CAMLprim value LFUN(sqr_nrm2_stub)(
value vSTABLE, value vN, value vOFSX, value vINCX, value vX)
{
CAMLparam1(vX);
integer GET_INT(N), GET_INT(INCX);
REAL res;
VEC_PARAMS(X);
caml_enter_blocking_section(); /* Allow other threads */
if (Bool_val(vSTABLE)) {
#ifndef LACAML_DOUBLE
res = scnrm2_(&N, X_data, &INCX);
#else
res = dznrm2_(&N, X_data, &INCX);
#endif
res *= res;
} else {
COMPLEX cres = FUN(dotc)(&N, X_data, &INCX, X_data, &INCX);
res = cres.r;
}
caml_leave_blocking_section(); /* Disallow other threads */
CAMLreturn(caml_copy_double(res));
}
/*! return its Euclidean norm */
inline double nrm2(const zrovector& vec)
{
#ifdef CPPL_VERBOSE
std::cerr << "# [MARK] nrm2(const zrovector&)"
<< std::endl;
#endif//CPPL_VERBOSE
return dznrm2_(vec.L, vec.Array, 1);
}
void test17 ( void )
/******************************************************************************/
/*
Purpose:
TEST17 tests DZNRM2.
Modified:
01 April 2007
Author:
John Burkardt
*/
{
# define N 5
int i;
int incx;
int ncopy;
double norm;
doublecomplex x[N] = {
{ 2.0, - 1.0 },
{-4.0, - 2.0 },
{ 3.0, + 1.0 },
{ 2.0, + 2.0 },
{-1.0, - 1.0 }
};
printf ( "\n" );
printf ( "TEST17\n" );
printf ( " DZNRM2 returns the Euclidean norm of a complex vector.\n" );
printf ( "\n" );
printf ( " The vector X:\n" );
printf ( "\n" );
for ( i = 0; i < N; i++ )
{
printf ( " %6d %6f %6f\n",
i, x[i].r, x[i].i );
}
ncopy = N;
incx = 1;
norm = dznrm2_ ( &ncopy, x, &incx );
printf ( "\n" );
printf ( " The L2 norm of X is %f\n", norm );
return;
# undef N
}
int toScalarC(int code, KCVEC(x), DVEC(r)) {
REQUIRES(rn==1,BAD_SIZE);
DEBUGMSG("toScalarC");
double res;
integer one = 1;
integer n = xn;
switch(code) {
case 0: { res = dznrm2_(&n,xp,&one); break; }
case 1: { res = dzasum_(&n,xp,&one); break; }
default: ERROR(BAD_CODE);
}
rp[0] = res;
OK
}
/* Subroutine */ int zlaghe_(integer *n, integer *k, doublereal *d,
doublecomplex *a, integer *lda, integer *iseed, doublecomplex *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double z_abs(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
doublecomplex *, doublecomplex *);
/* Local variables */
extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static integer i, j;
static doublecomplex alpha;
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zhemv_(char *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), zaxpy_(integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static doublecomplex wa, wb;
static doublereal wn;
extern /* Subroutine */ int xerbla_(char *, integer *), zlarnv_(
integer *, integer *, integer *, doublecomplex *);
static doublecomplex tau;
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZLAGHE generates a complex hermitian matrix A, by pre- and post-
multiplying a real diagonal matrix D with a random unitary matrix:
A = U*D*U'. The semi-bandwidth may then be reduced to k by additional
unitary transformations.
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
K (input) INTEGER
The number of nonzero subdiagonals within the band of A.
0 <= K <= N-1.
D (input) DOUBLE PRECISION array, dimension (N)
The diagonal elements of the diagonal matrix D.
A (output) COMPLEX*16 array, dimension (LDA,N)
The generated n by n hermitian matrix A (the full matrix is
stored).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= N.
ISEED (input/output) INTEGER array, dimension (4)
On entry, the seed of the random number generator; the array
elements must be between 0 and 4095, and ISEED(4) must be
odd.
On exit, the seed is updated.
WORK (workspace) COMPLEX*16 array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
--d;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*k < 0 || *k > *n - 1) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("ZLAGHE", &i__1);
return 0;
}
/* initialize lower triangle of A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
i__3 = i + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i = 1; i <= i__1; ++i) {
i__2 = i + i * a_dim1;
i__3 = i;
a[i__2].r = d[i__3], a[i__2].i = 0.;
/* L30: */
}
/* Generate lower triangle of hermitian matrix */
for (i = *n - 1; i >= 1; --i) {
/* generate random reflection */
i__1 = *n - i + 1;
zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i + 1;
wn = dznrm2_(&i__1, &work[1], &c__1);
d__1 = wn / z_abs(&work[1]);
z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__1 = *n - i;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__1, &z__1, &work[2], &c__1);
work[1].r = 1., work[1].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply random reflection to A(i:n,i:n) from the left
and the right
compute y := tau * A * u */
i__1 = *n - i + 1;
zhemv_("Lower", &i__1, &tau, &a[i + i * a_dim1], lda, &work[1], &c__1,
&c_b1, &work[*n + 1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
z__3.r = -.5, z__3.i = 0.;
z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i +
z__3.i * tau.r;
i__1 = *n - i + 1;
zdotc_(&z__4, &i__1, &work[*n + 1], &c__1, &work[1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i
+ z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__1 = *n - i + 1;
zaxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
/* apply the transformation as a rank-2 update to A(i:n,i:n) */
i__1 = *n - i + 1;
z__1.r = -1., z__1.i = 0.;
zher2_("Lower", &i__1, &z__1, &work[1], &c__1, &work[*n + 1], &c__1, &
a[i + i * a_dim1], lda);
/* L40: */
}
/* Reduce number of subdiagonals to K */
i__1 = *n - 1 - *k;
for (i = 1; i <= i__1; ++i) {
/* generate reflection to annihilate A(k+i+1:n,i) */
i__2 = *n - *k - i + 1;
wn = dznrm2_(&i__2, &a[*k + i + i * a_dim1], &c__1);
d__1 = wn / z_abs(&a[*k + i + i * a_dim1]);
i__2 = *k + i + i * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = *k + i + i * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *n - *k - i;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[*k + i + 1 + i * a_dim1], &c__1);
i__2 = *k + i + i * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i + (i + 1)
* a_dim1], lda, &a[*k + i + i * a_dim1], &c__1, &c_b1, &work[
1], &c__1);
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__1, &a[*k + i + i * a_dim1], &c__1, &work[1],
&c__1, &a[*k + i + (i + 1) * a_dim1], lda);
/* apply reflection to A(k+i:n,k+i:n) from the left and the rig
ht
compute y := tau * A * u */
i__2 = *n - *k - i + 1;
zhemv_("Lower", &i__2, &tau, &a[*k + i + (*k + i) * a_dim1], lda, &a[*
k + i + i * a_dim1], &c__1, &c_b1, &work[1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
z__3.r = -.5, z__3.i = 0.;
z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i +
z__3.i * tau.r;
i__2 = *n - *k - i + 1;
zdotc_(&z__4, &i__2, &work[1], &c__1, &a[*k + i + i * a_dim1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i
+ z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = *n - *k - i + 1;
zaxpy_(&i__2, &alpha, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1)
;
/* apply hermitian rank-2 update to A(k+i:n,k+i:n) */
i__2 = *n - *k - i + 1;
z__1.r = -1., z__1.i = 0.;
zher2_("Lower", &i__2, &z__1, &a[*k + i + i * a_dim1], &c__1, &work[1]
, &c__1, &a[*k + i + (*k + i) * a_dim1], lda);
i__2 = *k + i + i * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = *n;
for (j = *k + i + 1; j <= i__2; ++j) {
i__3 = j + i * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L50: */
}
/* L60: */
}
/* Store full hermitian matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
i__3 = j + i * a_dim1;
d_cnjg(&z__1, &a[i + j * a_dim1]);
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L70: */
}
/* L80: */
}
return 0;
/* End of ZLAGHE */
} /* zlaghe_ */
/* Subroutine */ int zneigh_(doublereal *rnorm, integer *n, doublecomplex *
h__, integer *ldh, doublecomplex *ritz, doublecomplex *bounds,
doublecomplex *q, integer *ldq, doublecomplex *workl, doublereal *
rwork, integer *ierr)
{
/* System generated locals */
integer h_dim1, h_offset, q_dim1, q_offset, i__1;
doublereal d__1;
/* Local variables */
static integer j;
static real t0, t1;
static doublecomplex vl[1];
static doublereal temp;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zmout_(integer *, integer *, integer
*, doublecomplex *, integer *, integer *, char *, ftnlen), zvout_(
integer *, integer *, doublecomplex *, integer *, char *, ftnlen);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int second_(real *);
static logical select[1];
static integer msglvl;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen),
zlahqr_(logical *, logical *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, integer *), ztrevc_(char *, char *,
logical *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, integer *,
doublecomplex *, doublereal *, integer *, ftnlen, ftnlen),
zdscal_(integer *, doublereal *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %------------------------% */
/* | Local Scalars & Arrays | */
/* %------------------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
/* Parameter adjustments */
--rwork;
--workl;
--bounds;
--ritz;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
/* Function Body */
second_(&t0);
msglvl = debug_1.mceigh;
if (msglvl > 2) {
zmout_(&debug_1.logfil, n, n, &h__[h_offset], ldh, &debug_1.ndigit,
"_neigh: Entering upper Hessenberg matrix H ", (ftnlen)43);
}
/* %----------------------------------------------------------% */
/* | 1. Compute the eigenvalues, the last components of the | */
/* | corresponding Schur vectors and the full Schur form T | */
/* | of the current upper Hessenberg matrix H. | */
/* | zlahqr returns the full Schur form of H | */
/* | in WORKL(1:N**2), and the Schur vectors in q. | */
/* %----------------------------------------------------------% */
zlacpy_("All", n, n, &h__[h_offset], ldh, &workl[1], n, (ftnlen)3);
zlaset_("All", n, n, &c_b2, &c_b1, &q[q_offset], ldq, (ftnlen)3);
zlahqr_(&c_true, &c_true, n, &c__1, n, &workl[1], ldh, &ritz[1], &c__1, n,
&q[q_offset], ldq, ierr);
if (*ierr != 0) {
goto L9000;
}
zcopy_(n, &q[*n - 1 + q_dim1], ldq, &bounds[1], &c__1);
if (msglvl > 1) {
zvout_(&debug_1.logfil, n, &bounds[1], &debug_1.ndigit, "_neigh: las"
"t row of the Schur matrix for H", (ftnlen)42);
}
/* %----------------------------------------------------------% */
/* | 2. Compute the eigenvectors of the full Schur form T and | */
/* | apply the Schur vectors to get the corresponding | */
/* | eigenvectors. | */
/* %----------------------------------------------------------% */
ztrevc_("Right", "Back", select, n, &workl[1], n, vl, n, &q[q_offset],
ldq, n, n, &workl[*n * *n + 1], &rwork[1], ierr, (ftnlen)5, (
ftnlen)4);
if (*ierr != 0) {
goto L9000;
}
/* %------------------------------------------------% */
/* | Scale the returning eigenvectors so that their | */
/* | Euclidean norms are all one. LAPACK subroutine | */
/* | ztrevc returns each eigenvector normalized so | */
/* | that the element of largest magnitude has | */
/* | magnitude 1; here the magnitude of a complex | */
/* | number (x,y) is taken to be |x| + |y|. | */
/* %------------------------------------------------% */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp = dznrm2_(n, &q[j * q_dim1 + 1], &c__1);
d__1 = 1. / temp;
zdscal_(n, &d__1, &q[j * q_dim1 + 1], &c__1);
/* L10: */
}
if (msglvl > 1) {
zcopy_(n, &q[*n + q_dim1], ldq, &workl[1], &c__1);
zvout_(&debug_1.logfil, n, &workl[1], &debug_1.ndigit, "_neigh: Last"
" row of the eigenvector matrix for H", (ftnlen)48);
}
/* %----------------------------% */
/* | Compute the Ritz estimates | */
/* %----------------------------% */
zcopy_(n, &q[*n + q_dim1], n, &bounds[1], &c__1);
zdscal_(n, rnorm, &bounds[1], &c__1);
if (msglvl > 2) {
zvout_(&debug_1.logfil, n, &ritz[1], &debug_1.ndigit, "_neigh: The e"
"igenvalues of H", (ftnlen)28);
zvout_(&debug_1.logfil, n, &bounds[1], &debug_1.ndigit, "_neigh: Rit"
"z estimates for the eigenvalues of H", (ftnlen)47);
}
second_(&t1);
timing_1.tceigh += t1 - t0;
L9000:
return 0;
/* %---------------% */
/* | End of zneigh | */
/* %---------------% */
} /* zneigh_ */
/* ----------------------------------------------------------------------| */
/* Subroutine */ int zgexpv(integer *n, integer *m, doublereal *t,
doublecomplex *v, doublecomplex *w, doublereal *tol, doublereal *
anorm, doublecomplex *wsp, integer *lwsp, integer *iwsp, integer *
liwsp, S_fp matvec, void *matvecdata, integer *itrace, integer *iflag)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
complex q__1;
doublecomplex z__1;
/* Builtin functions */
/* Subroutine */ int s_stop(char *, ftnlen);
double sqrt(doublereal), d_sign(doublereal *, doublereal *), pow_di(
doublereal *, integer *), pow_dd(doublereal *, doublereal *),
d_lg10(doublereal *);
integer i_dnnt(doublereal *);
double d_int(doublereal *);
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle();
double z_abs(doublecomplex *);
/* Local variables */
static integer ibrkflag;
static doublereal step_min__, step_max__;
static integer i__, j;
static doublereal break_tol__;
static integer k1;
static doublereal p1, p2, p3;
static integer ih, mh, iv, ns, mx;
static doublereal xm;
static integer j1v;
static doublecomplex hij;
static doublereal sgn, eps, hj1j, sqr1, beta, hump;
static integer ifree, lfree;
static doublereal t_old__;
static integer iexph;
static doublereal t_new__;
static integer nexph;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal t_now__;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, ftnlen);
static integer nstep;
static doublereal t_out__;
static integer nmult;
static doublereal vnorm;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static integer nscale;
static doublereal rndoff;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), zgpadm_(integer *, integer *,
doublereal *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, integer *, integer *, integer *), znchbv_(
integer *, doublereal *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *);
static doublereal t_step__, avnorm;
static integer ireject;
static doublereal err_loc__;
static integer nreject, mbrkdwn;
static doublereal tbrkdwn, s_error__, x_error__;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 6, 0, 0, 0 };
static cilist io___48 = { 0, 6, 0, 0, 0 };
static cilist io___49 = { 0, 6, 0, 0, 0 };
static cilist io___50 = { 0, 6, 0, 0, 0 };
static cilist io___51 = { 0, 6, 0, 0, 0 };
static cilist io___52 = { 0, 6, 0, 0, 0 };
static cilist io___53 = { 0, 6, 0, 0, 0 };
static cilist io___54 = { 0, 6, 0, 0, 0 };
static cilist io___55 = { 0, 6, 0, 0, 0 };
static cilist io___56 = { 0, 6, 0, 0, 0 };
static cilist io___57 = { 0, 6, 0, 0, 0 };
static cilist io___58 = { 0, 6, 0, 0, 0 };
static cilist io___59 = { 0, 6, 0, 0, 0 };
/* -----Purpose----------------------------------------------------------| */
/* --- ZGEXPV computes w = exp(t*A)*v */
/* for a Zomplex (i.e., complex double precision) matrix A */
/* It does not compute the matrix exponential in isolation but */
/* instead, it computes directly the action of the exponential */
/* operator on the operand vector. This way of doing so allows */
/* for addressing large sparse problems. */
/* The method used is based on Krylov subspace projection */
/* techniques and the matrix under consideration interacts only */
/* via the external routine `matvec' performing the matrix-vector */
/* product (matrix-free method). */
/* -----Arguments--------------------------------------------------------| */
/* n : (input) order of the principal matrix A. */
/* m : (input) maximum size for the Krylov basis. */
/* t : (input) time at wich the solution is needed (can be < 0). */
/* v(n) : (input) given operand vector. */
/* w(n) : (output) computed approximation of exp(t*A)*v. */
/* tol : (input/output) the requested accuracy tolerance on w. */
/* If on input tol=0.0d0 or tol is too small (tol.le.eps) */
/* the internal value sqrt(eps) is used, and tol is set to */
/* sqrt(eps) on output (`eps' denotes the machine epsilon). */
/* (`Happy breakdown' is assumed if h(j+1,j) .le. anorm*tol) */
/* anorm : (input) an approximation of some norm of A. */
/* wsp(lwsp): (workspace) lwsp .ge. n*(m+1)+n+(m+2)^2+4*(m+2)^2+ideg+1 */
/* +---------+-------+---------------+ */
/* (actually, ideg=6) V H wsp for PADE */
/* iwsp(liwsp): (workspace) liwsp .ge. m+2 */
/* matvec : external subroutine for matrix-vector multiplication. */
/* synopsis: matvec( x, y ) */
/* complex*16 x(*), y(*) */
/* computes: y(1:n) <- A*x(1:n) */
/* where A is the principal matrix. */
/* itrace : (input) running mode. 0=silent, 1=print step-by-step info */
/* iflag : (output) exit flag. */
/* <0 - bad input arguments */
/* 0 - no problem */
/* 1 - maximum number of steps reached without convergence */
/* 2 - requested tolerance was too high */
/* -----Accounts on the computation--------------------------------------| */
/* Upon exit, an interested user may retrieve accounts on the */
/* computations. They are located in the workspace arrays wsp and */
/* iwsp as indicated below: */
/* location mnemonic description */
/* -----------------------------------------------------------------| */
/* iwsp(1) = nmult, number of matrix-vector multiplications used */
/* iwsp(2) = nexph, number of Hessenberg matrix exponential evaluated */
/* iwsp(3) = nscale, number of repeated squaring involved in Pade */
/* iwsp(4) = nstep, number of integration steps used up to completion */
/* iwsp(5) = nreject, number of rejected step-sizes */
/* iwsp(6) = ibrkflag, set to 1 if `happy breakdown' and 0 otherwise */
/* iwsp(7) = mbrkdwn, if `happy brkdown', basis-size when it occured */
/* -----------------------------------------------------------------| */
/* wsp(1) = step_min, minimum step-size used during integration */
/* wsp(2) = step_max, maximum step-size used during integration */
/* wsp(3) = x_round, maximum among all roundoff errors (lower bound) */
/* wsp(4) = s_round, sum of roundoff errors (lower bound) */
/* wsp(5) = x_error, maximum among all local truncation errors */
/* wsp(6) = s_error, global sum of local truncation errors */
/* wsp(7) = tbrkdwn, if `happy breakdown', time when it occured */
/* wsp(8) = t_now, integration domain successfully covered */
/* wsp(9) = hump, i.e., max||exp(sA)||, s in [0,t] (or [t,0] if t<0) */
/* wsp(10) = ||w||/||v||, scaled norm of the solution w. */
/* -----------------------------------------------------------------| */
/* The `hump' is a measure of the conditioning of the problem. The */
/* matrix exponential is well-conditioned if hump = 1, whereas it is */
/* poorly-conditioned if hump >> 1. However the solution can still be */
/* relatively fairly accurate even when the hump is large (the hump */
/* is an upper bound), especially when the hump and the scaled norm */
/* of w [this is also computed and returned in wsp(10)] are of the */
/* same order of magnitude (further details in reference below). */
/* ----------------------------------------------------------------------| */
/* -----The following parameters may also be adjusted herein-------------| */
/* mxstep : maximum allowable number of integration steps. */
/* The value 0 means an infinite number of steps. */
/* mxreject: maximum allowable number of rejections at each step. */
/* The value 0 means an infinite number of rejections. */
/* ideg : the Pade approximation of type (ideg,ideg) is used as */
/* an approximation to exp(H). The value 0 switches to the */
/* uniform rational Chebyshev approximation of type (14,14) */
/* delta : local truncation error `safety factor' */
/* gamma : stepsize `shrinking factor' */
/* ----------------------------------------------------------------------| */
/* Roger B. Sidje ([email protected]) */
/* EXPOKIT: Software Package for Computing Matrix Exponentials. */
/* ACM - Transactions On Mathematical Software, 24(1):130-156, 1998 */
/* ----------------------------------------------------------------------| */
/* --- check restrictions on input parameters ... */
/* Parameter adjustments */
--w;
--v;
--wsp;
--iwsp;
/* Function Body */
*iflag = 0;
/* Computing 2nd power */
i__1 = *m + 2;
if (*lwsp < *n * (*m + 2) + i__1 * i__1 * 5 + 7) {
*iflag = -1;
}
if (*liwsp < *m + 2) {
*iflag = -2;
}
if (*m >= *n || *m <= 0) {
*iflag = -3;
}
if (*iflag != 0) {
s_stop("bad sizes (in input of ZGEXPV)", (ftnlen)30);
}
/* --- initialisations ... */
k1 = 2;
mh = *m + 2;
iv = 1;
ih = iv + *n * (*m + 1) + *n;
ifree = ih + mh * mh;
lfree = *lwsp - ifree + 1;
ibrkflag = 0;
mbrkdwn = *m;
nmult = 0;
nreject = 0;
nexph = 0;
nscale = 0;
t_out__ = abs(*t);
tbrkdwn = 0.;
step_min__ = t_out__;
step_max__ = 0.;
nstep = 0;
s_error__ = 0.;
x_error__ = 0.;
t_now__ = 0.;
t_new__ = 0.;
p1 = 1.3333333333333333;
L1:
p2 = p1 - 1.;
p3 = p2 + p2 + p2;
eps = (d__1 = p3 - 1., abs(d__1));
if (eps == 0.) {
goto L1;
}
if (*tol <= eps) {
*tol = sqrt(eps);
}
rndoff = eps * *anorm;
break_tol__ = 1e-7;
/* >>> break_tol = tol */
/* >>> break_tol = anorm*tol */
sgn = d_sign(&c_b6, t);
zcopy_(n, &v[1], &c__1, &w[1], &c__1);
beta = dznrm2_(n, &w[1], &c__1);
vnorm = beta;
hump = beta;
/* --- obtain the very first stepsize ... */
sqr1 = sqrt(.1);
xm = 1. / (doublereal) (*m);
d__1 = (*m + 1) / 2.72;
i__1 = *m + 1;
p2 = *tol * pow_di(&d__1, &i__1) * sqrt((*m + 1) * 6.2800000000000002);
d__1 = p2 / (beta * 4. * *anorm);
t_new__ = 1. / *anorm * pow_dd(&d__1, &xm);
d__1 = d_lg10(&t_new__) - sqr1;
i__1 = i_dnnt(&d__1) - 1;
p1 = pow_di(&c_b10, &i__1);
d__1 = t_new__ / p1 + .55;
t_new__ = d_int(&d__1) * p1;
/* --- step-by-step integration ... */
L100:
if (t_now__ >= t_out__) {
goto L500;
}
++nstep;
/* Computing MIN */
d__1 = t_out__ - t_now__;
t_step__ = min(d__1,t_new__);
p1 = 1. / beta;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iv + i__ - 1;
i__3 = i__;
z__1.r = p1 * w[i__3].r, z__1.i = p1 * w[i__3].i;
wsp[i__2].r = z__1.r, wsp[i__2].i = z__1.i;
}
i__1 = mh * mh;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = ih + i__ - 1;
wsp[i__2].r = 0., wsp[i__2].i = 0.;
}
/* --- Arnoldi loop ... */
j1v = iv + *n;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
++nmult;
(*matvec)(matvecdata, &wsp[j1v - *n], &wsp[j1v]);
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
zdotc_(&z__1, n, &wsp[iv + (i__ - 1) * *n], &c__1, &wsp[j1v], &
c__1);
hij.r = z__1.r, hij.i = z__1.i;
z__1.r = -hij.r, z__1.i = -hij.i;
zaxpy_(n, &z__1, &wsp[iv + (i__ - 1) * *n], &c__1, &wsp[j1v], &
c__1);
i__3 = ih + (j - 1) * mh + i__ - 1;
wsp[i__3].r = hij.r, wsp[i__3].i = hij.i;
}
hj1j = dznrm2_(n, &wsp[j1v], &c__1);
/* --- if `happy breakdown' go straightforward at the end ... */
if (hj1j <= break_tol__) {
s_wsle(&io___40);
do_lio(&c__9, &c__1, "happy breakdown: mbrkdwn =", (ftnlen)26);
do_lio(&c__3, &c__1, (char *)&j, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, " h =", (ftnlen)4);
do_lio(&c__5, &c__1, (char *)&hj1j, (ftnlen)sizeof(doublereal));
e_wsle();
k1 = 0;
ibrkflag = 1;
mbrkdwn = j;
tbrkdwn = t_now__;
t_step__ = t_out__ - t_now__;
goto L300;
}
i__2 = ih + (j - 1) * mh + j;
q__1.r = hj1j, q__1.i = (float)0.;
wsp[i__2].r = q__1.r, wsp[i__2].i = q__1.i;
d__1 = 1. / hj1j;
zdscal_(n, &d__1, &wsp[j1v], &c__1);
j1v += *n;
/* L200: */
}
++nmult;
(*matvec)(matvecdata, &wsp[j1v - *n], &wsp[j1v]);
avnorm = dznrm2_(n, &wsp[j1v], &c__1);
/* --- set 1 for the 2-corrected scheme ... */
L300:
i__1 = ih + *m * mh + *m + 1;
wsp[i__1].r = 1., wsp[i__1].i = 0.;
/* --- loop while ireject<mxreject until the tolerance is reached ... */
ireject = 0;
L401:
/* --- compute w = beta*V*exp(t_step*H)*e1 ... */
++nexph;
mx = mbrkdwn + k1;
if (TRUE_) {
/* --- irreducible rational Pade approximation ... */
d__1 = sgn * t_step__;
zgpadm_(&c__6, &mx, &d__1, &wsp[ih], &mh, &wsp[ifree], &lfree, &iwsp[
1], &iexph, &ns, iflag);
iexph = ifree + iexph - 1;
nscale += ns;
} else {
/* --- uniform rational Chebyshev approximation ... */
iexph = ifree;
i__1 = mx;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iexph + i__ - 1;
wsp[i__2].r = 0., wsp[i__2].i = 0.;
}
i__1 = iexph;
wsp[i__1].r = 1., wsp[i__1].i = 0.;
d__1 = sgn * t_step__;
znchbv_(&mx, &d__1, &wsp[ih], &mh, &wsp[iexph], &wsp[ifree + mx]);
}
/* L402: */
/* --- error estimate ... */
if (k1 == 0) {
err_loc__ = *tol;
} else {
p1 = z_abs(&wsp[iexph + *m]) * beta;
p2 = z_abs(&wsp[iexph + *m + 1]) * beta * avnorm;
if (p1 > p2 * 10.) {
err_loc__ = p2;
xm = 1. / (doublereal) (*m);
} else if (p1 > p2) {
err_loc__ = p1 * p2 / (p1 - p2);
xm = 1. / (doublereal) (*m);
} else {
err_loc__ = p1;
xm = 1. / (doublereal) (*m - 1);
}
}
/* --- reject the step-size if the error is not acceptable ... */
if (k1 != 0 && err_loc__ > t_step__ * 1.2 * *tol) {
t_old__ = t_step__;
d__1 = t_step__ * *tol / err_loc__;
t_step__ = t_step__ * .9 * pow_dd(&d__1, &xm);
d__1 = d_lg10(&t_step__) - sqr1;
i__1 = i_dnnt(&d__1) - 1;
p1 = pow_di(&c_b10, &i__1);
d__1 = t_step__ / p1 + .55;
t_step__ = d_int(&d__1) * p1;
if (*itrace != 0) {
s_wsle(&io___48);
do_lio(&c__9, &c__1, "t_step =", (ftnlen)8);
do_lio(&c__5, &c__1, (char *)&t_old__, (ftnlen)sizeof(doublereal))
;
e_wsle();
s_wsle(&io___49);
do_lio(&c__9, &c__1, "err_loc =", (ftnlen)9);
do_lio(&c__5, &c__1, (char *)&err_loc__, (ftnlen)sizeof(
doublereal));
e_wsle();
s_wsle(&io___50);
do_lio(&c__9, &c__1, "err_required =", (ftnlen)14);
d__1 = t_old__ * 1.2 * *tol;
do_lio(&c__5, &c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsle();
s_wsle(&io___51);
do_lio(&c__9, &c__1, "stepsize rejected, stepping down to:", (
ftnlen)36);
do_lio(&c__5, &c__1, (char *)&t_step__, (ftnlen)sizeof(doublereal)
);
e_wsle();
}
++ireject;
++nreject;
if (FALSE_) {
s_wsle(&io___52);
do_lio(&c__9, &c__1, "Failure in ZGEXPV: ---", (ftnlen)22);
e_wsle();
s_wsle(&io___53);
do_lio(&c__9, &c__1, "The requested tolerance is too high.", (
ftnlen)36);
e_wsle();
s_wsle(&io___54);
do_lio(&c__9, &c__1, "Rerun with a smaller value.", (ftnlen)27);
e_wsle();
*iflag = 2;
return 0;
}
goto L401;
}
/* --- now update w = beta*V*exp(t_step*H)*e1 and the hump ... */
/* Computing MAX */
i__1 = 0, i__2 = k1 - 1;
mx = mbrkdwn + max(i__1,i__2);
q__1.r = beta, q__1.i = (float)0.;
hij.r = q__1.r, hij.i = q__1.i;
zgemv_("n", n, &mx, &hij, &wsp[iv], n, &wsp[iexph], &c__1, &c_b1, &w[1], &
c__1, (ftnlen)1);
beta = dznrm2_(n, &w[1], &c__1);
hump = max(hump,beta);
/* --- suggested value for the next stepsize ... */
d__1 = t_step__ * *tol / err_loc__;
t_new__ = t_step__ * .9 * pow_dd(&d__1, &xm);
d__1 = d_lg10(&t_new__) - sqr1;
i__1 = i_dnnt(&d__1) - 1;
p1 = pow_di(&c_b10, &i__1);
d__1 = t_new__ / p1 + .55;
t_new__ = d_int(&d__1) * p1;
err_loc__ = max(err_loc__,rndoff);
/* --- update the time covered ... */
t_now__ += t_step__;
/* --- display and keep some information ... */
if (*itrace != 0) {
s_wsle(&io___55);
do_lio(&c__9, &c__1, "integration", (ftnlen)11);
do_lio(&c__3, &c__1, (char *)&nstep, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, "---------------------------------", (ftnlen)33);
e_wsle();
s_wsle(&io___56);
do_lio(&c__9, &c__1, "scale-square =", (ftnlen)14);
do_lio(&c__3, &c__1, (char *)&ns, (ftnlen)sizeof(integer));
e_wsle();
s_wsle(&io___57);
do_lio(&c__9, &c__1, "step_size =", (ftnlen)11);
do_lio(&c__5, &c__1, (char *)&t_step__, (ftnlen)sizeof(doublereal));
e_wsle();
s_wsle(&io___58);
do_lio(&c__9, &c__1, "err_loc =", (ftnlen)11);
do_lio(&c__5, &c__1, (char *)&err_loc__, (ftnlen)sizeof(doublereal));
e_wsle();
s_wsle(&io___59);
do_lio(&c__9, &c__1, "next_step =", (ftnlen)11);
do_lio(&c__5, &c__1, (char *)&t_new__, (ftnlen)sizeof(doublereal));
e_wsle();
}
step_min__ = min(step_min__,t_step__);
step_max__ = max(step_max__,t_step__);
s_error__ += err_loc__;
x_error__ = max(x_error__,err_loc__);
if (nstep < 500) {
goto L100;
}
*iflag = 1;
L500:
iwsp[1] = nmult;
iwsp[2] = nexph;
iwsp[3] = nscale;
iwsp[4] = nstep;
iwsp[5] = nreject;
iwsp[6] = ibrkflag;
iwsp[7] = mbrkdwn;
q__1.r = step_min__, q__1.i = (float)0.;
wsp[1].r = q__1.r, wsp[1].i = q__1.i;
q__1.r = step_max__, q__1.i = (float)0.;
wsp[2].r = q__1.r, wsp[2].i = q__1.i;
wsp[3].r = (float)0., wsp[3].i = (float)0.;
wsp[4].r = (float)0., wsp[4].i = (float)0.;
q__1.r = x_error__, q__1.i = (float)0.;
wsp[5].r = q__1.r, wsp[5].i = q__1.i;
q__1.r = s_error__, q__1.i = (float)0.;
wsp[6].r = q__1.r, wsp[6].i = q__1.i;
q__1.r = tbrkdwn, q__1.i = (float)0.;
wsp[7].r = q__1.r, wsp[7].i = q__1.i;
d__1 = sgn * t_now__;
q__1.r = d__1, q__1.i = (float)0.;
wsp[8].r = q__1.r, wsp[8].i = q__1.i;
d__1 = hump / vnorm;
q__1.r = d__1, q__1.i = (float)0.;
wsp[9].r = q__1.r, wsp[9].i = q__1.i;
d__1 = beta / vnorm;
q__1.r = d__1, q__1.i = (float)0.;
wsp[10].r = q__1.r, wsp[10].i = q__1.i;
return 0;
} /* zgexpv_ */
/* Subroutine */ int znaitr_(integer *ido, char *bmat, integer *n, integer *k,
integer *np, integer *nb, doublecomplex *resid, doublereal *rnorm,
doublecomplex *v, integer *ldv, doublecomplex *h__, integer *ldh,
integer *ipntr, doublecomplex *workd, integer *info, ftnlen bmat_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, v_dim1, v_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *), sqrt(doublereal);
/* Local variables */
static integer i__, j;
static real t0, t1, t2, t3, t4, t5;
static integer jj, ipj, irj, ivj;
static doublereal ulp, tst1;
static integer ierr, iter;
static doublereal unfl, ovfl;
static integer itry;
static doublereal temp1;
static logical orth1, orth2, step3, step4;
static doublereal betaj;
static integer infol;
static doublecomplex cnorm;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal rtemp[2];
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, ftnlen);
static doublereal wnorm;
extern /* Subroutine */ int dvout_(integer *, integer *, doublereal *,
integer *, char *, ftnlen), zcopy_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), ivout_(integer *, integer
*, integer *, integer *, char *, ftnlen), zaxpy_(integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *), zmout_(integer *, integer *, integer *, doublecomplex
*, integer *, integer *, char *, ftnlen), zvout_(integer *,
integer *, doublecomplex *, integer *, char *, ftnlen);
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static doublereal rnorm1;
extern /* Subroutine */ int zgetv0_(integer *, char *, integer *, logical
*, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublereal *, integer *, doublecomplex *,
integer *, ftnlen);
extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int second_(real *), zdscal_(integer *,
doublereal *, doublecomplex *, integer *);
static logical rstart;
static integer msglvl;
static doublereal smlnum;
extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *,
doublecomplex *, ftnlen);
extern /* Subroutine */ int zlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublecomplex *,
integer *, integer *, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %--------------% */
/* | Local Arrays | */
/* %--------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------% */
/* | Data statements | */
/* %-----------------% */
/* Parameter adjustments */
--workd;
--resid;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--ipntr;
/* Function Body */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
if (first) {
/* %-----------------------------------------% */
/* | Set machine-dependent constants for the | */
/* | the splitting and deflation criterion. | */
/* | If norm(H) <= sqrt(OVFL), | */
/* | overflow should not occur. | */
/* | REFERENCE: LAPACK subroutine zlahqr | */
/* %-----------------------------------------% */
unfl = dlamch_("safe minimum", (ftnlen)12);
z__1.r = 1. / unfl, z__1.i = 0. / unfl;
ovfl = z__1.r;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("precision", (ftnlen)9);
smlnum = unfl * (*n / ulp);
first = FALSE_;
}
if (*ido == 0) {
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
second_(&t0);
msglvl = debug_1.mcaitr;
/* %------------------------------% */
/* | Initial call to this routine | */
/* %------------------------------% */
*info = 0;
step3 = FALSE_;
step4 = FALSE_;
rstart = FALSE_;
orth1 = FALSE_;
orth2 = FALSE_;
j = *k + 1;
ipj = 1;
irj = ipj + *n;
ivj = irj + *n;
}
/* %-------------------------------------------------% */
/* | When in reverse communication mode one of: | */
/* | STEP3, STEP4, ORTH1, ORTH2, RSTART | */
/* | will be .true. when .... | */
/* | STEP3: return from computing OP*v_{j}. | */
/* | STEP4: return from computing B-norm of OP*v_{j} | */
/* | ORTH1: return from computing B-norm of r_{j+1} | */
/* | ORTH2: return from computing B-norm of | */
/* | correction to the residual vector. | */
/* | RSTART: return from OP computations needed by | */
/* | zgetv0. | */
/* %-------------------------------------------------% */
if (step3) {
goto L50;
}
if (step4) {
goto L60;
}
if (orth1) {
goto L70;
}
if (orth2) {
goto L90;
}
if (rstart) {
goto L30;
}
/* %-----------------------------% */
/* | Else this is the first step | */
/* %-----------------------------% */
/* %--------------------------------------------------------------% */
/* | | */
/* | A R N O L D I I T E R A T I O N L O O P | */
/* | | */
/* | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | */
/* %--------------------------------------------------------------% */
L1000:
if (msglvl > 1) {
ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: generat"
"ing Arnoldi vector number", (ftnlen)40);
dvout_(&debug_1.logfil, &c__1, rnorm, &debug_1.ndigit, "_naitr: B-no"
"rm of the current residual is", (ftnlen)41);
}
/* %---------------------------------------------------% */
/* | STEP 1: Check if the B norm of j-th residual | */
/* | vector is zero. Equivalent to determine whether | */
/* | an exact j-step Arnoldi factorization is present. | */
/* %---------------------------------------------------% */
betaj = *rnorm;
if (*rnorm > 0.) {
goto L40;
}
/* %---------------------------------------------------% */
/* | Invariant subspace found, generate a new starting | */
/* | vector which is orthogonal to the current Arnoldi | */
/* | basis and continue the iteration. | */
/* %---------------------------------------------------% */
if (msglvl > 0) {
ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: ****** "
"RESTART AT STEP ******", (ftnlen)37);
}
/* %---------------------------------------------% */
/* | ITRY is the loop variable that controls the | */
/* | maximum amount of times that a restart is | */
/* | attempted. NRSTRT is used by stat.h | */
/* %---------------------------------------------% */
betaj = 0.;
++timing_1.nrstrt;
itry = 1;
L20:
rstart = TRUE_;
*ido = 0;
L30:
/* %--------------------------------------% */
/* | If in reverse communication mode and | */
/* | RSTART = .true. flow returns here. | */
/* %--------------------------------------% */
zgetv0_(ido, bmat, &itry, &c_false, n, &j, &v[v_offset], ldv, &resid[1],
rnorm, &ipntr[1], &workd[1], &ierr, (ftnlen)1);
if (*ido != 99) {
goto L9000;
}
if (ierr < 0) {
++itry;
if (itry <= 3) {
goto L20;
}
/* %------------------------------------------------% */
/* | Give up after several restart attempts. | */
/* | Set INFO to the size of the invariant subspace | */
/* | which spans OP and exit. | */
/* %------------------------------------------------% */
*info = j - 1;
second_(&t1);
timing_1.tcaitr += t1 - t0;
*ido = 99;
goto L9000;
}
L40:
/* %---------------------------------------------------------% */
/* | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | */
/* | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | */
/* | when reciprocating a small RNORM, test against lower | */
/* | machine bound. | */
/* %---------------------------------------------------------% */
zcopy_(n, &resid[1], &c__1, &v[j * v_dim1 + 1], &c__1);
if (*rnorm >= unfl) {
temp1 = 1. / *rnorm;
zdscal_(n, &temp1, &v[j * v_dim1 + 1], &c__1);
zdscal_(n, &temp1, &workd[ipj], &c__1);
} else {
/* %-----------------------------------------% */
/* | To scale both v_{j} and p_{j} carefully | */
/* | use LAPACK routine zlascl | */
/* %-----------------------------------------% */
zlascl_("General", &i__, &i__, rnorm, &c_b27, n, &c__1, &v[j * v_dim1
+ 1], n, &infol, (ftnlen)7);
zlascl_("General", &i__, &i__, rnorm, &c_b27, n, &c__1, &workd[ipj],
n, &infol, (ftnlen)7);
}
/* %------------------------------------------------------% */
/* | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | */
/* | Note that this is not quite yet r_{j}. See STEP 4 | */
/* %------------------------------------------------------% */
step3 = TRUE_;
++timing_1.nopx;
second_(&t2);
zcopy_(n, &v[j * v_dim1 + 1], &c__1, &workd[ivj], &c__1);
ipntr[1] = ivj;
ipntr[2] = irj;
ipntr[3] = ipj;
*ido = 1;
/* %-----------------------------------% */
/* | Exit in order to compute OP*v_{j} | */
/* %-----------------------------------% */
goto L9000;
L50:
/* %----------------------------------% */
/* | Back from reverse communication; | */
/* | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | */
/* | if step3 = .true. | */
/* %----------------------------------% */
second_(&t3);
timing_1.tmvopx += t3 - t2;
step3 = FALSE_;
/* %------------------------------------------% */
/* | Put another copy of OP*v_{j} into RESID. | */
/* %------------------------------------------% */
zcopy_(n, &workd[irj], &c__1, &resid[1], &c__1);
/* %---------------------------------------% */
/* | STEP 4: Finish extending the Arnoldi | */
/* | factorization to length j. | */
/* %---------------------------------------% */
second_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
step4 = TRUE_;
ipntr[1] = irj;
ipntr[2] = ipj;
*ido = 2;
/* %-------------------------------------% */
/* | Exit in order to compute B*OP*v_{j} | */
/* %-------------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
zcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
}
L60:
/* %----------------------------------% */
/* | Back from reverse communication; | */
/* | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | */
/* | if step4 = .true. | */
/* %----------------------------------% */
if (*(unsigned char *)bmat == 'G') {
second_(&t3);
timing_1.tmvbx += t3 - t2;
}
step4 = FALSE_;
/* %-------------------------------------% */
/* | The following is needed for STEP 5. | */
/* | Compute the B-norm of OP*v_{j}. | */
/* %-------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1);
cnorm.r = z__1.r, cnorm.i = z__1.i;
d__1 = cnorm.r;
d__2 = d_imag(&cnorm);
wnorm = sqrt(dlapy2_(&d__1, &d__2));
} else if (*(unsigned char *)bmat == 'I') {
wnorm = dznrm2_(n, &resid[1], &c__1);
}
/* %-----------------------------------------% */
/* | Compute the j-th residual corresponding | */
/* | to the j step factorization. | */
/* | Use Classical Gram Schmidt and compute: | */
/* | w_{j} <- V_{j}^T * B * OP * v_{j} | */
/* | r_{j} <- OP*v_{j} - V_{j} * w_{j} | */
/* %-----------------------------------------% */
/* %------------------------------------------% */
/* | Compute the j Fourier coefficients w_{j} | */
/* | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | */
/* %------------------------------------------% */
zgemv_("C", n, &j, &c_b1, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b2, &
h__[j * h_dim1 + 1], &c__1, (ftnlen)1);
/* %--------------------------------------% */
/* | Orthogonalize r_{j} against V_{j}. | */
/* | RESID contains OP*v_{j}. See STEP 3. | */
/* %--------------------------------------% */
z__1.r = -1., z__1.i = -0.;
zgemv_("N", n, &j, &z__1, &v[v_offset], ldv, &h__[j * h_dim1 + 1], &c__1,
&c_b1, &resid[1], &c__1, (ftnlen)1);
if (j > 1) {
i__1 = j + (j - 1) * h_dim1;
z__1.r = betaj, z__1.i = 0.;
h__[i__1].r = z__1.r, h__[i__1].i = z__1.i;
}
second_(&t4);
orth1 = TRUE_;
second_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
zcopy_(n, &resid[1], &c__1, &workd[irj], &c__1);
ipntr[1] = irj;
ipntr[2] = ipj;
*ido = 2;
/* %----------------------------------% */
/* | Exit in order to compute B*r_{j} | */
/* %----------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
zcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
}
L70:
/* %---------------------------------------------------% */
/* | Back from reverse communication if ORTH1 = .true. | */
/* | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | */
/* %---------------------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
second_(&t3);
timing_1.tmvbx += t3 - t2;
}
orth1 = FALSE_;
/* %------------------------------% */
/* | Compute the B-norm of r_{j}. | */
/* %------------------------------% */
if (*(unsigned char *)bmat == 'G') {
zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1);
cnorm.r = z__1.r, cnorm.i = z__1.i;
d__1 = cnorm.r;
d__2 = d_imag(&cnorm);
*rnorm = sqrt(dlapy2_(&d__1, &d__2));
} else if (*(unsigned char *)bmat == 'I') {
*rnorm = dznrm2_(n, &resid[1], &c__1);
}
/* %-----------------------------------------------------------% */
/* | STEP 5: Re-orthogonalization / Iterative refinement phase | */
/* | Maximum NITER_ITREF tries. | */
/* | | */
/* | s = V_{j}^T * B * r_{j} | */
/* | r_{j} = r_{j} - V_{j}*s | */
/* | alphaj = alphaj + s_{j} | */
/* | | */
/* | The stopping criteria used for iterative refinement is | */
/* | discussed in Parlett's book SEP, page 107 and in Gragg & | */
/* | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | */
/* | Determine if we need to correct the residual. The goal is | */
/* | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | */
/* | The following test determines whether the sine of the | */
/* | angle between OP*x and the computed residual is less | */
/* | than or equal to 0.717. | */
/* %-----------------------------------------------------------% */
if (*rnorm > wnorm * .717f) {
goto L100;
}
iter = 0;
++timing_1.nrorth;
/* %---------------------------------------------------% */
/* | Enter the Iterative refinement phase. If further | */
/* | refinement is necessary, loop back here. The loop | */
/* | variable is ITER. Perform a step of Classical | */
/* | Gram-Schmidt using all the Arnoldi vectors V_{j} | */
/* %---------------------------------------------------% */
L80:
if (msglvl > 2) {
rtemp[0] = wnorm;
rtemp[1] = *rnorm;
dvout_(&debug_1.logfil, &c__2, rtemp, &debug_1.ndigit, "_naitr: re-o"
"rthogonalization; wnorm and rnorm are", (ftnlen)49);
zvout_(&debug_1.logfil, &j, &h__[j * h_dim1 + 1], &debug_1.ndigit,
"_naitr: j-th column of H", (ftnlen)24);
}
/* %----------------------------------------------------% */
/* | Compute V_{j}^T * B * r_{j}. | */
/* | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | */
/* %----------------------------------------------------% */
zgemv_("C", n, &j, &c_b1, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b2, &
workd[irj], &c__1, (ftnlen)1);
/* %---------------------------------------------% */
/* | Compute the correction to the residual: | */
/* | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | */
/* | The correction to H is v(:,1:J)*H(1:J,1:J) | */
/* | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | */
/* %---------------------------------------------% */
z__1.r = -1., z__1.i = -0.;
zgemv_("N", n, &j, &z__1, &v[v_offset], ldv, &workd[irj], &c__1, &c_b1, &
resid[1], &c__1, (ftnlen)1);
zaxpy_(&j, &c_b1, &workd[irj], &c__1, &h__[j * h_dim1 + 1], &c__1);
orth2 = TRUE_;
second_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
zcopy_(n, &resid[1], &c__1, &workd[irj], &c__1);
ipntr[1] = irj;
ipntr[2] = ipj;
*ido = 2;
/* %-----------------------------------% */
/* | Exit in order to compute B*r_{j}. | */
/* | r_{j} is the corrected residual. | */
/* %-----------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
zcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
}
L90:
/* %---------------------------------------------------% */
/* | Back from reverse communication if ORTH2 = .true. | */
/* %---------------------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
second_(&t3);
timing_1.tmvbx += t3 - t2;
}
/* %-----------------------------------------------------% */
/* | Compute the B-norm of the corrected residual r_{j}. | */
/* %-----------------------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1);
cnorm.r = z__1.r, cnorm.i = z__1.i;
d__1 = cnorm.r;
d__2 = d_imag(&cnorm);
rnorm1 = sqrt(dlapy2_(&d__1, &d__2));
} else if (*(unsigned char *)bmat == 'I') {
rnorm1 = dznrm2_(n, &resid[1], &c__1);
}
if (msglvl > 0 && iter > 0) {
ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: Iterati"
"ve refinement for Arnoldi residual", (ftnlen)49);
if (msglvl > 2) {
rtemp[0] = *rnorm;
rtemp[1] = rnorm1;
dvout_(&debug_1.logfil, &c__2, rtemp, &debug_1.ndigit, "_naitr: "
"iterative refinement ; rnorm and rnorm1 are", (ftnlen)51);
}
}
/* %-----------------------------------------% */
/* | Determine if we need to perform another | */
/* | step of re-orthogonalization. | */
/* %-----------------------------------------% */
if (rnorm1 > *rnorm * .717f) {
/* %---------------------------------------% */
/* | No need for further refinement. | */
/* | The cosine of the angle between the | */
/* | corrected residual vector and the old | */
/* | residual vector is greater than 0.717 | */
/* | In other words the corrected residual | */
/* | and the old residual vector share an | */
/* | angle of less than arcCOS(0.717) | */
/* %---------------------------------------% */
*rnorm = rnorm1;
} else {
/* %-------------------------------------------% */
/* | Another step of iterative refinement step | */
/* | is required. NITREF is used by stat.h | */
/* %-------------------------------------------% */
++timing_1.nitref;
*rnorm = rnorm1;
++iter;
if (iter <= 1) {
goto L80;
}
/* %-------------------------------------------------% */
/* | Otherwise RESID is numerically in the span of V | */
/* %-------------------------------------------------% */
i__1 = *n;
for (jj = 1; jj <= i__1; ++jj) {
i__2 = jj;
resid[i__2].r = 0., resid[i__2].i = 0.;
/* L95: */
}
*rnorm = 0.;
}
/* %----------------------------------------------% */
/* | Branch here directly if iterative refinement | */
/* | wasn't necessary or after at most NITER_REF | */
/* | steps of iterative refinement. | */
/* %----------------------------------------------% */
L100:
rstart = FALSE_;
orth2 = FALSE_;
second_(&t5);
timing_1.titref += t5 - t4;
/* %------------------------------------% */
/* | STEP 6: Update j = j+1; Continue | */
/* %------------------------------------% */
++j;
if (j > *k + *np) {
second_(&t1);
timing_1.tcaitr += t1 - t0;
*ido = 99;
i__1 = *k + *np - 1;
for (i__ = max(1,*k); i__ <= i__1; ++i__) {
/* %--------------------------------------------% */
/* | Check for splitting and deflation. | */
/* | Use a standard test as in the QR algorithm | */
/* | REFERENCE: LAPACK subroutine zlahqr | */
/* %--------------------------------------------% */
i__2 = i__ + i__ * h_dim1;
d__1 = h__[i__2].r;
d__2 = d_imag(&h__[i__ + i__ * h_dim1]);
i__3 = i__ + 1 + (i__ + 1) * h_dim1;
d__3 = h__[i__3].r;
d__4 = d_imag(&h__[i__ + 1 + (i__ + 1) * h_dim1]);
tst1 = dlapy2_(&d__1, &d__2) + dlapy2_(&d__3, &d__4);
if (tst1 == 0.) {
i__2 = *k + *np;
tst1 = zlanhs_("1", &i__2, &h__[h_offset], ldh, &workd[*n + 1]
, (ftnlen)1);
}
i__2 = i__ + 1 + i__ * h_dim1;
d__1 = h__[i__2].r;
d__2 = d_imag(&h__[i__ + 1 + i__ * h_dim1]);
/* Computing MAX */
d__3 = ulp * tst1;
if (dlapy2_(&d__1, &d__2) <= max(d__3,smlnum)) {
i__3 = i__ + 1 + i__ * h_dim1;
h__[i__3].r = 0., h__[i__3].i = 0.;
}
/* L110: */
}
if (msglvl > 2) {
i__1 = *k + *np;
i__2 = *k + *np;
zmout_(&debug_1.logfil, &i__1, &i__2, &h__[h_offset], ldh, &
debug_1.ndigit, "_naitr: Final upper Hessenberg matrix H"
" of order K+NP", (ftnlen)53);
}
goto L9000;
}
/* %--------------------------------------------------------% */
/* | Loop back to extend the factorization by another step. | */
/* %--------------------------------------------------------% */
goto L1000;
/* %---------------------------------------------------------------% */
/* | | */
/* | E N D O F M A I N I T E R A T I O N L O O P | */
/* | | */
/* %---------------------------------------------------------------% */
L9000:
return 0;
/* %---------------% */
/* | End of znaitr | */
/* %---------------% */
} /* znaitr_ */
/* Subroutine */ int zdrvev_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublecomplex *a, integer *lda, doublecomplex *h__, doublecomplex *w,
doublecomplex *w1, doublecomplex *vl, integer *ldvl, doublecomplex *
vr, integer *ldvr, doublecomplex *lre, integer *ldlre, doublereal *
result, doublecomplex *work, integer *nwork, doublereal *rwork,
integer *iwork, integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
/* Format strings */
static char fmt_9993[] = "(\002 ZDRVEV: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(/1x,a3,\002 -- Complex Eigenvalue-Eigenvect"
"or \002,\002Decomposition Driver\002,/\002 Matrix types (see ZDR"
"VEV for details): \002)";
static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: geom"
"etr. spaced entries.\002,/\002 2=Identity matrix. "
" \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
"/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
" 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
"l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
"ll, evenly spaced.\002)";
static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
" 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
"l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
"d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
"red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
"vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,a6,"
"/\002 12=Well-cond., random complex \002,a6,\002 \002,\002 17="
"Ill-cond., large rand. complx \002,a4,/\002 13=Ill-condi\002,"
"\002tioned, evenly spaced. \002,\002 18=Ill-cond., small ran"
"d.\002,\002 complx \002,a4)";
static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
" \002,\002 21=Matrix \002,\002with small random entries.\002,"
"/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
static char fmt_9995[] = "(\002 Tests performed with test threshold ="
"\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
"2 = | conj-trans(A) VL - VL conj-trans(W) | /\002,\002 ( n |A| u"
"lp ) \002,/\002 3 = | |VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i"
")| - 1 | / ulp \002,/\002 5 = 0 if W same no matter if VR or VL "
"computed,\002,\002 1/ulp otherwise\002,/\002 6 = 0 if VR same no"
" matter if VL computed,\002,\002 1/ulp otherwise\002,/\002 7 = "
"0 if VL same no matter if VR computed,\002,\002 1/ulp otherwis"
"e\002,/)";
static char fmt_9994[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
"=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
"\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4, i__5,
i__6;
doublereal d__1, d__2, d__3, d__4, d__5;
doublecomplex z__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double z_abs(doublecomplex *), d_imag(doublecomplex *);
/* Local variables */
integer j, n, jj;
doublecomplex dum[1];
doublereal res[2];
integer iwk;
doublereal ulp, vmx, cond;
integer jcol;
char path[3];
integer nmax;
doublereal unfl, ovfl, tnrm, vrmx, vtst;
logical badnn;
integer nfail, imode, iinfo;
doublereal conds, anorm;
extern /* Subroutine */ int zget22_(char *, char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublereal *, doublereal *), zgeev_(char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *);
integer jsize, nerrs, itype, jtype, ntest;
doublereal rtulp;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *);
integer idumma[1];
extern /* Subroutine */ int xerbla_(char *, integer *);
integer ioldsd[4];
extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
*), zlatme_(integer *, char *, integer *, doublecomplex *,
integer *, doublereal *, doublecomplex *, char *, char *, char *,
char *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, doublecomplex *, integer *,
doublecomplex *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *);
integer ntestf;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatmr_(integer *, integer *, char *, integer *, char *,
doublecomplex *, integer *, doublereal *, doublecomplex *, char *,
char *, doublecomplex *, integer *, doublereal *, doublecomplex *
, integer *, doublereal *, char *, integer *, integer *, integer *
, doublereal *, doublereal *, char *, doublecomplex *, integer *,
integer *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, char *, doublecomplex *, integer *, doublecomplex *,
integer *);
doublereal ulpinv;
integer nnwork, mtypes, ntestt;
doublereal rtulpi;
/* Fortran I/O blocks */
static cilist io___31 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9994, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRVEV checks the nonsymmetric eigenvalue problem driver ZGEEV. */
/* When ZDRVEV is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, one matrix will be generated and used */
/* to test the nonsymmetric eigenroutines. For each matrix, 7 */
/* tests will be performed: */
/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
/* Here VR is the matrix of unit right eigenvectors. */
/* W is a diagonal matrix with diagonal entries W(j). */
/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
/* Here VL is the matrix of unit left eigenvectors, A**H is the */
/* conjugate-transpose of A, and W is as above. */
/* (3) | |VR(i)| - 1 | / ulp and whether largest component real */
/* VR(i) denotes the i-th column of VR. */
/* (4) | |VL(i)| - 1 | / ulp and whether largest component real */
/* VL(i) denotes the i-th column of VL. */
/* (5) W(full) = W(partial) */
/* W(full) denotes the eigenvalues computed when both VR and VL */
/* are also computed, and W(partial) denotes the eigenvalues */
/* computed when only W, only W and VR, or only W and VL are */
/* computed. */
/* (6) VR(full) = VR(partial) */
/* VR(full) denotes the right eigenvectors computed when both VR */
/* and VL are computed, and VR(partial) denotes the result */
/* when only VR is computed. */
/* (7) VL(full) = VL(partial) */
/* VL(full) denotes the left eigenvectors computed when both VR */
/* and VL are also computed, and VL(partial) denotes the result */
/* when only VL is computed. */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
/* (4) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random complex angles. */
/* (7) Same as (4), but multiplied by a constant near */
/* the overflow threshold */
/* (8) Same as (4), but multiplied by a constant near */
/* the underflow threshold */
/* (9) A matrix of the form U' T U, where U is unitary and */
/* T has evenly spaced entries 1, ..., ULP with random complex */
/* angles on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (10) A matrix of the form U' T U, where U is unitary and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (11) A matrix of the form U' T U, where U is unitary and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (12) A matrix of the form U' T U, where U is unitary and */
/* T has complex eigenvalues randomly chosen from */
/* ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (13) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (14) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has geometrically spaced entries */
/* 1, ..., ULP with random complex angles on the diagonal */
/* and random O(1) entries in the upper triangle. */
/* (15) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (16) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
/* from ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (17) Same as (16), but multiplied by a constant */
/* near the overflow threshold */
/* (18) Same as (16), but multiplied by a constant */
/* near the underflow threshold */
/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
/* If N is at least 4, all entries in first two rows and last */
/* row, and first column and last two columns are zero. */
/* (20) Same as (19), but multiplied by a constant */
/* near the overflow threshold */
/* (21) Same as (19), but multiplied by a constant */
/* near the underflow threshold */
/* Arguments */
/* ========== */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* ZDRVEV does nothing. It must be at least zero. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, ZDRVEV */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to ZDRVEV to continue the same random number */
/* sequence. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns INFO not equal to 0.) */
/* A (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually used. */
/* LDA (input) INTEGER */
/* The leading dimension of A, and H. LDA must be at */
/* least 1 and at least max(NN). */
/* H (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* Another copy of the test matrix A, modified by ZGEEV. */
/* W (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* The eigenvalues of A. On exit, W are the eigenvalues of */
/* the matrix in A. */
/* W1 (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* Like W, this array contains the eigenvalues of A, */
/* but those computed when ZGEEV only computes a partial */
/* eigendecomposition, i.e. not the eigenvalues and left */
/* and right eigenvectors. */
/* VL (workspace) COMPLEX*16 array, dimension (LDVL, max(NN)) */
/* VL holds the computed left eigenvectors. */
/* LDVL (input) INTEGER */
/* Leading dimension of VL. Must be at least max(1,max(NN)). */
/* VR (workspace) COMPLEX*16 array, dimension (LDVR, max(NN)) */
/* VR holds the computed right eigenvectors. */
/* LDVR (input) INTEGER */
/* Leading dimension of VR. Must be at least max(1,max(NN)). */
/* LRE (workspace) COMPLEX*16 array, dimension (LDLRE, max(NN)) */
/* LRE holds the computed right or left eigenvectors. */
/* LDLRE (input) INTEGER */
/* Leading dimension of LRE. Must be at least max(1,max(NN)). */
/* RESULT (output) DOUBLE PRECISION array, dimension (7) */
/* The values computed by the seven tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* WORK (workspace) COMPLEX*16 array, dimension (NWORK) */
/* NWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* 5*NN(j)+2*NN(j)**2 for all j. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*max(NN)) */
/* IWORK (workspace) INTEGER array, dimension (max(NN)) */
/* INFO (output) INTEGER */
/* If 0, then everything ran OK. */
/* -1: NSIZES < 0 */
/* -2: Some NN(j) < 0 */
/* -3: NTYPES < 0 */
/* -6: THRESH < 0 */
/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
/* -14: LDVL < 1 or LDVL < NMAX, where NMAX is max( NN(j) ). */
/* -16: LDVR < 1 or LDVR < NMAX, where NMAX is max( NN(j) ). */
/* -18: LDLRE < 1 or LDLRE < NMAX, where NMAX is max( NN(j) ). */
/* -21: NWORK too small. */
/* If ZLATMR, CLATMS, CLATME or ZGEEV returns an error code, */
/* the absolute value of it is returned. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* NMAX Largest value in NN. */
/* NERRS The number of tests which have exceeded THRESH */
/* COND, CONDS, */
/* IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTULP, RTULPI Square roots of the previous 4 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* KCONDS(j) Selectw whether CONDS is to be 1 or */
/* 1/sqrt(ulp). (0 means irrelevant.) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
--w1;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
lre_dim1 = *ldlre;
lre_offset = 1 + lre_dim1;
lre -= lre_offset;
--result;
--work;
--rwork;
--iwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "EV", (ftnlen)2, (ftnlen)2);
/* Check for errors */
ntestt = 0;
ntestf = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
nmax = 0;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*nounit <= 0) {
*info = -7;
} else if (*lda < 1 || *lda < nmax) {
*info = -9;
} else if (*ldvl < 1 || *ldvl < nmax) {
*info = -14;
} else if (*ldvr < 1 || *ldvr < nmax) {
*info = -16;
} else if (*ldlre < 1 || *ldlre < nmax) {
*info = -28;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = nmax;
if (nmax * 5 + (i__1 * i__1 << 1) > *nwork) {
*info = -21;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRVEV", &i__1);
return 0;
}
/* Quick return if nothing to do */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
/* More Important constants */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
ulpinv = 1. / ulp;
rtulp = sqrt(ulp);
rtulpi = 1. / rtulp;
/* Loop over sizes, types */
nerrs = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L260;
}
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Compute "A" */
/* Control parameters: */
/* KMAGN KCONDS KMODE KTYPE */
/* =1 O(1) 1 clustered 1 zero */
/* =2 large large clustered 2 identity */
/* =3 small exponential Jordan */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log symmetric, w/ eigenvalues */
/* =6 random general, w/ eigenvalues */
/* =7 random diagonal */
/* =8 random symmetric */
/* =9 random general */
/* =10 random triangular */
if (mtypes > 21) {
goto L90;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L30;
case 2: goto L40;
case 3: goto L50;
}
L30:
anorm = 1.;
goto L60;
L40:
anorm = ovfl * ulp;
goto L60;
L50:
anorm = unfl * ulpinv;
goto L60;
L60:
zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices -- Identity & Jordan block */
/* Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
z__1.r = anorm, z__1.i = 0.;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
/* L70: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
z__1.r = anorm, z__1.i = 0.;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
if (jcol > 1) {
i__4 = jcol + (jcol - 1) * a_dim1;
a[i__4].r = 1., a[i__4].i = 0.;
}
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
n + 1], &iinfo);
} else if (itype == 5) {
/* Hermitian, eigenvalues specified */
zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
&iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.;
}
zlatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
" ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
&anorm, &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
n << 1) + 1], &c__1, &c_b38, "N", idumma, &c__0, &
c__0, &c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b38,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, &
c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, &
c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
if (n >= 4) {
zlaset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset],
lda);
i__3 = n - 3;
zlaset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a[a_dim1 + 3]
, lda);
i__3 = n - 3;
zlaset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a[(n - 1) *
a_dim1 + 3], lda);
zlaset_("Full", &c__1, &n, &c_b1, &c_b1, &a[n + a_dim1],
lda);
}
} else if (itype == 10) {
/* Triangular, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &c__0, &
c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___31.ciunit = *nounit;
s_wsfe(&io___31);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L90:
/* Test for minimal and generous workspace */
for (iwk = 1; iwk <= 2; ++iwk) {
if (iwk == 1) {
nnwork = n << 1;
} else {
/* Computing 2nd power */
i__3 = n;
nnwork = n * 5 + (i__3 * i__3 << 1);
}
nnwork = max(nnwork,1);
/* Initialize RESULT */
for (j = 1; j <= 7; ++j) {
result[j] = -1.;
/* L100: */
}
/* Compute eigenvalues and eigenvectors, and test them */
zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
zgeev_("V", "V", &n, &h__[h_offset], lda, &w[1], &vl[
vl_offset], ldvl, &vr[vr_offset], ldvr, &work[1], &
nnwork, &rwork[1], &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___34.ciunit = *nounit;
s_wsfe(&io___34);
do_fio(&c__1, "ZGEEV1", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L220;
}
/* Do Test (1) */
zget22_("N", "N", "N", &n, &a[a_offset], lda, &vr[vr_offset],
ldvr, &w[1], &work[1], &rwork[1], res);
result[1] = res[0];
/* Do Test (2) */
zget22_("C", "N", "C", &n, &a[a_offset], lda, &vl[vl_offset],
ldvl, &w[1], &work[1], &rwork[1], res);
result[2] = res[0];
/* Do Test (3) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
tnrm = dznrm2_(&n, &vr[j * vr_dim1 + 1], &c__1);
/* Computing MAX */
/* Computing MIN */
d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
d__2 = result[3], d__3 = min(d__4,d__5);
result[3] = max(d__2,d__3);
vmx = 0.;
vrmx = 0.;
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
vtst = z_abs(&vr[jj + j * vr_dim1]);
if (vtst > vmx) {
vmx = vtst;
}
i__5 = jj + j * vr_dim1;
if (d_imag(&vr[jj + j * vr_dim1]) == 0. && (d__1 = vr[
i__5].r, abs(d__1)) > vrmx) {
i__6 = jj + j * vr_dim1;
vrmx = (d__2 = vr[i__6].r, abs(d__2));
}
/* L110: */
}
if (vrmx / vmx < 1. - ulp * 2.) {
result[3] = ulpinv;
}
/* L120: */
}
/* Do Test (4) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
tnrm = dznrm2_(&n, &vl[j * vl_dim1 + 1], &c__1);
/* Computing MAX */
/* Computing MIN */
d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
d__2 = result[4], d__3 = min(d__4,d__5);
result[4] = max(d__2,d__3);
vmx = 0.;
vrmx = 0.;
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
vtst = z_abs(&vl[jj + j * vl_dim1]);
if (vtst > vmx) {
vmx = vtst;
}
i__5 = jj + j * vl_dim1;
if (d_imag(&vl[jj + j * vl_dim1]) == 0. && (d__1 = vl[
i__5].r, abs(d__1)) > vrmx) {
i__6 = jj + j * vl_dim1;
vrmx = (d__2 = vl[i__6].r, abs(d__2));
}
/* L130: */
}
if (vrmx / vmx < 1. - ulp * 2.) {
result[4] = ulpinv;
}
/* L140: */
}
/* Compute eigenvalues only, and test them */
zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
zgeev_("N", "N", &n, &h__[h_offset], lda, &w1[1], dum, &c__1,
dum, &c__1, &work[1], &nnwork, &rwork[1], &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "ZGEEV2", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L220;
}
/* Do Test (5) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
result[5] = ulpinv;
}
/* L150: */
}
/* Compute eigenvalues and right eigenvectors, and test them */
zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
zgeev_("N", "V", &n, &h__[h_offset], lda, &w1[1], dum, &c__1,
&lre[lre_offset], ldlre, &work[1], &nnwork, &rwork[1],
&iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "ZGEEV3", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L220;
}
/* Do Test (5) again */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
result[5] = ulpinv;
}
/* L160: */
}
/* Do Test (6) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = j + jj * vr_dim1;
i__6 = j + jj * lre_dim1;
if (vr[i__5].r != lre[i__6].r || vr[i__5].i != lre[
i__6].i) {
result[6] = ulpinv;
}
/* L170: */
}
/* L180: */
}
/* Compute eigenvalues and left eigenvectors, and test them */
zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
zgeev_("V", "N", &n, &h__[h_offset], lda, &w1[1], &lre[
lre_offset], ldlre, dum, &c__1, &work[1], &nnwork, &
rwork[1], &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, "ZGEEV4", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L220;
}
/* Do Test (5) again */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
result[5] = ulpinv;
}
/* L190: */
}
/* Do Test (7) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = j + jj * vl_dim1;
i__6 = j + jj * lre_dim1;
if (vl[i__5].r != lre[i__6].r || vl[i__5].i != lre[
i__6].i) {
result[7] = ulpinv;
}
/* L200: */
}
/* L210: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L220:
ntest = 0;
nfail = 0;
for (j = 1; j <= 7; ++j) {
if (result[j] >= 0.) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L230: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___48.ciunit = *nounit;
s_wsfe(&io___48);
e_wsfe();
io___49.ciunit = *nounit;
s_wsfe(&io___49);
e_wsfe();
io___50.ciunit = *nounit;
s_wsfe(&io___50);
e_wsfe();
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
doublereal));
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 7; ++j) {
if (result[j] >= *thresh) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
/* L240: */
}
nerrs += nfail;
ntestt += ntest;
/* L250: */
}
L260:
;
}
/* L270: */
}
/* Summary */
dlasum_(path, nounit, &nerrs, &ntestt);
return 0;
/* End of ZDRVEV */
} /* zdrvev_ */
/* Subroutine */ int zgeqpf_(integer *m, integer *n, doublecomplex *a,
integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work,
doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
doublecomplex z__1;
/* Local variables */
integer i__, j, ma, mn;
doublecomplex aii;
integer pvt;
doublereal temp, temp2, tol3z;
integer itemp;
/* -- LAPACK deprecated driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine ZGEQP3. */
/* ZGEQPF computes a QR factorization with column pivoting of a */
/* complex M-by-N matrix A: A*P = Q*R. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0 */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the upper triangle of the array contains the */
/* min(M,N)-by-N upper triangular matrix R; the elements */
/* below the diagonal, together with the array TAU, */
/* represent the unitary matrix Q as a product of */
/* min(m,n) elementary reflectors. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* JPVT (input/output) INTEGER array, dimension (N) */
/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
/* to the front of A*P (a leading column); if JPVT(i) = 0, */
/* the i-th column of A is a free column. */
/* On exit, if JPVT(i) = k, then the i-th column of A*P */
/* was the k-th column of A. */
/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors. */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of elementary reflectors */
/* Q = H(1) H(2) . . . H(n) */
/* Each H(i) has the form */
/* H = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). */
/* The matrix P is represented in jpvt as follows: If */
/* jpvt(j) = i */
/* then the jth column of P is the ith canonical unit vector. */
/* Partial column norm updating strategy modified by */
/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
/* University of Zagreb, Croatia. */
/* June 2006. */
/* For more details see LAPACK Working Note 176. */
/* ===================================================================== */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--work;
--rwork;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEQPF", &i__1);
return 0;
}
mn = min(*m,*n);
tol3z = sqrt(dlamch_("Epsilon"));
/* Move initial columns up front */
itemp = 1;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (jpvt[i__] != 0) {
if (i__ != itemp) {
zswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1],
&c__1);
jpvt[i__] = jpvt[itemp];
jpvt[itemp] = i__;
} else {
jpvt[i__] = i__;
}
++itemp;
} else {
jpvt[i__] = i__;
}
}
--itemp;
/* Compute the QR factorization and update remaining columns */
if (itemp > 0) {
ma = min(itemp,*m);
zgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info);
if (ma < *n) {
i__1 = *n - ma;
zunm2r_("Left", "Conjugate transpose", m, &i__1, &ma, &a[a_offset]
, lda, &tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1],
info);
}
}
if (itemp < mn) {
/* Initialize partial column norms. The first n elements of */
/* work store the exact column norms. */
i__1 = *n;
for (i__ = itemp + 1; i__ <= i__1; ++i__) {
i__2 = *m - itemp;
rwork[i__] = dznrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1);
rwork[*n + i__] = rwork[i__];
}
/* Compute factorization */
i__1 = mn;
for (i__ = itemp + 1; i__ <= i__1; ++i__) {
/* Determine ith pivot column and swap if necessary */
i__2 = *n - i__ + 1;
pvt = i__ - 1 + idamax_(&i__2, &rwork[i__], &c__1);
if (pvt != i__) {
zswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
c__1);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[i__];
jpvt[i__] = itemp;
rwork[pvt] = rwork[i__];
rwork[*n + pvt] = rwork[*n + i__];
}
/* Generate elementary reflector H(i) */
i__2 = i__ + i__ * a_dim1;
aii.r = a[i__2].r, aii.i = a[i__2].i;
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfp_(&i__2, &aii, &a[min(i__3, *m)+ i__ * a_dim1], &c__1, &tau[
i__]);
i__2 = i__ + i__ * a_dim1;
a[i__2].r = aii.r, a[i__2].i = aii.i;
if (i__ < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */
i__2 = i__ + i__ * a_dim1;
aii.r = a[i__2].r, aii.i = a[i__2].i;
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
i__2 = *m - i__ + 1;
i__3 = *n - i__;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
z__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
i__2 = i__ + i__ * a_dim1;
a[i__2].r = aii.r, a[i__2].i = aii.i;
}
/* Update partial column norms */
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (rwork[j] != 0.) {
/* NOTE: The following 4 lines follow from the analysis in */
/* Lapack Working Note 176. */
temp = z_abs(&a[i__ + j * a_dim1]) / rwork[j];
/* Computing MAX */
d__1 = 0., d__2 = (temp + 1.) * (1. - temp);
temp = max(d__1,d__2);
/* Computing 2nd power */
d__1 = rwork[j] / rwork[*n + j];
temp2 = temp * (d__1 * d__1);
if (temp2 <= tol3z) {
if (*m - i__ > 0) {
i__3 = *m - i__;
rwork[j] = dznrm2_(&i__3, &a[i__ + 1 + j * a_dim1]
, &c__1);
rwork[*n + j] = rwork[j];
} else {
rwork[j] = 0.;
rwork[*n + j] = 0.;
}
} else {
rwork[j] *= sqrt(temp);
}
}
}
}
}
return 0;
/* End of ZGEQPF */
} /* zgeqpf_ */
int main(int argc, char *argv[])
{
void zmatvec_mult(doublecomplex alpha, doublecomplex x[], doublecomplex beta, doublecomplex y[]);
void zpsolve(int n, doublecomplex x[], doublecomplex y[]);
extern int zfgmr( int n,
void (*matvec_mult)(doublecomplex, doublecomplex [], doublecomplex, doublecomplex []),
void (*psolve)(int n, doublecomplex [], doublecomplex[]),
doublecomplex *rhs, doublecomplex *sol, double tol, int restrt, int *itmax,
FILE *fits);
extern int zfill_diag(int n, NCformat *Astore);
char equed[1] = {'B'};
yes_no_t equil;
trans_t trans;
SuperMatrix A, L, U;
SuperMatrix B, X;
NCformat *Astore;
NCformat *Ustore;
SCformat *Lstore;
doublecomplex *a;
int *asub, *xa;
int *etree;
int *perm_c; /* column permutation vector */
int *perm_r; /* row permutations from partial pivoting */
int nrhs, ldx, lwork, info, m, n, nnz;
doublecomplex *rhsb, *rhsx, *xact;
doublecomplex *work = NULL;
double *R, *C;
double u, rpg, rcond;
doublecomplex zero = {0.0, 0.0};
doublecomplex one = {1.0, 0.0};
doublecomplex none = {-1.0, 0.0};
mem_usage_t mem_usage;
superlu_options_t options;
SuperLUStat_t stat;
int restrt, iter, maxit, i;
double resid;
doublecomplex *x, *b;
#ifdef DEBUG
extern int num_drop_L, num_drop_U;
#endif
#if ( DEBUGlevel>=1 )
CHECK_MALLOC("Enter main()");
#endif
/* Defaults */
lwork = 0;
nrhs = 1;
trans = NOTRANS;
/* Set the default input options:
options.Fact = DOFACT;
options.Equil = YES;
options.ColPerm = COLAMD;
options.DiagPivotThresh = 0.1; //different from complete LU
options.Trans = NOTRANS;
options.IterRefine = NOREFINE;
options.SymmetricMode = NO;
options.PivotGrowth = NO;
options.ConditionNumber = NO;
options.PrintStat = YES;
options.RowPerm = LargeDiag;
options.ILU_DropTol = 1e-4;
options.ILU_FillTol = 1e-2;
options.ILU_FillFactor = 10.0;
options.ILU_DropRule = DROP_BASIC | DROP_AREA;
options.ILU_Norm = INF_NORM;
options.ILU_MILU = SILU;
*/
ilu_set_default_options(&options);
/* Modify the defaults. */
options.PivotGrowth = YES; /* Compute reciprocal pivot growth */
options.ConditionNumber = YES;/* Compute reciprocal condition number */
if ( lwork > 0 ) {
work = SUPERLU_MALLOC(lwork);
if ( !work ) ABORT("Malloc fails for work[].");
}
/* Read matrix A from a file in Harwell-Boeing format.*/
if (argc < 2)
{
printf("Usage:\n%s [OPTION] < [INPUT] > [OUTPUT]\nOPTION:\n"
"-h -hb:\n\t[INPUT] is a Harwell-Boeing format matrix.\n"
"-r -rb:\n\t[INPUT] is a Rutherford-Boeing format matrix.\n"
"-t -triplet:\n\t[INPUT] is a triplet format matrix.\n",
argv[0]);
return 0;
}
else
{
switch (argv[1][1])
{
case 'H':
case 'h':
printf("Input a Harwell-Boeing format matrix:\n");
zreadhb(&m, &n, &nnz, &a, &asub, &xa);
break;
case 'R':
case 'r':
printf("Input a Rutherford-Boeing format matrix:\n");
zreadrb(&m, &n, &nnz, &a, &asub, &xa);
break;
case 'T':
case 't':
printf("Input a triplet format matrix:\n");
zreadtriple(&m, &n, &nnz, &a, &asub, &xa);
break;
default:
printf("Unrecognized format.\n");
return 0;
}
}
zCreate_CompCol_Matrix(&A, m, n, nnz, a, asub, xa,
SLU_NC, SLU_Z, SLU_GE);
Astore = A.Store;
zfill_diag(n, Astore);
printf("Dimension %dx%d; # nonzeros %d\n", A.nrow, A.ncol, Astore->nnz);
fflush(stdout);
/* Generate the right-hand side */
if ( !(rhsb = doublecomplexMalloc(m * nrhs)) ) ABORT("Malloc fails for rhsb[].");
if ( !(rhsx = doublecomplexMalloc(m * nrhs)) ) ABORT("Malloc fails for rhsx[].");
zCreate_Dense_Matrix(&B, m, nrhs, rhsb, m, SLU_DN, SLU_Z, SLU_GE);
zCreate_Dense_Matrix(&X, m, nrhs, rhsx, m, SLU_DN, SLU_Z, SLU_GE);
xact = doublecomplexMalloc(n * nrhs);
ldx = n;
zGenXtrue(n, nrhs, xact, ldx);
zFillRHS(trans, nrhs, xact, ldx, &A, &B);
if ( !(etree = intMalloc(n)) ) ABORT("Malloc fails for etree[].");
if ( !(perm_r = intMalloc(m)) ) ABORT("Malloc fails for perm_r[].");
if ( !(perm_c = intMalloc(n)) ) ABORT("Malloc fails for perm_c[].");
if ( !(R = (double *) SUPERLU_MALLOC(A.nrow * sizeof(double))) )
ABORT("SUPERLU_MALLOC fails for R[].");
if ( !(C = (double *) SUPERLU_MALLOC(A.ncol * sizeof(double))) )
ABORT("SUPERLU_MALLOC fails for C[].");
info = 0;
#ifdef DEBUG
num_drop_L = 0;
num_drop_U = 0;
#endif
/* Initialize the statistics variables. */
StatInit(&stat);
/* Compute the incomplete factorization and compute the condition number
and pivot growth using dgsisx. */
B.ncol = 0; /* not to perform triangular solution */
zgsisx(&options, &A, perm_c, perm_r, etree, equed, R, C, &L, &U, work,
lwork, &B, &X, &rpg, &rcond, &mem_usage, &stat, &info);
/* Set RHS for GMRES. */
if (!(b = doublecomplexMalloc(m))) ABORT("Malloc fails for b[].");
if (*equed == 'R' || *equed == 'B') {
for (i = 0; i < n; ++i) zd_mult(&b[i], &rhsb[i], R[i]);
} else {
for (i = 0; i < m; i++) b[i] = rhsb[i];
}
printf("zgsisx(): info %d, equed %c\n", info, equed[0]);
if (info > 0 || rcond < 1e-8 || rpg > 1e8)
printf("WARNING: This preconditioner might be unstable.\n");
if ( info == 0 || info == n+1 ) {
if ( options.PivotGrowth == YES )
printf("Recip. pivot growth = %e\n", rpg);
if ( options.ConditionNumber == YES )
printf("Recip. condition number = %e\n", rcond);
} else if ( info > 0 && lwork == -1 ) {
printf("** Estimated memory: %d bytes\n", info - n);
}
Lstore = (SCformat *) L.Store;
Ustore = (NCformat *) U.Store;
printf("n(A) = %d, nnz(A) = %d\n", n, Astore->nnz);
printf("No of nonzeros in factor L = %d\n", Lstore->nnz);
printf("No of nonzeros in factor U = %d\n", Ustore->nnz);
printf("No of nonzeros in L+U = %d\n", Lstore->nnz + Ustore->nnz - n);
printf("Fill ratio: nnz(F)/nnz(A) = %.3f\n",
((double)(Lstore->nnz) + (double)(Ustore->nnz) - (double)n)
/ (double)Astore->nnz);
printf("L\\U MB %.3f\ttotal MB needed %.3f\n",
mem_usage.for_lu/1e6, mem_usage.total_needed/1e6);
fflush(stdout);
/* Set the global variables. */
GLOBAL_A = &A;
GLOBAL_L = &L;
GLOBAL_U = &U;
GLOBAL_STAT = &stat;
GLOBAL_PERM_C = perm_c;
GLOBAL_PERM_R = perm_r;
GLOBAL_OPTIONS = &options;
GLOBAL_R = R;
GLOBAL_C = C;
GLOBAL_MEM_USAGE = &mem_usage;
/* Set the options to do solve-only. */
options.Fact = FACTORED;
options.PivotGrowth = NO;
options.ConditionNumber = NO;
/* Set the variables used by GMRES. */
restrt = SUPERLU_MIN(n / 3 + 1, 50);
maxit = 1000;
iter = maxit;
resid = 1e-8;
if (!(x = doublecomplexMalloc(n))) ABORT("Malloc fails for x[].");
if (info <= n + 1)
{
int i_1 = 1;
double maxferr = 0.0, nrmA, nrmB, res, t;
doublecomplex temp;
extern double dznrm2_(int *, doublecomplex [], int *);
extern void zaxpy_(int *, doublecomplex *, doublecomplex [], int *, doublecomplex [], int *);
/* Initial guess */
for (i = 0; i < n; i++) x[i] = zero;
t = SuperLU_timer_();
/* Call GMRES */
zfgmr(n, zmatvec_mult, zpsolve, b, x, resid, restrt, &iter, stdout);
t = SuperLU_timer_() - t;
/* Output the result. */
nrmA = dznrm2_(&(Astore->nnz), (doublecomplex *)((DNformat *)A.Store)->nzval,
&i_1);
nrmB = dznrm2_(&m, b, &i_1);
sp_zgemv("N", none, &A, x, 1, one, b, 1);
res = dznrm2_(&m, b, &i_1);
resid = res / nrmB;
printf("||A||_F = %.1e, ||B||_2 = %.1e, ||B-A*X||_2 = %.1e, "
"relres = %.1e\n", nrmA, nrmB, res, resid);
if (iter >= maxit)
{
if (resid >= 1.0) iter = -180;
else if (resid > 1e-8) iter = -111;
}
printf("iteration: %d\nresidual: %.1e\nGMRES time: %.2f seconds.\n",
iter, resid, t);
/* Scale the solution back if equilibration was performed. */
if (*equed == 'C' || *equed == 'B')
for (i = 0; i < n; i++) zd_mult(&x[i], &x[i], C[i]);
for (i = 0; i < m; i++) {
z_sub(&temp, &x[i], &xact[i]);
maxferr = SUPERLU_MAX(maxferr, z_abs1(&temp));
}
printf("||X-X_true||_oo = %.1e\n", maxferr);
}
#ifdef DEBUG
printf("%d entries in L and %d entries in U dropped.\n",
num_drop_L, num_drop_U);
#endif
fflush(stdout);
if ( options.PrintStat ) StatPrint(&stat);
StatFree(&stat);
SUPERLU_FREE (rhsb);
SUPERLU_FREE (rhsx);
SUPERLU_FREE (xact);
SUPERLU_FREE (etree);
SUPERLU_FREE (perm_r);
SUPERLU_FREE (perm_c);
SUPERLU_FREE (R);
SUPERLU_FREE (C);
Destroy_CompCol_Matrix(&A);
Destroy_SuperMatrix_Store(&B);
Destroy_SuperMatrix_Store(&X);
if ( lwork >= 0 ) {
Destroy_SuperNode_Matrix(&L);
Destroy_CompCol_Matrix(&U);
}
SUPERLU_FREE(b);
SUPERLU_FREE(x);
#if ( DEBUGlevel>=1 )
CHECK_MALLOC("Exit main()");
#endif
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)
{
/* 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 zlaghe_(integer *n, integer *k, doublereal *d__,
doublecomplex *a, integer *lda, integer *iseed, doublecomplex *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
integer i__, j;
doublecomplex wa, wb;
doublereal wn;
doublecomplex tau;
doublecomplex alpha;
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAGHE generates a complex hermitian matrix A, by pre- and post- */
/* multiplying a real diagonal matrix D with a random unitary matrix: */
/* A = U*D*U'. The semi-bandwidth may then be reduced to k by additional */
/* unitary transformations. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* K (input) INTEGER */
/* The number of nonzero subdiagonals within the band of A. */
/* 0 <= K <= N-1. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The diagonal elements of the diagonal matrix D. */
/* A (output) COMPLEX*16 array, dimension (LDA,N) */
/* The generated n by n hermitian matrix A (the full matrix is */
/* stored). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= N. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator; the array */
/* elements must be between 0 and 4095, and ISEED(4) must be */
/* odd. */
/* On exit, the seed is updated. */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
--d__;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*k < 0 || *k > *n - 1) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("ZLAGHE", &i__1);
return 0;
}
/* initialize lower triangle of A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
i__3 = i__;
a[i__2].r = d__[i__3], a[i__2].i = 0.;
/* L30: */
}
/* Generate lower triangle of hermitian matrix */
for (i__ = *n - 1; i__ >= 1; --i__) {
/* generate random reflection */
i__1 = *n - i__ + 1;
zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i__ + 1;
wn = dznrm2_(&i__1, &work[1], &c__1);
d__1 = wn / z_abs(&work[1]);
z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__1 = *n - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__1, &z__1, &work[2], &c__1);
work[1].r = 1., work[1].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply random reflection to A(i:n,i:n) from the left */
/* and the right */
/* compute y := tau * A * u */
i__1 = *n - i__ + 1;
zhemv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], &
c__1, &c_b1, &work[*n + 1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
z__3.r = -.5, z__3.i = -0.;
z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i +
z__3.i * tau.r;
i__1 = *n - i__ + 1;
zdotc_(&z__4, &i__1, &work[*n + 1], &c__1, &work[1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i
+ z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__1 = *n - i__ + 1;
zaxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
/* apply the transformation as a rank-2 update to A(i:n,i:n) */
i__1 = *n - i__ + 1;
z__1.r = -1., z__1.i = -0.;
zher2_("Lower", &i__1, &z__1, &work[1], &c__1, &work[*n + 1], &c__1, &
a[i__ + i__ * a_dim1], lda);
/* L40: */
}
/* Reduce number of subdiagonals to K */
i__1 = *n - 1 - *k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* generate reflection to annihilate A(k+i+1:n,i) */
i__2 = *n - *k - i__ + 1;
wn = dznrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
d__1 = wn / z_abs(&a[*k + i__ + i__ * a_dim1]);
i__2 = *k + i__ + i__ * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = *k + i__ + i__ * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *n - *k - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1);
i__2 = *k + i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
i__2 = *n - *k - i__ + 1;
i__3 = *k - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__
+ 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &
c_b1, &work[1], &c__1);
i__2 = *n - *k - i__ + 1;
i__3 = *k - 1;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[
1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda);
/* apply reflection to A(k+i:n,k+i:n) from the left and the right */
/* compute y := tau * A * u */
i__2 = *n - *k - i__ + 1;
zhemv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda,
&a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
z__3.r = -.5, z__3.i = -0.;
z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i +
z__3.i * tau.r;
i__2 = *n - *k - i__ + 1;
zdotc_(&z__4, &i__2, &work[1], &c__1, &a[*k + i__ + i__ * a_dim1], &
c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i
+ z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = *n - *k - i__ + 1;
zaxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
c__1);
/* apply hermitian rank-2 update to A(k+i:n,k+i:n) */
i__2 = *n - *k - i__ + 1;
z__1.r = -1., z__1.i = -0.;
zher2_("Lower", &i__2, &z__1, &a[*k + i__ + i__ * a_dim1], &c__1, &
work[1], &c__1, &a[*k + i__ + (*k + i__) * a_dim1], lda);
i__2 = *k + i__ + i__ * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = *n;
for (j = *k + i__ + 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L50: */
}
/* L60: */
}
/* Store full hermitian matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * a_dim1;
d_cnjg(&z__1, &a[i__ + j * a_dim1]);
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L70: */
}
/* L80: */
}
return 0;
/* End of ZLAGHE */
} /* zlaghe_ */
/* Subroutine */
int zgeevx_(char *balanc, char *jobvl, char *jobvr, char * sense, integer *n, doublecomplex *a, integer *lda, doublecomplex *w, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, integer *ilo, integer *ihi, doublereal *scale, doublereal *abnrm, doublereal *rconde, doublereal *rcondv, doublecomplex *work, integer * lwork, doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double sqrt(doublereal), d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, k;
char job[1];
doublereal scl, dum[1], eps;
doublecomplex tmp;
char side[1];
doublereal anrm;
integer ierr, itau, iwrk, nout, icond;
extern logical lsame_(char *, char *);
extern /* Subroutine */
int zscal_(integer *, doublecomplex *, doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
logical scalea;
extern doublereal dlamch_(char *);
doublereal cscale;
extern /* Subroutine */
int dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *), zgebak_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, doublecomplex *, integer *, integer *), zgebal_(char *, integer *, doublecomplex *, integer *, integer *, integer *, doublereal *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */
int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
logical select[1];
extern /* Subroutine */
int zdscal_(integer *, doublereal *, doublecomplex *, integer *);
doublereal bignum;
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */
int zgehrd_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublecomplex *, integer *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
integer minwrk, maxwrk;
logical wantvl, wntsnb;
integer hswork;
logical wntsne;
doublereal smlnum;
extern /* Subroutine */
int zhseqr_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *);
logical lquery, wantvr;
extern /* Subroutine */
int ztrevc_(char *, char *, logical *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *, doublecomplex *, doublereal *, integer *), ztrsna_(char *, char *, logical *, integer *, doublecomplex *, integer *, doublecomplex * , integer *, doublecomplex *, integer *, doublereal *, doublereal *, integer *, integer *, doublecomplex *, integer *, doublereal *, integer *), zunghr_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *);
logical wntsnn, wntsnv;
/* -- LAPACK driver 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 Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--scale;
--rconde;
--rcondv;
--work;
--rwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
wntsnn = lsame_(sense, "N");
wntsne = lsame_(sense, "E");
wntsnv = lsame_(sense, "V");
wntsnb = lsame_(sense, "B");
if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P") || lsame_(balanc, "B")))
{
*info = -1;
}
else if (! wantvl && ! lsame_(jobvl, "N"))
{
*info = -2;
}
else if (! wantvr && ! lsame_(jobvr, "N"))
{
*info = -3;
}
else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb) && ! (wantvl && wantvr))
{
*info = -4;
}
else if (*n < 0)
{
*info = -5;
}
else if (*lda < max(1,*n))
{
*info = -7;
}
else if (*ldvl < 1 || wantvl && *ldvl < *n)
{
*info = -10;
}
else if (*ldvr < 1 || wantvr && *ldvr < *n)
{
*info = -12;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* CWorkspace refers to complex workspace, and RWorkspace to real */
/* workspace. NB refers to the optimal block size for the */
/* immediately following subroutine, as returned by ILAENV. */
/* HSWORK refers to the workspace preferred by ZHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0)
{
if (*n == 0)
{
minwrk = 1;
maxwrk = 1;
}
else
{
maxwrk = *n + *n * ilaenv_(&c__1, "ZGEHRD", " ", n, &c__1, n, & c__0);
if (wantvl)
{
zhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[ vl_offset], ldvl, &work[1], &c_n1, info);
}
else if (wantvr)
{
zhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[ vr_offset], ldvr, &work[1], &c_n1, info);
}
else
{
if (wntsnn)
{
zhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], & vr[vr_offset], ldvr, &work[1], &c_n1, info);
}
else
{
zhseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &w[1], & vr[vr_offset], ldvr, &work[1], &c_n1, info);
}
}
hswork = (integer) work[1].r;
if (! wantvl && ! wantvr)
{
minwrk = *n << 1;
if (! (wntsnn || wntsne))
{
/* Computing MAX */
i__1 = minwrk;
i__2 = *n * *n + (*n << 1); // , expr subst
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
if (! (wntsnn || wntsne))
{
/* Computing MAX */
i__1 = maxwrk;
i__2 = *n * *n + (*n << 1); // , expr subst
maxwrk = max(i__1,i__2);
}
}
else
{
minwrk = *n << 1;
if (! (wntsnn || wntsne))
{
/* Computing MAX */
i__1 = minwrk;
i__2 = *n * *n + (*n << 1); // , expr subst
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
/* Computing MAX */
i__1 = maxwrk;
i__2 = *n + (*n - 1) * ilaenv_(&c__1, "ZUNGHR", " ", n, &c__1, n, &c_n1); // , expr subst
maxwrk = max(i__1,i__2);
if (! (wntsnn || wntsne))
{
/* Computing MAX */
i__1 = maxwrk;
i__2 = *n * *n + (*n << 1); // , expr subst
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk;
i__2 = *n << 1; // , expr subst
maxwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,minwrk);
}
work[1].r = (doublereal) maxwrk;
work[1].i = 0.; // , expr subst
if (*lwork < minwrk && ! lquery)
{
*info = -20;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZGEEVX", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
icond = 0;
anrm = zlange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0. && anrm < smlnum)
{
scalea = TRUE_;
cscale = smlnum;
}
else if (anrm > bignum)
{
scalea = TRUE_;
cscale = bignum;
}
if (scalea)
{
zlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & ierr);
}
/* Balance the matrix and compute ABNRM */
zgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
*abnrm = zlange_("1", n, n, &a[a_offset], lda, dum);
if (scalea)
{
dum[0] = *abnrm;
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, & ierr);
*abnrm = dum[0];
}
/* Reduce to upper Hessenberg form */
/* (CWorkspace: need 2*N, prefer N+N*NB) */
/* (RWorkspace: none) */
itau = 1;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
zgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, & ierr);
if (wantvl)
{
/* Want left eigenvectors */
/* Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
zlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl) ;
/* Generate unitary matrix in VL */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
zunghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], & i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
zhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vl[ vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr)
{
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
zlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
}
else if (wantvr)
{
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
zlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr) ;
/* Generate unitary matrix in VR */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
zunghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], & i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
zhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[ vr_offset], ldvr, &work[iwrk], &i__1, info);
}
else
{
/* Compute eigenvalues only */
/* If condition numbers desired, compute Schur form */
if (wntsnn)
{
*(unsigned char *)job = 'E';
}
else
{
*(unsigned char *)job = 'S';
}
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
zhseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[ vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from ZHSEQR, then quit */
if (*info > 0)
{
goto L50;
}
if (wantvl || wantvr)
{
/* Compute left and/or right eigenvectors */
/* (CWorkspace: need 2*N) */
/* (RWorkspace: need N) */
ztrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &rwork[1], & ierr);
}
/* Compute condition numbers if desired */
/* (CWorkspace: need N*N+2*N unless SENSE = 'E') */
/* (RWorkspace: need 2*N unless SENSE = 'E') */
if (! wntsnn)
{
ztrsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout, &work[iwrk], n, &rwork[1], &icond);
}
if (wantvl)
{
/* Undo balancing of left eigenvectors */
zgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl, &ierr);
/* Normalize left eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
scl = 1. / dznrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
zdscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__3 = k + i__ * vl_dim1;
/* Computing 2nd power */
d__1 = vl[i__3].r;
/* Computing 2nd power */
d__2 = d_imag(&vl[k + i__ * vl_dim1]);
rwork[k] = d__1 * d__1 + d__2 * d__2;
/* L10: */
}
k = idamax_(n, &rwork[1], &c__1);
d_cnjg(&z__2, &vl[k + i__ * vl_dim1]);
d__1 = sqrt(rwork[k]);
z__1.r = z__2.r / d__1;
z__1.i = z__2.i / d__1; // , expr subst
tmp.r = z__1.r;
tmp.i = z__1.i; // , expr subst
zscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = k + i__ * vl_dim1;
i__3 = k + i__ * vl_dim1;
d__1 = vl[i__3].r;
z__1.r = d__1;
z__1.i = 0.; // , expr subst
vl[i__2].r = z__1.r;
vl[i__2].i = z__1.i; // , expr subst
/* L20: */
}
}
if (wantvr)
{
/* Undo balancing of right eigenvectors */
zgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr, &ierr);
/* Normalize right eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
scl = 1. / dznrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
zdscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__3 = k + i__ * vr_dim1;
/* Computing 2nd power */
d__1 = vr[i__3].r;
/* Computing 2nd power */
d__2 = d_imag(&vr[k + i__ * vr_dim1]);
rwork[k] = d__1 * d__1 + d__2 * d__2;
/* L30: */
}
k = idamax_(n, &rwork[1], &c__1);
d_cnjg(&z__2, &vr[k + i__ * vr_dim1]);
d__1 = sqrt(rwork[k]);
z__1.r = z__2.r / d__1;
z__1.i = z__2.i / d__1; // , expr subst
tmp.r = z__1.r;
tmp.i = z__1.i; // , expr subst
zscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = k + i__ * vr_dim1;
i__3 = k + i__ * vr_dim1;
d__1 = vr[i__3].r;
z__1.r = d__1;
z__1.i = 0.; // , expr subst
vr[i__2].r = z__1.r;
vr[i__2].i = z__1.i; // , expr subst
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea)
{
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1] , &i__2, &ierr);
if (*info == 0)
{
if ((wntsnv || wntsnb) && icond == 0)
{
dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[ 1], n, &ierr);
}
}
else
{
i__1 = *ilo - 1;
zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n, &ierr);
}
}
work[1].r = (doublereal) maxwrk;
work[1].i = 0.; // , expr subst
return 0;
/* End of ZGEEVX */
}
/* Subroutine */ int zlaqp2_(integer *m, integer *n, integer *offset,
doublecomplex *a, integer *lda, integer *jpvt, doublecomplex *tau,
doublereal *vn1, doublereal *vn2, doublecomplex *work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
double sqrt(doublereal);
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
/* Local variables */
integer i__, j, mn;
doublecomplex aii;
integer pvt;
doublereal temp, temp2, tol3z;
integer offpi, itemp;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), zswap_(integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int zlarfp_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAQP2 computes a QR factorization with column pivoting of */
/* the block A(OFFSET+1:M,1:N). */
/* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* OFFSET (input) INTEGER */
/* The number of rows of the matrix A that must be pivoted */
/* but no factorized. OFFSET >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is */
/* the triangular factor obtained; the elements in block */
/* A(OFFSET+1:M,1:N) below the diagonal, together with the */
/* array TAU, represent the orthogonal matrix Q as a product of */
/* elementary reflectors. Block A(1:OFFSET,1:N) has been */
/* accordingly pivoted, but no factorized. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* JPVT (input/output) INTEGER array, dimension (N) */
/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
/* to the front of A*P (a leading column); if JPVT(i) = 0, */
/* the i-th column of A is a free column. */
/* On exit, if JPVT(i) = k, then the i-th column of A*P */
/* was the k-th column of A. */
/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors. */
/* VN1 (input/output) DOUBLE PRECISION array, dimension (N) */
/* The vector with the partial column norms. */
/* VN2 (input/output) DOUBLE PRECISION array, dimension (N) */
/* The vector with the exact column norms. */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
/* X. Sun, Computer Science Dept., Duke University, USA */
/* Partial column norm updating strategy modified by */
/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
/* University of Zagreb, Croatia. */
/* June 2006. */
/* For more details see LAPACK Working Note 176. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--vn1;
--vn2;
--work;
/* Function Body */
/* Computing MIN */
i__1 = *m - *offset;
mn = min(i__1,*n);
tol3z = sqrt(dlamch_("Epsilon"));
/* Compute factorization. */
i__1 = mn;
for (i__ = 1; i__ <= i__1; ++i__) {
offpi = *offset + i__;
/* Determine ith pivot column and swap if necessary. */
i__2 = *n - i__ + 1;
pvt = i__ - 1 + idamax_(&i__2, &vn1[i__], &c__1);
if (pvt != i__) {
zswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
c__1);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[i__];
jpvt[i__] = itemp;
vn1[pvt] = vn1[i__];
vn2[pvt] = vn2[i__];
}
/* Generate elementary reflector H(i). */
if (offpi < *m) {
i__2 = *m - offpi + 1;
zlarfp_(&i__2, &a[offpi + i__ * a_dim1], &a[offpi + 1 + i__ *
a_dim1], &c__1, &tau[i__]);
} else {
zlarfp_(&c__1, &a[*m + i__ * a_dim1], &a[*m + i__ * a_dim1], &
c__1, &tau[i__]);
}
if (i__ < *n) {
/* Apply H(i)' to A(offset+i:m,i+1:n) from the left. */
i__2 = offpi + i__ * a_dim1;
aii.r = a[i__2].r, aii.i = a[i__2].i;
i__2 = offpi + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
i__2 = *m - offpi + 1;
i__3 = *n - i__;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Left", &i__2, &i__3, &a[offpi + i__ * a_dim1], &c__1, &
z__1, &a[offpi + (i__ + 1) * a_dim1], lda, &work[1]);
i__2 = offpi + i__ * a_dim1;
a[i__2].r = aii.r, a[i__2].i = aii.i;
}
/* Update partial column norms. */
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (vn1[j] != 0.) {
/* NOTE: The following 4 lines follow from the analysis in */
/* Lapack Working Note 176. */
/* Computing 2nd power */
d__1 = z_abs(&a[offpi + j * a_dim1]) / vn1[j];
temp = 1. - d__1 * d__1;
temp = max(temp,0.);
/* Computing 2nd power */
d__1 = vn1[j] / vn2[j];
temp2 = temp * (d__1 * d__1);
if (temp2 <= tol3z) {
if (offpi < *m) {
i__3 = *m - offpi;
vn1[j] = dznrm2_(&i__3, &a[offpi + 1 + j * a_dim1], &
c__1);
vn2[j] = vn1[j];
} else {
vn1[j] = 0.;
vn2[j] = 0.;
}
} else {
vn1[j] *= sqrt(temp);
}
}
/* L10: */
}
/* L20: */
}
return 0;
/* End of ZLAQP2 */
} /* zlaqp2_ */
/* Subroutine */ int zgeqp3_(integer *m, integer *n, doublecomplex *a,
integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work,
integer *lwork, doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer j, jb, na, nb, sm, sn, nx, fjb, iws, nfxd, nbmin, minmn, minws;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zlaqp2_(integer *, integer *,
integer *, doublecomplex *, integer *, integer *, doublecomplex *,
doublereal *, doublereal *, doublecomplex *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *
);
integer topbmn, sminmn;
extern /* Subroutine */ int zlaqps_(integer *, integer *, integer *,
integer *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, doublereal *, doublereal *, doublecomplex *,
doublecomplex *, integer *);
integer lwkopt;
logical lquery;
extern /* Subroutine */ int zunmqr_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEQP3 computes a QR factorization with column pivoting of a */
/* matrix A: A*P = Q*R using Level 3 BLAS. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the upper triangle of the array contains the */
/* min(M,N)-by-N upper trapezoidal matrix R; the elements below */
/* the diagonal, together with the array TAU, represent the */
/* unitary matrix Q as a product of min(M,N) elementary */
/* reflectors. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* JPVT (input/output) INTEGER array, dimension (N) */
/* On entry, if JPVT(J).ne.0, the J-th column of A is permuted */
/* to the front of A*P (a leading column); if JPVT(J)=0, */
/* the J-th column of A is a free column. */
/* On exit, if JPVT(J)=K, then the J-th column of A*P was the */
/* the K-th column of A. */
/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO=0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= N+1. */
/* For optimal performance LWORK >= ( N+1 )*NB, where NB */
/* is the optimal blocksize. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of elementary reflectors */
/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real/complex scalar, and v is a real/complex vector */
/* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in */
/* A(i+1:m,i), and tau in TAU(i). */
/* Based on contributions by */
/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
/* X. Sun, Computer Science Dept., Duke University, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test input arguments */
/* ==================== */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--work;
--rwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info == 0) {
minmn = min(*m,*n);
if (minmn == 0) {
iws = 1;
lwkopt = 1;
} else {
iws = *n + 1;
nb = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1);
lwkopt = (*n + 1) * nb;
}
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
if (*lwork < iws && ! lquery) {
*info = -8;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEQP3", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible. */
if (minmn == 0) {
return 0;
}
/* Move initial columns up front. */
nfxd = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (jpvt[j] != 0) {
if (j != nfxd) {
zswap_(m, &a[j * a_dim1 + 1], &c__1, &a[nfxd * a_dim1 + 1], &
c__1);
jpvt[j] = jpvt[nfxd];
jpvt[nfxd] = j;
} else {
jpvt[j] = j;
}
++nfxd;
} else {
jpvt[j] = j;
}
/* L10: */
}
--nfxd;
/* Factorize fixed columns */
/* ======================= */
/* Compute the QR factorization of fixed columns and update */
/* remaining columns. */
if (nfxd > 0) {
na = min(*m,nfxd);
/* CC CALL ZGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) */
zgeqrf_(m, &na, &a[a_offset], lda, &tau[1], &work[1], lwork, info);
/* Computing MAX */
i__1 = iws, i__2 = (integer) work[1].r;
iws = max(i__1,i__2);
if (na < *n) {
/* CC CALL ZUNM2R( 'Left', 'Conjugate Transpose', M, N-NA, */
/* CC $ NA, A, LDA, TAU, A( 1, NA+1 ), LDA, WORK, */
/* CC $ INFO ) */
i__1 = *n - na;
zunmqr_("Left", "Conjugate Transpose", m, &i__1, &na, &a[a_offset]
, lda, &tau[1], &a[(na + 1) * a_dim1 + 1], lda, &work[1],
lwork, info);
/* Computing MAX */
i__1 = iws, i__2 = (integer) work[1].r;
iws = max(i__1,i__2);
}
}
/* Factorize free columns */
/* ====================== */
if (nfxd < minmn) {
sm = *m - nfxd;
sn = *n - nfxd;
sminmn = minmn - nfxd;
/* Determine the block size. */
nb = ilaenv_(&c__1, "ZGEQRF", " ", &sm, &sn, &c_n1, &c_n1);
nbmin = 2;
nx = 0;
if (nb > 1 && nb < sminmn) {
/* Determine when to cross over from blocked to unblocked code. */
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, "ZGEQRF", " ", &sm, &sn, &c_n1, &
c_n1);
nx = max(i__1,i__2);
if (nx < sminmn) {
/* Determine if workspace is large enough for blocked code. */
minws = (sn + 1) * nb;
iws = max(iws,minws);
if (*lwork < minws) {
/* Not enough workspace to use optimal NB: Reduce NB and */
/* determine the minimum value of NB. */
nb = *lwork / (sn + 1);
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEQRF", " ", &sm, &sn, &
c_n1, &c_n1);
nbmin = max(i__1,i__2);
}
}
}
/* Initialize partial column norms. The first N elements of work */
/* store the exact column norms. */
i__1 = *n;
for (j = nfxd + 1; j <= i__1; ++j) {
rwork[j] = dznrm2_(&sm, &a[nfxd + 1 + j * a_dim1], &c__1);
rwork[*n + j] = rwork[j];
/* L20: */
}
if (nb >= nbmin && nb < sminmn && nx < sminmn) {
/* Use blocked code initially. */
j = nfxd + 1;
/* Compute factorization: while loop. */
topbmn = minmn - nx;
L30:
if (j <= topbmn) {
/* Computing MIN */
i__1 = nb, i__2 = topbmn - j + 1;
jb = min(i__1,i__2);
/* Factorize JB columns among columns J:N. */
i__1 = *n - j + 1;
i__2 = j - 1;
i__3 = *n - j + 1;
zlaqps_(m, &i__1, &i__2, &jb, &fjb, &a[j * a_dim1 + 1], lda, &
jpvt[j], &tau[j], &rwork[j], &rwork[*n + j], &work[1],
&work[jb + 1], &i__3);
j += fjb;
goto L30;
}
} else {
j = nfxd + 1;
}
/* Use unblocked code to factor the last or only block. */
if (j <= minmn) {
i__1 = *n - j + 1;
i__2 = j - 1;
zlaqp2_(m, &i__1, &i__2, &a[j * a_dim1 + 1], lda, &jpvt[j], &tau[
j], &rwork[j], &rwork[*n + j], &work[1]);
}
}
work[1].r = (doublereal) iws, work[1].i = 0.;
return 0;
/* End of ZGEQP3 */
} /* zgeqp3_ */
/* Subroutine */ int zlagge_(integer *m, integer *n, integer *kl, integer *ku,
doublereal *d__, doublecomplex *a, integer *lda, integer *iseed,
doublecomplex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
double z_abs(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j;
doublecomplex wa, wb;
doublereal wn;
doublecomplex tau;
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *), zlacgv_(
integer *, doublecomplex *, integer *), zlarnv_(integer *,
integer *, integer *, doublecomplex *);
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAGGE generates a complex general m by n matrix A, by pre- and post- */
/* multiplying a real diagonal matrix D with random unitary matrices: */
/* A = U*D*V. The lower and upper bandwidths may then be reduced to */
/* kl and ku by additional unitary transformations. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of nonzero subdiagonals within the band of A. */
/* 0 <= KL <= M-1. */
/* KU (input) INTEGER */
/* The number of nonzero superdiagonals within the band of A. */
/* 0 <= KU <= N-1. */
/* D (input) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The diagonal elements of the diagonal matrix D. */
/* A (output) COMPLEX*16 array, dimension (LDA,N) */
/* The generated m by n matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= M. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator; the array */
/* elements must be between 0 and 4095, and ISEED(4) must be */
/* odd. */
/* On exit, the seed is updated. */
/* WORK (workspace) COMPLEX*16 array, dimension (M+N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
--d__;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0 || *kl > *m - 1) {
*info = -3;
} else if (*ku < 0 || *ku > *n - 1) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -7;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("ZLAGGE", &i__1);
return 0;
}
/* initialize A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
i__1 = min(*m,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
i__3 = i__;
a[i__2].r = d__[i__3], a[i__2].i = 0.;
/* L30: */
}
/* pre- and post-multiply A by random unitary matrices */
for (i__ = min(*m,*n); i__ >= 1; --i__) {
if (i__ < *m) {
/* generate random reflection */
i__1 = *m - i__ + 1;
zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *m - i__ + 1;
wn = dznrm2_(&i__1, &work[1], &c__1);
d__1 = wn / z_abs(&work[1]);
z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__1 = *m - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__1, &z__1, &work[2], &c__1);
work[1].r = 1., work[1].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* multiply A(i:m,i:n) by random reflection from the left */
i__1 = *m - i__ + 1;
i__2 = *n - i__ + 1;
zgemv_("Conjugate transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ *
a_dim1], lda, &work[1], &c__1, &c_b1, &work[*m + 1], &
c__1);
i__1 = *m - i__ + 1;
i__2 = *n - i__ + 1;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__1, &i__2, &z__1, &work[1], &c__1, &work[*m + 1], &c__1,
&a[i__ + i__ * a_dim1], lda);
}
if (i__ < *n) {
/* generate random reflection */
i__1 = *n - i__ + 1;
zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i__ + 1;
wn = dznrm2_(&i__1, &work[1], &c__1);
d__1 = wn / z_abs(&work[1]);
z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__1 = *n - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__1, &z__1, &work[2], &c__1);
work[1].r = 1., work[1].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* multiply A(i:m,i:n) by random reflection from the right */
i__1 = *m - i__ + 1;
i__2 = *n - i__ + 1;
zgemv_("No transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ * a_dim1]
, lda, &work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
i__1 = *m - i__ + 1;
i__2 = *n - i__ + 1;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__1, &i__2, &z__1, &work[*n + 1], &c__1, &work[1], &c__1,
&a[i__ + i__ * a_dim1], lda);
}
/* L40: */
}
/* Reduce number of subdiagonals to KL and number of superdiagonals */
/* to KU */
/* Computing MAX */
i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku;
i__1 = max(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
if (*kl <= *ku) {
/* annihilate subdiagonal elements first (necessary if KL = 0) */
/* Computing MIN */
i__2 = *m - 1 - *kl;
if (i__ <= min(i__2,*n)) {
/* generate reflection to annihilate A(kl+i+1:m,i) */
i__2 = *m - *kl - i__ + 1;
wn = dznrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
d__1 = wn / z_abs(&a[*kl + i__ + i__ * a_dim1]);
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *m - *kl - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
c__1);
i__2 = *kl + i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply reflection to A(kl+i:m,i+1:n) from the left */
i__2 = *m - *kl - i__ + 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl +
i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ *
a_dim1], &c__1, &c_b1, &work[1], &c__1);
i__2 = *m - *kl - i__ + 1;
i__3 = *n - i__;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__1, &a[*kl + i__ + i__ * a_dim1], &
c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) *
a_dim1], lda);
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
/* Computing MIN */
i__2 = *n - 1 - *ku;
if (i__ <= min(i__2,*m)) {
/* generate reflection to annihilate A(i,ku+i+1:n) */
i__2 = *n - *ku - i__ + 1;
wn = dznrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
d__1 = wn / z_abs(&a[i__ + (*ku + i__) * a_dim1]);
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *n - *ku - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[i__ + (*ku + i__ + 1) * a_dim1],
lda);
i__2 = i__ + (*ku + i__) * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply reflection to A(i+1:m,ku+i:n) from the right */
i__2 = *n - *ku - i__ + 1;
zlacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
i__2 = *m - i__;
i__3 = *n - *ku - i__ + 1;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku
+ i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1],
lda, &c_b1, &work[1], &c__1);
i__2 = *m - i__;
i__3 = *n - *ku - i__ + 1;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__1, &work[1], &c__1, &a[i__ + (*ku +
i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) *
a_dim1], lda);
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
} else {
/* annihilate superdiagonal elements first (necessary if */
/* KU = 0) */
/* Computing MIN */
i__2 = *n - 1 - *ku;
if (i__ <= min(i__2,*m)) {
/* generate reflection to annihilate A(i,ku+i+1:n) */
i__2 = *n - *ku - i__ + 1;
wn = dznrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
d__1 = wn / z_abs(&a[i__ + (*ku + i__) * a_dim1]);
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *n - *ku - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[i__ + (*ku + i__ + 1) * a_dim1],
lda);
i__2 = i__ + (*ku + i__) * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply reflection to A(i+1:m,ku+i:n) from the right */
i__2 = *n - *ku - i__ + 1;
zlacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
i__2 = *m - i__;
i__3 = *n - *ku - i__ + 1;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku
+ i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1],
lda, &c_b1, &work[1], &c__1);
i__2 = *m - i__;
i__3 = *n - *ku - i__ + 1;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__1, &work[1], &c__1, &a[i__ + (*ku +
i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) *
a_dim1], lda);
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
/* Computing MIN */
i__2 = *m - 1 - *kl;
if (i__ <= min(i__2,*n)) {
/* generate reflection to annihilate A(kl+i+1:m,i) */
i__2 = *m - *kl - i__ + 1;
wn = dznrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
d__1 = wn / z_abs(&a[*kl + i__ + i__ * a_dim1]);
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *m - *kl - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
c__1);
i__2 = *kl + i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply reflection to A(kl+i:m,i+1:n) from the left */
i__2 = *m - *kl - i__ + 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl +
i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ *
a_dim1], &c__1, &c_b1, &work[1], &c__1);
i__2 = *m - *kl - i__ + 1;
i__3 = *n - i__;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__1, &a[*kl + i__ + i__ * a_dim1], &
c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) *
a_dim1], lda);
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
}
i__2 = *m;
for (j = *kl + i__ + 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L50: */
}
i__2 = *n;
for (j = *ku + i__ + 1; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L60: */
}
/* L70: */
}
return 0;
/* End of ZLAGGE */
} /* zlagge_ */
/* Subroutine */ int zgeevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, doublecomplex *a, integer *lda, doublecomplex *w,
doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr,
integer *ilo, integer *ihi, doublereal *scale, doublereal *abnrm,
doublereal *rconde, doublereal *rcondv, doublecomplex *work, integer *
lwork, doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double sqrt(doublereal), d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, k;
char job[1];
doublereal scl, dum[1], eps;
doublecomplex tmp;
char side[1];
doublereal anrm;
integer ierr, itau, iwrk, nout, icond;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
logical scalea;
extern doublereal dlamch_(char *);
doublereal cscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), zgebak_(char *, char *, integer *,
integer *, integer *, doublereal *, integer *, doublecomplex *,
integer *, integer *), zgebal_(char *, integer *,
doublecomplex *, integer *, integer *, integer *, doublereal *,
integer *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
logical select[1];
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
doublereal bignum;
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *), zlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublecomplex *,
integer *, integer *), zlacpy_(char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *);
integer minwrk, maxwrk;
logical wantvl, wntsnb;
integer hswork;
logical wntsne;
doublereal smlnum;
extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
logical lquery, wantvr;
extern /* Subroutine */ int ztrevc_(char *, char *, logical *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *, doublecomplex *,
doublereal *, integer *), ztrsna_(char *, char *,
logical *, integer *, doublecomplex *, integer *, doublecomplex *
, integer *, doublecomplex *, integer *, doublereal *, doublereal
*, integer *, integer *, doublecomplex *, integer *, doublereal *,
integer *), zunghr_(integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, integer *);
logical wntsnn, wntsnv;
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEEVX computes for an N-by-N complex nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* Optionally also, it computes a balancing transformation to improve */
/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
/* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */
/* (RCONDE), and reciprocal condition numbers for the right */
/* eigenvectors (RCONDV). */
/* The right eigenvector v(j) of A satisfies */
/* A * v(j) = lambda(j) * v(j) */
/* where lambda(j) is its eigenvalue. */
/* The left eigenvector u(j) of A satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H */
/* where u(j)**H denotes the conjugate transpose of u(j). */
/* The computed eigenvectors are normalized to have Euclidean norm */
/* equal to 1 and largest component real. */
/* Balancing a matrix means permuting the rows and columns to make it */
/* more nearly upper triangular, and applying a diagonal similarity */
/* transformation D * A * D**(-1), where D is a diagonal matrix, to */
/* make its rows and columns closer in norm and the condition numbers */
/* of its eigenvalues and eigenvectors smaller. The computed */
/* reciprocal condition numbers correspond to the balanced matrix. */
/* Permuting rows and columns will not change the condition numbers */
/* (in exact arithmetic) but diagonal scaling will. For further */
/* explanation of balancing, see section 4.10.2 of the LAPACK */
/* Users' Guide. */
/* Arguments */
/* ========= */
/* BALANC (input) CHARACTER*1 */
/* Indicates how the input matrix should be diagonally scaled */
/* and/or permuted to improve the conditioning of its */
/* eigenvalues. */
/* = 'N': Do not diagonally scale or permute; */
/* = 'P': Perform permutations to make the matrix more nearly */
/* upper triangular. Do not diagonally scale; */
/* = 'S': Diagonally scale the matrix, ie. replace A by */
/* D*A*D**(-1), where D is a diagonal matrix chosen */
/* to make the rows and columns of A more equal in */
/* norm. Do not permute; */
/* = 'B': Both diagonally scale and permute A. */
/* Computed reciprocal condition numbers will be for the matrix */
/* after balancing and/or permuting. Permuting does not change */
/* condition numbers (in exact arithmetic), but balancing does. */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVL must = 'V'. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVR must = 'V'. */
/* SENSE (input) CHARACTER*1 */
/* Determines which reciprocal condition numbers are computed. */
/* = 'N': None are computed; */
/* = 'E': Computed for eigenvalues only; */
/* = 'V': Computed for right eigenvectors only; */
/* = 'B': Computed for eigenvalues and right eigenvectors. */
/* If SENSE = 'E' or 'B', both left and right eigenvectors */
/* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten. If JOBVL = 'V' or */
/* JOBVR = 'V', A contains the Schur form of the balanced */
/* version of the matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* W (output) COMPLEX*16 array, dimension (N) */
/* W contains the computed eigenvalues. */
/* VL (output) COMPLEX*16 array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order */
/* as their eigenvalues. */
/* If JOBVL = 'N', VL is not referenced. */
/* u(j) = VL(:,j), the j-th column of VL. */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1; if */
/* JOBVL = 'V', LDVL >= N. */
/* VR (output) COMPLEX*16 array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order */
/* as their eigenvalues. */
/* If JOBVR = 'N', VR is not referenced. */
/* v(j) = VR(:,j), the j-th column of VR. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1; if */
/* JOBVR = 'V', LDVR >= N. */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are integer values determined when A was */
/* balanced. The balanced A(i,j) = 0 if I > J and */
/* J = 1,...,ILO-1 or I = IHI+1,...,N. */
/* SCALE (output) DOUBLE PRECISION array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* when balancing A. If P(j) is the index of the row and column */
/* interchanged with row and column j, and D(j) is the scaling */
/* factor applied to row and column j, then */
/* SCALE(J) = P(J), for J = 1,...,ILO-1 */
/* = D(J), for J = ILO,...,IHI */
/* = P(J) for J = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* ABNRM (output) DOUBLE PRECISION */
/* The one-norm of the balanced matrix (the maximum */
/* of the sum of absolute values of elements of any column). */
/* RCONDE (output) DOUBLE PRECISION array, dimension (N) */
/* RCONDE(j) is the reciprocal condition number of the j-th */
/* eigenvalue. */
/* RCONDV (output) DOUBLE PRECISION array, dimension (N) */
/* RCONDV(j) is the reciprocal condition number of the j-th */
/* right eigenvector. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. If SENSE = 'N' or 'E', */
/* LWORK >= max(1,2*N), and if SENSE = 'V' or 'B', */
/* LWORK >= N*N+2*N. */
/* For good performance, LWORK must generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the QR algorithm failed to compute all the */
/* eigenvalues, and no eigenvectors or condition numbers */
/* have been computed; elements 1:ILO-1 and i+1:N of W */
/* contain eigenvalues which have converged. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--scale;
--rconde;
--rcondv;
--work;
--rwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
wntsnn = lsame_(sense, "N");
wntsne = lsame_(sense, "E");
wntsnv = lsame_(sense, "V");
wntsnb = lsame_(sense, "B");
if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
|| lsame_(balanc, "B"))) {
*info = -1;
} else if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -2;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*info = -3;
} else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
&& ! (wantvl && wantvr)) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -10;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -12;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* CWorkspace refers to complex workspace, and RWorkspace to real */
/* workspace. NB refers to the optimal block size for the */
/* immediately following subroutine, as returned by ILAENV. */
/* HSWORK refers to the workspace preferred by ZHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = *n + *n * ilaenv_(&c__1, "ZGEHRD", " ", n, &c__1, n, &
c__0);
if (wantvl) {
zhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[
vl_offset], ldvl, &work[1], &c_n1, info);
} else if (wantvr) {
zhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[1], &c_n1, info);
} else {
if (wntsnn) {
zhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &
vr[vr_offset], ldvr, &work[1], &c_n1, info);
} else {
zhseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &
vr[vr_offset], ldvr, &work[1], &c_n1, info);
}
}
hswork = (integer) work[1].r;
if (! wantvl && ! wantvr) {
minwrk = *n << 1;
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + (*n << 1);
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + (*n << 1);
maxwrk = max(i__1,i__2);
}
} else {
minwrk = *n << 1;
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + (*n << 1);
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "ZUNGHR",
" ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + (*n << 1);
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *n << 1;
maxwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,minwrk);
}
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
if (*lwork < minwrk && ! lquery) {
*info = -20;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
icond = 0;
anrm = zlange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0. && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
zlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix and compute ABNRM */
zgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
*abnrm = zlange_("1", n, n, &a[a_offset], lda, dum);
if (scalea) {
dum[0] = *abnrm;
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
ierr);
*abnrm = dum[0];
}
/* Reduce to upper Hessenberg form */
/* (CWorkspace: need 2*N, prefer N+N*NB) */
/* (RWorkspace: none) */
itau = 1;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
zgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &
ierr);
if (wantvl) {
/* Want left eigenvectors */
/* Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
zlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate unitary matrix in VL */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
zunghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
zhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vl[
vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
zlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
zlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate unitary matrix in VR */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
zunghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
zhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only */
/* If condition numbers desired, compute Schur form */
if (wntsnn) {
*(unsigned char *)job = 'E';
} else {
*(unsigned char *)job = 'S';
}
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
zhseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from ZHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (CWorkspace: need 2*N) */
/* (RWorkspace: need N) */
ztrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &rwork[1], &
ierr);
}
/* Compute condition numbers if desired */
/* (CWorkspace: need N*N+2*N unless SENSE = 'E') */
/* (RWorkspace: need 2*N unless SENSE = 'E') */
if (! wntsnn) {
ztrsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout,
&work[iwrk], n, &rwork[1], &icond);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
zgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl,
&ierr);
/* Normalize left eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1. / dznrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
zdscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + i__ * vl_dim1;
/* Computing 2nd power */
d__1 = vl[i__3].r;
/* Computing 2nd power */
d__2 = d_imag(&vl[k + i__ * vl_dim1]);
rwork[k] = d__1 * d__1 + d__2 * d__2;
/* L10: */
}
k = idamax_(n, &rwork[1], &c__1);
d_cnjg(&z__2, &vl[k + i__ * vl_dim1]);
d__1 = sqrt(rwork[k]);
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
tmp.r = z__1.r, tmp.i = z__1.i;
zscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = k + i__ * vl_dim1;
i__3 = k + i__ * vl_dim1;
d__1 = vl[i__3].r;
z__1.r = d__1, z__1.i = 0.;
vl[i__2].r = z__1.r, vl[i__2].i = z__1.i;
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
zgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr,
&ierr);
/* Normalize right eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1. / dznrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
zdscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + i__ * vr_dim1;
/* Computing 2nd power */
d__1 = vr[i__3].r;
/* Computing 2nd power */
d__2 = d_imag(&vr[k + i__ * vr_dim1]);
rwork[k] = d__1 * d__1 + d__2 * d__2;
/* L30: */
}
k = idamax_(n, &rwork[1], &c__1);
d_cnjg(&z__2, &vr[k + i__ * vr_dim1]);
d__1 = sqrt(rwork[k]);
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
tmp.r = z__1.r, tmp.i = z__1.i;
zscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = k + i__ * vr_dim1;
i__3 = k + i__ * vr_dim1;
d__1 = vr[i__3].r;
z__1.r = d__1, z__1.i = 0.;
vr[i__2].r = z__1.r, vr[i__2].i = z__1.i;
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1]
, &i__2, &ierr);
if (*info == 0) {
if ((wntsnv || wntsnb) && icond == 0) {
dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[
1], n, &ierr);
}
} else {
i__1 = *ilo - 1;
zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n,
&ierr);
}
}
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
return 0;
/* End of ZGEEVX */
} /* zgeevx_ */
/* Subroutine */ int ztgsna_(char *job, char *howmny, logical *select,
integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer
*ldb, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *
ldvr, doublereal *s, doublereal *dif, integer *mm, integer *m,
doublecomplex *work, integer *lwork, integer *iwork, integer *info)
{
/* -- 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
Purpose
=======
ZTGSNA estimates reciprocal condition numbers for specified
eigenvalues and/or eigenvectors of a matrix pair (A, B).
(A, B) must be in generalized Schur canonical form, that is, A and
B are both upper triangular.
Arguments
=========
JOB (input) CHARACTER*1
Specifies whether condition numbers are required for
eigenvalues (S) or eigenvectors (DIF):
= 'E': for eigenvalues only (S);
= 'V': for eigenvectors only (DIF);
= 'B': for both eigenvalues and eigenvectors (S and DIF).
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 corresponding j-th eigenvalue and/or eigenvector,
SELECT(j) must be set to .TRUE..
If HOWMNY = 'A', SELECT is not referenced.
N (input) INTEGER
The order of the square matrix pair (A, B). N >= 0.
A (input) COMPLEX*16 array, dimension (LDA,N)
The upper triangular matrix A in the pair (A,B).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input) COMPLEX*16 array, dimension (LDB,N)
The upper triangular matrix B in the pair (A, B).
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
VL (input) COMPLEX*16 array, dimension (LDVL,M)
IF JOB = 'E' or 'B', VL must contain left eigenvectors of
(A, B), corresponding to the eigenpairs specified by HOWMNY
and SELECT. The eigenvectors must be stored in consecutive
columns of VL, as returned by ZTGEVC.
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
(A, B), corresponding to the eigenpairs specified by HOWMNY
and SELECT. The eigenvectors must be stored in consecutive
columns of VR, as returned by ZTGEVC.
If JOB = 'V', VR is not referenced.
LDVR (input) INTEGER
The leading dimension of the array VR. LDVR >= 1;
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.
If JOB = 'V', S is not referenced.
DIF (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 the eigenvalues cannot be reordered to compute DIF(j),
DIF(j) is set to 0; this can only occur when the true value
would be very small anyway.
For each eigenvalue/vector specified by SELECT, DIF stores
a Frobenius norm-based estimate of Difl.
If JOB = 'E', DIF is not referenced.
MM (input) INTEGER
The number of elements in the arrays S and DIF. MM >= M.
M (output) INTEGER
The number of elements of the arrays S and DIF used to store
the specified condition numbers; for each selected eigenvalue
one element is used. If HOWMNY = 'A', M is set to N.
WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
If JOB = 'E', 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. LWORK >= 1.
If JOB = 'V' or 'B', LWORK >= 2*N*N.
IWORK (workspace) INTEGER array, dimension (N+2)
If JOB = 'E', IWORK is not referenced.
INFO (output) INTEGER
= 0: Successful exit
< 0: If INFO = -i, the i-th argument had an illegal value
Further Details
===============
The reciprocal of the condition number of the i-th generalized
eigenvalue w = (a, b) is defined as
S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v))
where u and v are the right and left eigenvectors of (A, B)
corresponding to w; |z| denotes the absolute value of the complex
number, and norm(u) denotes the 2-norm of the vector u. The pair
(a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the
matrix pair (A, B). If both a and b equal zero, then (A,B) is
singular and S(I) = -1 is returned.
An approximate error bound on the chordal distance between the i-th
computed generalized eigenvalue w and the corresponding exact
eigenvalue lambda is
chord(w, lambda) <= EPS * norm(A, B) / S(I),
where EPS is the machine precision.
The reciprocal of the condition number of the right eigenvector u
and left eigenvector v corresponding to the generalized eigenvalue w
is defined as follows. Suppose
(A, B) = ( a * ) ( b * ) 1
( 0 A22 ),( 0 B22 ) n-1
1 n-1 1 n-1
Then the reciprocal condition number DIF(I) is
Difl[(a, b), (A22, B22)] = sigma-min( Zl )
where sigma-min(Zl) denotes the smallest singular value of
Zl = [ kron(a, In-1) -kron(1, A22) ]
[ kron(b, In-1) -kron(1, B22) ].
Here In-1 is the identity matrix of size n-1 and X' is the conjugate
transpose of X. kron(X, Y) is the Kronecker product between the
matrices X and Y.
We approximate the smallest singular value of Zl with an upper
bound. This is done by ZLATDF.
An approximate error bound for a computed eigenvector VL(i) or
VR(i) is given by
EPS * norm(A, B) / DIF(i).
See ref. [2-3] for more details and further references.
Based on contributions by
Bo Kagstrom and Peter Poromaa, Department of Computing Science,
Umea University, S-901 87 Umea, Sweden.
References
==========
[1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
M.S. Moonen et al (eds), Linear Algebra for Large Scale and
Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
[2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
Eigenvalues of a Regular Matrix Pair (A, B) and Condition
Estimation: Theory, Algorithms and Software, Report
UMINF - 94.04, Department of Computing Science, Umea University,
S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.
To appear in Numerical Algorithms, 1996.
[3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
for Solving the Generalized Sylvester Equation and Estimating the
Separation between Regular Matrix Pairs, Report UMINF - 93.23,
Department of Computing Science, Umea University, S-901 87 Umea,
Sweden, December 1993, Revised April 1994, Also as LAPACK Working
Note 75.
To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996.
=====================================================================
Decode and test the input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublecomplex c_b19 = {1.,0.};
static doublecomplex c_b20 = {0.,0.};
static logical c_false = FALSE_;
static integer c__3 = 3;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
vr_offset, i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double z_abs(doublecomplex *);
/* Local variables */
static doublereal cond;
static integer ierr, ifst;
static doublereal lnrm;
static doublecomplex yhax, yhbx;
static integer ilst;
static doublereal rnrm;
static integer i__, k;
static doublereal scale;
extern logical lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer lwmin;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static logical wants;
static integer llwrk, n1, n2;
static doublecomplex dummy[1];
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
static doublecomplex dummy1[1];
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *);
static integer ks;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal bignum;
static logical wantbh, wantdf, somcon;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
ztgexc_(logical *, logical *, integer *, doublecomplex *, integer
*, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *, integer *);
static doublereal smlnum;
static logical lquery;
extern /* Subroutine */ int ztgsyl_(char *, integer *, integer *, integer
*, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, integer *, integer *,
integer *);
static doublereal eps;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define 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;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_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;
--dif;
--work;
--iwork;
/* Function Body */
wantbh = lsame_(job, "B");
wants = lsame_(job, "E") || wantbh;
wantdf = lsame_(job, "V") || wantbh;
somcon = lsame_(howmny, "S");
*info = 0;
lquery = *lwork == -1;
if (lsame_(job, "V") || lsame_(job, "B")) {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 1) * *n;
lwmin = max(i__1,i__2);
} else {
lwmin = 1;
}
if (! wants && ! wantdf) {
*info = -1;
} else if (! lsame_(howmny, "A") && ! somcon) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (wants && *ldvl < *n) {
*info = -10;
} else if (wants && *ldvr < *n) {
*info = -12;
} else {
/* Set M to the number of eigenpairs for which condition numbers
are required, and test MM. */
if (somcon) {
*m = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (select[k]) {
++(*m);
}
/* L10: */
}
} else {
*m = *n;
}
if (*mm < *m) {
*info = -15;
} else if (*lwork < lwmin && ! lquery) {
*info = -18;
}
}
if (*info == 0) {
work[1].r = (doublereal) lwmin, work[1].i = 0.;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTGSNA", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
llwrk = *lwork - (*n << 1) * *n;
ks = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Determine whether condition numbers are required for the k-th
eigenpair. */
if (somcon) {
if (! select[k]) {
goto L20;
}
}
++ks;
if (wants) {
/* Compute the reciprocal condition number of the k-th
eigenvalue. */
rnrm = dznrm2_(n, &vr_ref(1, ks), &c__1);
lnrm = dznrm2_(n, &vl_ref(1, ks), &c__1);
zgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr_ref(1, ks), &
c__1, &c_b20, &work[1], &c__1);
zdotc_(&z__1, n, &work[1], &c__1, &vl_ref(1, ks), &c__1);
yhax.r = z__1.r, yhax.i = z__1.i;
zgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr_ref(1, ks), &
c__1, &c_b20, &work[1], &c__1);
zdotc_(&z__1, n, &work[1], &c__1, &vl_ref(1, ks), &c__1);
yhbx.r = z__1.r, yhbx.i = z__1.i;
d__1 = z_abs(&yhax);
d__2 = z_abs(&yhbx);
cond = dlapy2_(&d__1, &d__2);
if (cond == 0.) {
s[ks] = -1.;
} else {
s[ks] = cond / (rnrm * lnrm);
}
}
if (wantdf) {
if (*n == 1) {
d__1 = z_abs(&a_ref(1, 1));
d__2 = z_abs(&b_ref(1, 1));
dif[ks] = dlapy2_(&d__1, &d__2);
goto L20;
}
/* Estimate the reciprocal condition number of the k-th
eigenvectors.
Copy the matrix (A, B) to the array WORK and move the
(k,k)th pair to the (1,1) position. */
zlacpy_("Full", n, n, &a[a_offset], lda, &work[1], n);
zlacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n);
ifst = k;
ilst = 1;
ztgexc_(&c_false, &c_false, n, &work[1], n, &work[*n * *n + 1], n,
dummy, &c__1, dummy1, &c__1, &ifst, &ilst, &ierr);
if (ierr > 0) {
/* Ill-conditioned problem - swap rejected. */
dif[ks] = 0.;
} else {
/* Reordering successful, solve generalized Sylvester
equation for R and L,
A22 * R - L * A11 = A12
B22 * R - L * B11 = B12,
and compute estimate of Difl[(A11,B11), (A22, B22)]. */
n1 = 1;
n2 = *n - n1;
i__ = *n * *n + 1;
ztgsyl_("N", &c__3, &n2, &n1, &work[*n * n1 + n1 + 1], n, &
work[1], n, &work[n1 + 1], n, &work[*n * n1 + n1 +
i__], n, &work[i__], n, &work[n1 + i__], n, &scale, &
dif[ks], &work[(*n * *n << 1) + 1], &llwrk, &iwork[1],
&ierr);
}
}
L20:
;
}
work[1].r = (doublereal) lwmin, work[1].i = 0.;
return 0;
/* End of ZTGSNA */
} /* ztgsna_ */
/* Subroutine */ int zgeqpf_(integer *m, integer *n, doublecomplex *a,
integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work,
doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static integer i__, j, ma, mn;
static doublecomplex aii;
static integer pvt;
static doublereal temp, temp2;
static integer itemp;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, ftnlen), zswap_(integer *,
doublecomplex *, integer *, doublecomplex *, integer *), zgeqr2_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen,
ftnlen);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlarfg_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
/* -- LAPACK auxiliary 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 */
/* ======= */
/* This routine is deprecated and has been replaced by routine ZGEQP3. */
/* ZGEQPF computes a QR factorization with column pivoting of a */
/* complex M-by-N matrix A: A*P = Q*R. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0 */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the upper triangle of the array contains the */
/* min(M,N)-by-N upper triangular matrix R; the elements */
/* below the diagonal, together with the array TAU, */
/* represent the unitary matrix Q as a product of */
/* min(m,n) elementary reflectors. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* JPVT (input/output) INTEGER array, dimension (N) */
/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
/* to the front of A*P (a leading column); if JPVT(i) = 0, */
/* the i-th column of A is a free column. */
/* On exit, if JPVT(i) = k, then the i-th column of A*P */
/* was the k-th column of A. */
/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors. */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of elementary reflectors */
/* Q = H(1) H(2) . . . H(n) */
/* Each H(i) has the form */
/* H = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). */
/* The matrix P is represented in jpvt as follows: If */
/* jpvt(j) = i */
/* then the jth column of P is the ith canonical unit vector. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--work;
--rwork;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEQPF", &i__1, (ftnlen)6);
return 0;
}
mn = min(*m,*n);
/* Move initial columns up front */
itemp = 1;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (jpvt[i__] != 0) {
if (i__ != itemp) {
zswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1],
&c__1);
jpvt[i__] = jpvt[itemp];
jpvt[itemp] = i__;
} else {
jpvt[i__] = i__;
}
++itemp;
} else {
jpvt[i__] = i__;
}
/* L10: */
}
--itemp;
/* Compute the QR factorization and update remaining columns */
if (itemp > 0) {
ma = min(itemp,*m);
zgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info);
if (ma < *n) {
i__1 = *n - ma;
zunm2r_("Left", "Conjugate transpose", m, &i__1, &ma, &a[a_offset]
, lda, &tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1],
info, (ftnlen)4, (ftnlen)19);
}
}
if (itemp < mn) {
/* Initialize partial column norms. The first n elements of */
/* work store the exact column norms. */
i__1 = *n;
for (i__ = itemp + 1; i__ <= i__1; ++i__) {
i__2 = *m - itemp;
rwork[i__] = dznrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1);
rwork[*n + i__] = rwork[i__];
/* L20: */
}
/* Compute factorization */
i__1 = mn;
for (i__ = itemp + 1; i__ <= i__1; ++i__) {
/* Determine ith pivot column and swap if necessary */
i__2 = *n - i__ + 1;
pvt = i__ - 1 + idamax_(&i__2, &rwork[i__], &c__1);
if (pvt != i__) {
zswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
c__1);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[i__];
jpvt[i__] = itemp;
rwork[pvt] = rwork[i__];
rwork[*n + pvt] = rwork[*n + i__];
}
/* Generate elementary reflector H(i) */
i__2 = i__ + i__ * a_dim1;
aii.r = a[i__2].r, aii.i = a[i__2].i;
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
zlarfg_(&i__2, &aii, &a[min(i__3,*m) + i__ * a_dim1], &c__1, &tau[
i__]);
i__2 = i__ + i__ * a_dim1;
a[i__2].r = aii.r, a[i__2].i = aii.i;
if (i__ < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */
i__2 = i__ + i__ * a_dim1;
aii.r = a[i__2].r, aii.i = a[i__2].i;
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
i__2 = *m - i__ + 1;
i__3 = *n - i__;
d_cnjg(&z__1, &tau[i__]);
zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
z__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], (
ftnlen)4);
i__2 = i__ + i__ * a_dim1;
a[i__2].r = aii.r, a[i__2].i = aii.i;
}
/* Update partial column norms */
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (rwork[j] != 0.) {
/* Computing 2nd power */
d__1 = z_abs(&a[i__ + j * a_dim1]) / rwork[j];
temp = 1. - d__1 * d__1;
temp = max(temp,0.);
/* Computing 2nd power */
d__1 = rwork[j] / rwork[*n + j];
temp2 = temp * .05 * (d__1 * d__1) + 1.;
if (temp2 == 1.) {
if (*m - i__ > 0) {
i__3 = *m - i__;
rwork[j] = dznrm2_(&i__3, &a[i__ + 1 + j * a_dim1]
, &c__1);
rwork[*n + j] = rwork[j];
} else {
rwork[j] = 0.;
rwork[*n + j] = 0.;
}
} else {
rwork[j] *= sqrt(temp);
}
}
/* L30: */
}
/* L40: */
}
}
return 0;
/* End of ZGEQPF */
} /* zgeqpf_ */
double dznrm2( int n, doublecomplex *x, int incx)
{
return dznrm2_(&n, x, &incx);
}
/* Subroutine */
int zlarfgp_(integer *n, doublecomplex *alpha, doublecomplex *x, integer *incx, doublecomplex *tau)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *), z_abs( doublecomplex *);
/* Local variables */
integer j;
doublecomplex savealpha;
integer knt;
doublereal beta, alphi, alphr;
extern /* Subroutine */
int zscal_(integer *, doublecomplex *, doublecomplex *, integer *);
doublereal xnorm;
extern doublereal dlapy2_(doublereal *, doublereal *), dlapy3_(doublereal *, doublereal *, doublereal *), dznrm2_(integer *, doublecomplex * , integer *), dlamch_(char *);
extern /* Subroutine */
int zdscal_(integer *, doublereal *, doublecomplex *, integer *);
doublereal bignum;
extern /* Double Complex */
VOID zladiv_(doublecomplex *, doublecomplex *, doublecomplex *);
doublereal smlnum;
/* -- 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 .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 0)
{
tau->r = 0., tau->i = 0.;
return 0;
}
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = d_imag(alpha);
if (xnorm == 0.)
{
/* H = [1-alpha/abs(alpha) 0;
0 I], sign chosen so ALPHA >= 0. */
if (alphi == 0.)
{
if (alphr >= 0.)
{
/* When TAU.eq.ZERO, the vector is special-cased to be */
/* all zeros in the application routines. We do not need */
/* to clear it. */
tau->r = 0., tau->i = 0.;
}
else
{
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
tau->r = 2., tau->i = 0.;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.;
x[i__2].i = 0.; // , expr subst
}
z__1.r = -alpha->r;
z__1.i = -alpha->i; // , expr subst
alpha->r = z__1.r, alpha->i = z__1.i;
}
}
else
{
/* Only "reflecting" the diagonal entry to be real and non-negative. */
xnorm = dlapy2_(&alphr, &alphi);
d__1 = 1. - alphr / xnorm;
d__2 = -alphi / xnorm;
z__1.r = d__1;
z__1.i = d__2; // , expr subst
tau->r = z__1.r, tau->i = z__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.;
x[i__2].i = 0.; // , expr subst
}
alpha->r = xnorm, alpha->i = 0.;
}
}
else
{
/* general case */
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = d_sign(&d__1, &alphr);
smlnum = dlamch_("S") / dlamch_("E");
bignum = 1. / smlnum;
knt = 0;
if (abs(beta) < smlnum)
{
/* XNORM, BETA may be inaccurate;
scale X and recompute them */
L10:
++knt;
i__1 = *n - 1;
zdscal_(&i__1, &bignum, &x[1], incx);
beta *= bignum;
alphi *= bignum;
alphr *= bignum;
if (abs(beta) < smlnum)
{
goto L10;
}
/* New BETA is at most 1, at least SMLNUM */
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
z__1.r = alphr;
z__1.i = alphi; // , expr subst
alpha->r = z__1.r, alpha->i = z__1.i;
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = d_sign(&d__1, &alphr);
}
savealpha.r = alpha->r;
savealpha.i = alpha->i; // , expr subst
z__1.r = alpha->r + beta;
z__1.i = alpha->i; // , expr subst
alpha->r = z__1.r, alpha->i = z__1.i;
if (beta < 0.)
{
beta = -beta;
z__2.r = -alpha->r;
z__2.i = -alpha->i; // , expr subst
z__1.r = z__2.r / beta;
z__1.i = z__2.i / beta; // , expr subst
tau->r = z__1.r, tau->i = z__1.i;
}
else
{
alphr = alphi * (alphi / alpha->r);
alphr += xnorm * (xnorm / alpha->r);
d__1 = alphr / beta;
d__2 = -alphi / beta;
z__1.r = d__1;
z__1.i = d__2; // , expr subst
tau->r = z__1.r, tau->i = z__1.i;
d__1 = -alphr;
z__1.r = d__1;
z__1.i = alphi; // , expr subst
alpha->r = z__1.r, alpha->i = z__1.i;
}
zladiv_(&z__1, &c_b5, alpha);
alpha->r = z__1.r, alpha->i = z__1.i;
if (z_abs(tau) <= smlnum)
{
/* In the case where the computed TAU ends up being a denormalized number, */
/* it loses relative accuracy. This is a BIG problem. Solution: flush TAU */
/* to ZERO (or TWO or whatever makes a nonnegative real number for BETA). */
/* (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.) */
/* (Thanks Pat. Thanks MathWorks.) */
alphr = savealpha.r;
alphi = d_imag(&savealpha);
if (alphi == 0.)
{
if (alphr >= 0.)
{
tau->r = 0., tau->i = 0.;
}
else
{
tau->r = 2., tau->i = 0.;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.;
x[i__2].i = 0.; // , expr subst
}
z__1.r = -savealpha.r;
z__1.i = -savealpha.i; // , expr subst
beta = z__1.r;
}
}
else
{
xnorm = dlapy2_(&alphr, &alphi);
d__1 = 1. - alphr / xnorm;
d__2 = -alphi / xnorm;
z__1.r = d__1;
z__1.i = d__2; // , expr subst
tau->r = z__1.r, tau->i = z__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.;
x[i__2].i = 0.; // , expr subst
}
beta = xnorm;
}
}
else
{
/* This is the general case. */
i__1 = *n - 1;
zscal_(&i__1, alpha, &x[1], incx);
}
/* If BETA is subnormal, it may lose relative accuracy */
i__1 = knt;
for (j = 1;
j <= i__1;
++j)
{
beta *= smlnum;
/* L20: */
}
alpha->r = beta, alpha->i = 0.;
}
return 0;
/* End of ZLARFGP */
}
/* Subroutine */ int zgetv0_(integer *ido, char *bmat, integer *itry, logical
*initv, integer *n, integer *j, doublecomplex *v, integer *ldv,
doublecomplex *resid, doublereal *rnorm, integer *ipntr,
doublecomplex *workd, integer *ierr, ftnlen bmat_len)
{
/* Initialized data */
static logical inits = TRUE_;
/* System generated locals */
integer v_dim1, v_offset, i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1;
/* Local variables */
static real t0, t1, t2, t3;
static integer jj, iter;
static logical orth;
static integer iseed[4], idist;
static doublecomplex cnorm;
extern /* Double Complex */ void zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static logical first;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, ftnlen),
dvout_(integer *, integer *, doublereal *, integer *, char *,
ftnlen), zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zvout_(integer *, integer *,
doublecomplex *, integer *, char *, ftnlen);
extern doublereal dlapy2_(doublereal *, doublereal *), dznrm2_(integer *,
doublecomplex *, integer *);
static doublereal rnorm0;
extern /* Subroutine */ int arscnd_(real *);
static integer msglvl;
extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
doublecomplex *);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %------------------------% */
/* | Local Scalars & Arrays | */
/* %------------------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %-----------------% */
/* | Data Statements | */
/* %-----------------% */
/* Parameter adjustments */
--workd;
--resid;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--ipntr;
/* Function Body */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %-----------------------------------% */
/* | Initialize the seed of the LAPACK | */
/* | random number generator | */
/* %-----------------------------------% */
if (inits) {
iseed[0] = 1;
iseed[1] = 3;
iseed[2] = 5;
iseed[3] = 7;
inits = FALSE_;
}
if (*ido == 0) {
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
arscnd_(&t0);
msglvl = debug_1.mgetv0;
*ierr = 0;
iter = 0;
first = FALSE_;
orth = FALSE_;
/* %-----------------------------------------------------% */
/* | Possibly generate a random starting vector in RESID | */
/* | Use a LAPACK random number generator used by the | */
/* | matrix generation routines. | */
/* | idist = 1: uniform (0,1) distribution; | */
/* | idist = 2: uniform (-1,1) distribution; | */
/* | idist = 3: normal (0,1) distribution; | */
/* %-----------------------------------------------------% */
if (! (*initv)) {
idist = 2;
zlarnv_(&idist, iseed, n, &resid[1]);
}
/* %----------------------------------------------------------% */
/* | Force the starting vector into the range of OP to handle | */
/* | the generalized problem when B is possibly (singular). | */
/* %----------------------------------------------------------% */
arscnd_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nopx;
ipntr[1] = 1;
ipntr[2] = *n + 1;
zcopy_(n, &resid[1], &c__1, &workd[1], &c__1);
*ido = -1;
goto L9000;
}
}
/* %----------------------------------------% */
/* | Back from computing B*(initial-vector) | */
/* %----------------------------------------% */
if (first) {
goto L20;
}
/* %-----------------------------------------------% */
/* | Back from computing B*(orthogonalized-vector) | */
/* %-----------------------------------------------% */
if (orth) {
goto L40;
}
arscnd_(&t3);
timing_1.tmvopx += t3 - t2;
/* %------------------------------------------------------% */
/* | Starting vector is now in the range of OP; r = OP*r; | */
/* | Compute B-norm of starting vector. | */
/* %------------------------------------------------------% */
arscnd_(&t2);
first = TRUE_;
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
zcopy_(n, &workd[*n + 1], &c__1, &resid[1], &c__1);
ipntr[1] = *n + 1;
ipntr[2] = 1;
*ido = 2;
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
zcopy_(n, &resid[1], &c__1, &workd[1], &c__1);
}
L20:
if (*(unsigned char *)bmat == 'G') {
arscnd_(&t3);
timing_1.tmvbx += t3 - t2;
}
first = FALSE_;
if (*(unsigned char *)bmat == 'G') {
zdotc_(&z__1, n, &resid[1], &c__1, &workd[1], &c__1);
cnorm.r = z__1.r, cnorm.i = z__1.i;
d__1 = cnorm.r;
d__2 = d_imag(&cnorm);
rnorm0 = sqrt(dlapy2_(&d__1, &d__2));
} else if (*(unsigned char *)bmat == 'I') {
rnorm0 = dznrm2_(n, &resid[1], &c__1);
}
*rnorm = rnorm0;
/* %---------------------------------------------% */
/* | Exit if this is the very first Arnoldi step | */
/* %---------------------------------------------% */
if (*j == 1) {
goto L50;
}
/* %---------------------------------------------------------------- */
/* | Otherwise need to B-orthogonalize the starting vector against | */
/* | the current Arnoldi basis using Gram-Schmidt with iter. ref. | */
/* | This is the case where an invariant subspace is encountered | */
/* | in the middle of the Arnoldi factorization. | */
/* | | */
/* | s = V^{T}*B*r; r = r - V*s; | */
/* | | */
/* | Stopping criteria used for iter. ref. is discussed in | */
/* | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | */
/* %---------------------------------------------------------------% */
orth = TRUE_;
L30:
i__1 = *j - 1;
zgemv_("C", n, &i__1, &c_b1, &v[v_offset], ldv, &workd[1], &c__1, &c_b2, &
workd[*n + 1], &c__1, (ftnlen)1);
i__1 = *j - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("N", n, &i__1, &z__1, &v[v_offset], ldv, &workd[*n + 1], &c__1, &
c_b1, &resid[1], &c__1, (ftnlen)1);
/* %----------------------------------------------------------% */
/* | Compute the B-norm of the orthogonalized starting vector | */
/* %----------------------------------------------------------% */
arscnd_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
zcopy_(n, &resid[1], &c__1, &workd[*n + 1], &c__1);
ipntr[1] = *n + 1;
ipntr[2] = 1;
*ido = 2;
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
zcopy_(n, &resid[1], &c__1, &workd[1], &c__1);
}
L40:
if (*(unsigned char *)bmat == 'G') {
arscnd_(&t3);
timing_1.tmvbx += t3 - t2;
}
if (*(unsigned char *)bmat == 'G') {
zdotc_(&z__1, n, &resid[1], &c__1, &workd[1], &c__1);
cnorm.r = z__1.r, cnorm.i = z__1.i;
d__1 = cnorm.r;
d__2 = d_imag(&cnorm);
*rnorm = sqrt(dlapy2_(&d__1, &d__2));
} else if (*(unsigned char *)bmat == 'I') {
*rnorm = dznrm2_(n, &resid[1], &c__1);
}
/* %--------------------------------------% */
/* | Check for further orthogonalization. | */
/* %--------------------------------------% */
if (msglvl > 2) {
dvout_(&debug_1.logfil, &c__1, &rnorm0, &debug_1.ndigit, "_getv0: re"
"-orthonalization ; rnorm0 is", (ftnlen)38);
dvout_(&debug_1.logfil, &c__1, rnorm, &debug_1.ndigit, "_getv0: re-o"
"rthonalization ; rnorm is", (ftnlen)37);
}
if (*rnorm > rnorm0 * .717f) {
goto L50;
}
++iter;
if (iter <= 1) {
/* %-----------------------------------% */
/* | Perform iterative refinement step | */
/* %-----------------------------------% */
rnorm0 = *rnorm;
goto L30;
} else {
/* %------------------------------------% */
/* | Iterative refinement step "failed" | */
/* %------------------------------------% */
i__1 = *n;
for (jj = 1; jj <= i__1; ++jj) {
i__2 = jj;
resid[i__2].r = 0., resid[i__2].i = 0.;
/* L45: */
}
*rnorm = 0.;
*ierr = -1;
}
L50:
if (msglvl > 0) {
dvout_(&debug_1.logfil, &c__1, rnorm, &debug_1.ndigit, "_getv0: B-no"
"rm of initial / restarted starting vector", (ftnlen)53);
}
if (msglvl > 2) {
zvout_(&debug_1.logfil, n, &resid[1], &debug_1.ndigit, "_getv0: init"
"ial / restarted starting vector", (ftnlen)43);
}
*ido = 99;
arscnd_(&t1);
timing_1.tgetv0 += t1 - t0;
L9000:
return 0;
/* %---------------% */
/* | End of zgetv0 | */
/* %---------------% */
} /* zgetv0_ */
/* 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 zlaqps_(integer *m, integer *n, integer *offset, integer
*nb, integer *kb, doublecomplex *a, integer *lda, integer *jpvt,
doublecomplex *tau, doublereal *vn1, doublereal *vn2, doublecomplex *
auxv, doublecomplex *f, integer *ldf)
{
/* System generated locals */
integer a_dim1, a_offset, f_dim1, f_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double sqrt(doublereal);
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
integer i_dnnt(doublereal *);
/* Local variables */
integer j, k, rk;
doublecomplex akk;
integer pvt;
doublereal temp, temp2, tol3z;
integer itemp;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *);
extern integer idamax_(integer *, doublereal *, integer *);
integer lsticc;
extern /* Subroutine */ int zlarfp_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *);
integer lastrk;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAQPS computes a step of QR factorization with column pivoting */
/* of a complex M-by-N matrix A by using Blas-3. It tries to factorize */
/* NB columns from A starting from the row OFFSET+1, and updates all */
/* of the matrix with Blas-3 xGEMM. */
/* In some cases, due to catastrophic cancellations, it cannot */
/* factorize NB columns. Hence, the actual number of factorized */
/* columns is returned in KB. */
/* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0 */
/* OFFSET (input) INTEGER */
/* The number of rows of A that have been factorized in */
/* previous steps. */
/* NB (input) INTEGER */
/* The number of columns to factorize. */
/* KB (output) INTEGER */
/* The number of columns actually factorized. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, block A(OFFSET+1:M,1:KB) is the triangular */
/* factor obtained and block A(1:OFFSET,1:N) has been */
/* accordingly pivoted, but no factorized. */
/* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has */
/* been updated. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* JPVT (input/output) INTEGER array, dimension (N) */
/* JPVT(I) = K <==> Column K of the full matrix A has been */
/* permuted into position I in AP. */
/* TAU (output) COMPLEX*16 array, dimension (KB) */
/* The scalar factors of the elementary reflectors. */
/* VN1 (input/output) DOUBLE PRECISION array, dimension (N) */
/* The vector with the partial column norms. */
/* VN2 (input/output) DOUBLE PRECISION array, dimension (N) */
/* The vector with the exact column norms. */
/* AUXV (input/output) COMPLEX*16 array, dimension (NB) */
/* Auxiliar vector. */
/* F (input/output) COMPLEX*16 array, dimension (LDF,NB) */
/* Matrix F' = L*Y'*A. */
/* LDF (input) INTEGER */
/* The leading dimension of the array F. LDF >= max(1,N). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
/* X. Sun, Computer Science Dept., Duke University, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--vn1;
--vn2;
--auxv;
f_dim1 = *ldf;
f_offset = 1 + f_dim1;
f -= f_offset;
/* Function Body */
/* Computing MIN */
i__1 = *m, i__2 = *n + *offset;
lastrk = min(i__1,i__2);
lsticc = 0;
k = 0;
tol3z = sqrt(dlamch_("Epsilon"));
/* Beginning of while loop. */
L10:
if (k < *nb && lsticc == 0) {
++k;
rk = *offset + k;
/* Determine ith pivot column and swap if necessary */
i__1 = *n - k + 1;
pvt = k - 1 + idamax_(&i__1, &vn1[k], &c__1);
if (pvt != k) {
zswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
i__1 = k - 1;
zswap_(&i__1, &f[pvt + f_dim1], ldf, &f[k + f_dim1], ldf);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[k];
jpvt[k] = itemp;
vn1[pvt] = vn1[k];
vn2[pvt] = vn2[k];
}
/* Apply previous Householder reflectors to column K: */
/* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'. */
if (k > 1) {
i__1 = k - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j * f_dim1;
d_cnjg(&z__1, &f[k + j * f_dim1]);
f[i__2].r = z__1.r, f[i__2].i = z__1.i;
/* L20: */
}
i__1 = *m - rk + 1;
i__2 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__1, &i__2, &z__1, &a[rk + a_dim1], lda,
&f[k + f_dim1], ldf, &c_b2, &a[rk + k * a_dim1], &c__1);
i__1 = k - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j * f_dim1;
d_cnjg(&z__1, &f[k + j * f_dim1]);
f[i__2].r = z__1.r, f[i__2].i = z__1.i;
/* L30: */
}
}
/* Generate elementary reflector H(k). */
if (rk < *m) {
i__1 = *m - rk + 1;
zlarfp_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], &
c__1, &tau[k]);
} else {
zlarfp_(&c__1, &a[rk + k * a_dim1], &a[rk + k * a_dim1], &c__1, &
tau[k]);
}
i__1 = rk + k * a_dim1;
akk.r = a[i__1].r, akk.i = a[i__1].i;
i__1 = rk + k * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
/* Compute Kth column of F: */
/* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). */
if (k < *n) {
i__1 = *m - rk + 1;
i__2 = *n - k;
zgemv_("Conjugate transpose", &i__1, &i__2, &tau[k], &a[rk + (k +
1) * a_dim1], lda, &a[rk + k * a_dim1], &c__1, &c_b1, &f[
k + 1 + k * f_dim1], &c__1);
}
/* Padding F(1:K,K) with zeros. */
i__1 = k;
for (j = 1; j <= i__1; ++j) {
i__2 = j + k * f_dim1;
f[i__2].r = 0., f[i__2].i = 0.;
/* L40: */
}
/* Incremental updating of F: */
/* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)' */
/* *A(RK:M,K). */
if (k > 1) {
i__1 = *m - rk + 1;
i__2 = k - 1;
i__3 = k;
z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
zgemv_("Conjugate transpose", &i__1, &i__2, &z__1, &a[rk + a_dim1]
, lda, &a[rk + k * a_dim1], &c__1, &c_b1, &auxv[1], &c__1);
i__1 = k - 1;
zgemv_("No transpose", n, &i__1, &c_b2, &f[f_dim1 + 1], ldf, &
auxv[1], &c__1, &c_b2, &f[k * f_dim1 + 1], &c__1);
}
/* Update the current row of A: */
/* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'. */
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &c__1, &i__1, &k, &
z__1, &a[rk + a_dim1], lda, &f[k + 1 + f_dim1], ldf, &
c_b2, &a[rk + (k + 1) * a_dim1], lda);
}
/* Update partial column norms. */
if (rk < lastrk) {
i__1 = *n;
for (j = k + 1; j <= i__1; ++j) {
if (vn1[j] != 0.) {
/* NOTE: The following 4 lines follow from the analysis in */
/* Lapack Working Note 176. */
temp = z_abs(&a[rk + j * a_dim1]) / vn1[j];
/* Computing MAX */
d__1 = 0., d__2 = (temp + 1.) * (1. - temp);
temp = max(d__1,d__2);
/* Computing 2nd power */
d__1 = vn1[j] / vn2[j];
temp2 = temp * (d__1 * d__1);
if (temp2 <= tol3z) {
vn2[j] = (doublereal) lsticc;
lsticc = j;
} else {
vn1[j] *= sqrt(temp);
}
}
/* L50: */
}
}
i__1 = rk + k * a_dim1;
a[i__1].r = akk.r, a[i__1].i = akk.i;
/* End of while loop. */
goto L10;
}
*kb = k;
rk = *offset + *kb;
/* Apply the block reflector to the rest of the matrix: */
/* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - */
/* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'. */
/* Computing MIN */
i__1 = *n, i__2 = *m - *offset;
if (*kb < min(i__1,i__2)) {
i__1 = *m - rk;
i__2 = *n - *kb;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", &i__1, &i__2, kb, &z__1,
&a[rk + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b2, &
a[rk + 1 + (*kb + 1) * a_dim1], lda);
}
/* Recomputation of difficult columns. */
L60:
if (lsticc > 0) {
itemp = i_dnnt(&vn2[lsticc]);
i__1 = *m - rk;
vn1[lsticc] = dznrm2_(&i__1, &a[rk + 1 + lsticc * a_dim1], &c__1);
/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */
/* SNRM2 does not fail on vectors with norm below the value of */
/* SQRT(DLAMCH('S')) */
vn2[lsticc] = vn1[lsticc];
lsticc = itemp;
goto L60;
}
return 0;
/* End of ZLAQPS */
} /* zlaqps_ */
/* Subroutine */ int check1_(doublereal *sfac)
{
/* Initialized data */
static doublereal strue2[5] = { 0.,.5,.6,.7,.7 };
static doublereal strue4[5] = { 0.,.7,1.,1.3,1.7 };
static doublecomplex ctrue5[80] /* was [8][5][2] */ = { {.1,.1},{
1.,
2.
},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{-.16,-.37},{
3.,4.
},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{-.17,-.19}
,{.13,-.39},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{
.11,
-.03
},{-.17,.46},{-.17,-.19},{7.,8.},{7.,8.},{7.,8.},{7.,8.},{
7.,
8.
},{.19,-.17},{.32,.09},{.23,-.24},{.18,.01},{2.,3.},{2.,3.},{
2.,
3.
},{2.,3.},{.1,.1},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{
4.,
5.
},{4.,5.},{-.16,-.37},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{
6.,7.
},{6.,7.},{-.17,-.19},{8.,9.},{.13,-.39},{2.,5.},{2.,5.},{
2.,
5.
},{2.,5.},{2.,5.},{.11,-.03},{3.,6.},{-.17,.46},{4.,7.},{
-.17,
-.19
},{7.,2.},{7.,2.},{7.,2.},{.19,-.17},{5.,8.},{.32,.09},{6.,9.}
,{.23,-.24},{8.,3.},{.18,.01},{9.,4.}
};
static doublecomplex ctrue6[80] /* was [8][5][2] */ = { {.1,.1},{
1.,
2.
},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{.09,-.12},{
3.,4.
},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{.03,-.09},
{.15,-.03},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{.03,
.03
},{-.18,.03},{.03,-.09},{7.,8.},{7.,8.},{7.,8.},{7.,8.},{7.,8.}
,{.09,.03},{.03,.12},{.12,.03},{.03,.06},{2.,3.},{2.,3.},{2.,3.},{
2.,3.
},{.1,.1},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{
4.,5.
},{.09,-.12},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.},
{6.,7.},{.03,-.09},{8.,9.},{.15,-.03},{2.,5.},{2.,5.},{2.,5.},{2.,
5.
},{2.,5.},{.03,.03},{3.,6.},{-.18,.03},{4.,7.},{.03,-.09},{
7.,
2.
},{7.,2.},{7.,2.},{.09,.03},{5.,8.},{.03,.12},{6.,9.},{.12,.03},
{8.,3.},{.03,.06},{9.,4.}
};
static integer itrue3[5] = { 0,1,2,2,2 };
static doublereal sa = .3;
static doublecomplex ca = {.4,-.7};
static doublecomplex cv[80] /* was [8][5][2] */ = { {.1,.1},{1.,2.},{
1.,
2.
},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{.3,-.4},{3.,4.},{
3.,
4.
},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{.1,-.3},{.5,-.1},{
5.,
6.
},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{.1,.1},{-.6,.1},{
.1,
-.3
},{7.,8.},{7.,8.},{7.,8.},{7.,8.},{7.,8.},{.3,.1},{.1,.4},{
.4,
.1
},{.1,.2},{2.,3.},{2.,3.},{2.,3.},{2.,3.},{.1,.1},{4.,5.},{
4.,
5.
},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{.3,-.4},{6.,7.},{
6.,
7.
},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{.1,-.3},{8.,9.},{
.5,
-.1
},{2.,5.},{2.,5.},{2.,5.},{2.,5.},{2.,5.},{.1,.1},{3.,6.},{
-.6,
.1
},{4.,7.},{.1,-.3},{7.,2.},{7.,2.},{7.,2.},{.3,.1},{5.,8.},{
.1,
.4
},{6.,9.},{.4,.1},{8.,3.},{.1,.2},{9.,4.}
};
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
static integer i__;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), ctest_(integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublereal *);
static doublecomplex mwpcs[5], mwpct[5];
extern /* Subroutine */ int itest1_(integer *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int stest1_(doublereal *, doublereal *,
doublereal *, doublereal *);
static doublecomplex cx[8];
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
extern integer izamax_(integer *, doublecomplex *, integer *);
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
static integer np1, len;
/* Fortran I/O blocks */
static cilist io___19 = { 0, 6, 0, 0, 0 };
#define ctrue5_subscr(a_1,a_2,a_3) ((a_3)*5 + (a_2))*8 + a_1 - 49
#define ctrue5_ref(a_1,a_2,a_3) ctrue5[ctrue5_subscr(a_1,a_2,a_3)]
#define ctrue6_subscr(a_1,a_2,a_3) ((a_3)*5 + (a_2))*8 + a_1 - 49
#define ctrue6_ref(a_1,a_2,a_3) ctrue6[ctrue6_subscr(a_1,a_2,a_3)]
#define cv_subscr(a_1,a_2,a_3) ((a_3)*5 + (a_2))*8 + a_1 - 49
#define cv_ref(a_1,a_2,a_3) cv[cv_subscr(a_1,a_2,a_3)]
for (combla_1.incx = 1; combla_1.incx <= 2; ++combla_1.incx) {
for (np1 = 1; np1 <= 5; ++np1) {
combla_1.n = np1 - 1;
len = max(combla_1.n,1) << 1;
i__1 = len;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ - 1;
i__3 = cv_subscr(i__, np1, combla_1.incx);
cx[i__2].r = cv[i__3].r, cx[i__2].i = cv[i__3].i;
/* L20: */
}
if (combla_1.icase == 6) {
d__1 = dznrm2_(&combla_1.n, cx, &combla_1.incx);
stest1_(&d__1, &strue2[np1 - 1], &strue2[np1 - 1], sfac);
} else if (combla_1.icase == 7) {
d__1 = dzasum_(&combla_1.n, cx, &combla_1.incx);
stest1_(&d__1, &strue4[np1 - 1], &strue4[np1 - 1], sfac);
} else if (combla_1.icase == 8) {
zscal_(&combla_1.n, &ca, cx, &combla_1.incx);
ctest_(&len, cx, &ctrue5_ref(1, np1, combla_1.incx), &
ctrue5_ref(1, np1, combla_1.incx), sfac);
} else if (combla_1.icase == 9) {
zdscal_(&combla_1.n, &sa, cx, &combla_1.incx);
ctest_(&len, cx, &ctrue6_ref(1, np1, combla_1.incx), &
ctrue6_ref(1, np1, combla_1.incx), sfac);
} else if (combla_1.icase == 10) {
i__1 = izamax_(&combla_1.n, cx, &combla_1.incx);
itest1_(&i__1, &itrue3[np1 - 1]);
} else {
s_wsle(&io___19);
do_lio(&c__9, &c__1, " Shouldn't be here in CHECK1", (ftnlen)
28);
e_wsle();
s_stop("", (ftnlen)0);
}
/* L40: */
}
/* L60: */
}
combla_1.incx = 1;
if (combla_1.icase == 8) {
/* ZSCAL
Add a test for alpha equal to zero. */
ca.r = 0., ca.i = 0.;
for (i__ = 1; i__ <= 5; ++i__) {
i__1 = i__ - 1;
mwpct[i__1].r = 0., mwpct[i__1].i = 0.;
i__1 = i__ - 1;
mwpcs[i__1].r = 1., mwpcs[i__1].i = 1.;
/* L80: */
}
zscal_(&c__5, &ca, cx, &combla_1.incx);
ctest_(&c__5, cx, mwpct, mwpcs, sfac);
} else if (combla_1.icase == 9) {
/* ZDSCAL
Add a test for alpha equal to zero. */
sa = 0.;
for (i__ = 1; i__ <= 5; ++i__) {
i__1 = i__ - 1;
mwpct[i__1].r = 0., mwpct[i__1].i = 0.;
i__1 = i__ - 1;
mwpcs[i__1].r = 1., mwpcs[i__1].i = 1.;
/* L100: */
}
zdscal_(&c__5, &sa, cx, &combla_1.incx);
ctest_(&c__5, cx, mwpct, mwpcs, sfac);
/* Add a test for alpha equal to one. */
sa = 1.;
for (i__ = 1; i__ <= 5; ++i__) {
i__1 = i__ - 1;
i__2 = i__ - 1;
mwpct[i__1].r = cx[i__2].r, mwpct[i__1].i = cx[i__2].i;
i__1 = i__ - 1;
i__2 = i__ - 1;
mwpcs[i__1].r = cx[i__2].r, mwpcs[i__1].i = cx[i__2].i;
/* L120: */
}
zdscal_(&c__5, &sa, cx, &combla_1.incx);
ctest_(&c__5, cx, mwpct, mwpcs, sfac);
/* Add a test for alpha equal to minus one. */
sa = -1.;
for (i__ = 1; i__ <= 5; ++i__) {
i__1 = i__ - 1;
i__2 = i__ - 1;
z__1.r = -cx[i__2].r, z__1.i = -cx[i__2].i;
mwpct[i__1].r = z__1.r, mwpct[i__1].i = z__1.i;
i__1 = i__ - 1;
i__2 = i__ - 1;
z__1.r = -cx[i__2].r, z__1.i = -cx[i__2].i;
mwpcs[i__1].r = z__1.r, mwpcs[i__1].i = z__1.i;
/* L140: */
}
zdscal_(&c__5, &sa, cx, &combla_1.incx);
ctest_(&c__5, cx, mwpct, mwpcs, sfac);
}
return 0;
} /* check1_ */
/* Subroutine */ int zlarfg_(integer *n, doublecomplex *alpha, doublecomplex *
x, integer *incx, doublecomplex *tau)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZLARFG generates a complex elementary reflector H of order n, such
that
H' * ( alpha ) = ( beta ), H' * H = I.
( x ) ( 0 )
where alpha and beta are scalars, with beta real, and x is an
(n-1)-element complex vector. H is represented in the form
H = I - tau * ( 1 ) * ( 1 v' ) ,
( v )
where tau is a complex scalar and v is a complex (n-1)-element
vector. Note that H is not hermitian.
If the elements of x are all zero and alpha is real, then tau = 0
and H is taken to be the unit matrix.
Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
Arguments
=========
N (input) INTEGER
The order of the elementary reflector.
ALPHA (input/output) COMPLEX*16
On entry, the value alpha.
On exit, it is overwritten with the value beta.
X (input/output) COMPLEX*16 array, dimension
(1+(N-2)*abs(INCX))
On entry, the vector x.
On exit, it is overwritten with the vector v.
INCX (input) INTEGER
The increment between elements of X. INCX > 0.
TAU (output) COMPLEX*16
The value tau.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b5 = {1.,0.};
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *);
/* Local variables */
static doublereal beta;
static integer j;
static doublereal alphi, alphr;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static doublereal xnorm;
extern doublereal dlapy3_(doublereal *, doublereal *, doublereal *),
dznrm2_(integer *, doublecomplex *, integer *), dlamch_(char *);
static doublereal safmin;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
static doublereal rsafmn;
extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
doublecomplex *);
static integer knt;
--x;
/* Function Body */
if (*n <= 0) {
tau->r = 0., tau->i = 0.;
return 0;
}
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = d_imag(alpha);
if (xnorm == 0. && alphi == 0.) {
/* H = I */
tau->r = 0., tau->i = 0.;
} else {
/* general case */
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = -d_sign(&d__1, &alphr);
safmin = dlamch_("S") / dlamch_("E");
rsafmn = 1. / safmin;
if (abs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
knt = 0;
L10:
++knt;
i__1 = *n - 1;
zdscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
alphi *= rsafmn;
alphr *= rsafmn;
if (abs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
z__1.r = alphr, z__1.i = alphi;
alpha->r = z__1.r, alpha->i = z__1.i;
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = -d_sign(&d__1, &alphr);
d__1 = (beta - alphr) / beta;
d__2 = -alphi / beta;
z__1.r = d__1, z__1.i = d__2;
tau->r = z__1.r, tau->i = z__1.i;
z__2.r = alpha->r - beta, z__2.i = alpha->i;
zladiv_(&z__1, &c_b5, &z__2);
alpha->r = z__1.r, alpha->i = z__1.i;
i__1 = *n - 1;
zscal_(&i__1, alpha, &x[1], incx);
/* If ALPHA is subnormal, it may lose relative accuracy */
alpha->r = beta, alpha->i = 0.;
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
z__1.r = safmin * alpha->r, z__1.i = safmin * alpha->i;
alpha->r = z__1.r, alpha->i = z__1.i;
/* L20: */
}
} else {
d__1 = (beta - alphr) / beta;
d__2 = -alphi / beta;
z__1.r = d__1, z__1.i = d__2;
tau->r = z__1.r, tau->i = z__1.i;
z__2.r = alpha->r - beta, z__2.i = alpha->i;
zladiv_(&z__1, &c_b5, &z__2);
alpha->r = z__1.r, alpha->i = z__1.i;
i__1 = *n - 1;
zscal_(&i__1, alpha, &x[1], incx);
alpha->r = beta, alpha->i = 0.;
}
}
return 0;
/* End of ZLARFG */
} /* zlarfg_ */
/* Subroutine */ int zgeqpf_(integer *m, integer *n, doublecomplex *a,
integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work,
doublereal *rwork, integer *info)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
ZGEQPF computes a QR factorization with column pivoting of a
complex M-by-N matrix A: A*P = Q*R.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, the upper triangle of the array contains the
min(M,N)-by-N upper triangular matrix R; the elements
below the diagonal, together with the array TAU,
represent the orthogonal matrix Q as a product of
min(m,n) elementary reflectors.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
JPVT (input/output) INTEGER array, dimension (N)
On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
to the front of A*P (a leading column); if JPVT(i) = 0,
the i-th column of A is a free column.
On exit, if JPVT(i) = k, then the i-th column of A*P
was the k-th column of A.
TAU (output) COMPLEX*16 array, dimension (min(M,N))
The scalar factors of the elementary reflectors.
WORK (workspace) COMPLEX*16 array, dimension (N)
RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The matrix Q is represented as a product of elementary reflectors
Q = H(1) H(2) . . . H(n)
Each H(i) has the form
H = I - tau * v * v'
where tau is a complex scalar, and v is a complex vector with
v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
The matrix P is represented in jpvt as follows: If
jpvt(j) = i
then the jth column of P is the ith canonical unit vector.
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static doublereal temp, temp2;
static integer i, j, itemp;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *), zswap_(integer *,
doublecomplex *, integer *, doublecomplex *, integer *), zgeqr2_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static integer ma, mn;
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *), zlarfg_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
static doublecomplex aii;
static integer pvt;
#define JPVT(I) jpvt[(I)-1]
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEQPF", &i__1);
return 0;
}
mn = min(*m,*n);
/* Move initial columns up front */
itemp = 1;
i__1 = *n;
for (i = 1; i <= *n; ++i) {
if (JPVT(i) != 0) {
if (i != itemp) {
zswap_(m, &A(1,i), &c__1, &A(1,itemp), &
c__1);
JPVT(i) = JPVT(itemp);
JPVT(itemp) = i;
} else {
JPVT(i) = i;
}
++itemp;
} else {
JPVT(i) = i;
}
/* L10: */
}
--itemp;
/* Compute the QR factorization and update remaining columns */
if (itemp > 0) {
ma = min(itemp,*m);
zgeqr2_(m, &ma, &A(1,1), lda, &TAU(1), &WORK(1), info);
if (ma < *n) {
i__1 = *n - ma;
zunm2r_("Left", "Conjugate transpose", m, &i__1, &ma, &A(1,1)
, lda, &TAU(1), &A(1,ma+1), lda, &WORK(1),
info);
}
}
if (itemp < mn) {
/* Initialize partial column norms. The first n elements of
work store the exact column norms. */
i__1 = *n;
for (i = itemp + 1; i <= *n; ++i) {
i__2 = *m - itemp;
RWORK(i) = dznrm2_(&i__2, &A(itemp+1,i), &c__1);
RWORK(*n + i) = RWORK(i);
/* L20: */
}
/* Compute factorization */
i__1 = mn;
for (i = itemp + 1; i <= mn; ++i) {
/* Determine ith pivot column and swap if necessary */
i__2 = *n - i + 1;
pvt = i - 1 + idamax_(&i__2, &RWORK(i), &c__1);
if (pvt != i) {
zswap_(m, &A(1,pvt), &c__1, &A(1,i), &
c__1);
itemp = JPVT(pvt);
JPVT(pvt) = JPVT(i);
JPVT(i) = itemp;
RWORK(pvt) = RWORK(i);
RWORK(*n + pvt) = RWORK(*n + i);
}
/* Generate elementary reflector H(i) */
i__2 = i + i * a_dim1;
aii.r = A(i,i).r, aii.i = A(i,i).i;
i__2 = *m - i + 1;
/* Computing MIN */
i__3 = i + 1;
zlarfg_(&i__2, &aii, &A(min(i+1,*m),i), &c__1, &TAU(i)
);
i__2 = i + i * a_dim1;
A(i,i).r = aii.r, A(i,i).i = aii.i;
if (i < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */
i__2 = i + i * a_dim1;
aii.r = A(i,i).r, aii.i = A(i,i).i;
i__2 = i + i * a_dim1;
A(i,i).r = 1., A(i,i).i = 0.;
i__2 = *m - i + 1;
i__3 = *n - i;
d_cnjg(&z__1, &TAU(i));
zlarf_("Left", &i__2, &i__3, &A(i,i), &c__1, &z__1,
&A(i,i+1), lda, &WORK(1));
i__2 = i + i * a_dim1;
A(i,i).r = aii.r, A(i,i).i = aii.i;
}
/* Update partial column norms */
i__2 = *n;
for (j = i + 1; j <= *n; ++j) {
if (RWORK(j) != 0.) {
/* Computing 2nd power */
d__1 = z_abs(&A(i,j)) / RWORK(j);
temp = 1. - d__1 * d__1;
temp = max(temp,0.);
/* Computing 2nd power */
d__1 = RWORK(j) / RWORK(*n + j);
temp2 = temp * .05 * (d__1 * d__1) + 1.;
if (temp2 == 1.) {
if (*m - i > 0) {
i__3 = *m - i;
RWORK(j) = dznrm2_(&i__3, &A(i+1,j),
&c__1);
RWORK(*n + j) = RWORK(j);
} else {
RWORK(j) = 0.;
RWORK(*n + j) = 0.;
}
} else {
RWORK(j) *= sqrt(temp);
}
}
/* L30: */
}
/* L40: */
}
}
return 0;
/* End of ZGEQPF */
} /* zgeqpf_ */
/* Subroutine */ int zlaror_slu(char *side, char *init, integer *m, integer *n,
doublecomplex *a, integer *lda, integer *iseed, doublecomplex *x,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1, z__2;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer kbeg, jcol;
static doublereal xabs;
static integer irow, j;
static doublecomplex csign;
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static integer ixfrm;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static integer itype, nxfrm;
static doublereal xnorm;
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
extern int input_error(char *, int *);
static doublereal factor;
extern /* Subroutine */ int zlacgv_slu(integer *, doublecomplex *, integer *)
;
extern /* Double Complex */ VOID zlarnd_slu(doublecomplex *, integer *,
integer *);
extern /* Subroutine */ int zlaset_slu(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static doublecomplex xnorms;
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZLAROR pre- or post-multiplies an M by N matrix A by a random
unitary matrix U, overwriting A. A may optionally be
initialized to the identity matrix before multiplying by U.
U is generated using the method of G.W. Stewart
( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ).
(BLAS-2 version)
Arguments
=========
SIDE - CHARACTER*1
SIDE specifies whether A is multiplied on the left or right
by U.
SIDE = 'L' Multiply A on the left (premultiply) by U
SIDE = 'R' Multiply A on the right (postmultiply) by U*
SIDE = 'C' Multiply A on the left by U and the right by U*
SIDE = 'T' Multiply A on the left by U and the right by U'
Not modified.
INIT - CHARACTER*1
INIT specifies whether or not A should be initialized to
the identity matrix.
INIT = 'I' Initialize A to (a section of) the
identity matrix before applying U.
INIT = 'N' No initialization. Apply U to the
input matrix A.
INIT = 'I' may be used to generate square (i.e., unitary)
or rectangular orthogonal matrices (orthogonality being
in the sense of ZDOTC):
For square matrices, M=N, and SIDE many be either 'L' or
'R'; the rows will be orthogonal to each other, as will the
columns.
For rectangular matrices where M < N, SIDE = 'R' will
produce a dense matrix whose rows will be orthogonal and
whose columns will not, while SIDE = 'L' will produce a
matrix whose rows will be orthogonal, and whose first M
columns will be orthogonal, the remaining columns being
zero.
For matrices where M > N, just use the previous
explaination, interchanging 'L' and 'R' and "rows" and
"columns".
Not modified.
M - INTEGER
Number of rows of A. Not modified.
N - INTEGER
Number of columns of A. Not modified.
A - COMPLEX*16 array, dimension ( LDA, N )
Input and output array. Overwritten by U A ( if SIDE = 'L' )
or by A U ( if SIDE = 'R' )
or by U A U* ( if SIDE = 'C')
or by U A U' ( if SIDE = 'T') on exit.
LDA - INTEGER
Leading dimension of A. Must be at least MAX ( 1, M ).
Not modified.
ISEED - INTEGER array, dimension ( 4 )
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to ZLAROR to continue the same random number
sequence.
Modified.
X - COMPLEX*16 array, dimension ( 3*MAX( M, N ) )
Workspace. Of length:
2*M + N if SIDE = 'L',
2*N + M if SIDE = 'R',
3*N if SIDE = 'C' or 'T'.
Modified.
INFO - INTEGER
An error flag. It is set to:
0 if no error.
1 if ZLARND returned a bad random number (installation
problem)
-1 if SIDE is not L, R, C, or T.
-3 if M is negative.
-4 if N is negative or if SIDE is C or T and N is not equal
to M.
-6 if LDA is less than M.
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--x;
/* Function Body */
if (*n == 0 || *m == 0) {
return 0;
}
itype = 0;
if (strncmp(side, "L", 1)==0) {
itype = 1;
} else if (strncmp(side, "R", 1)==0) {
itype = 2;
} else if (strncmp(side, "C", 1)==0) {
itype = 3;
} else if (strncmp(side, "T", 1)==0) {
itype = 4;
}
/* Check for argument errors. */
*info = 0;
if (itype == 0) {
*info = -1;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0 || itype == 3 && *n != *m) {
*info = -4;
} else if (*lda < *m) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
input_error("ZLAROR", &i__1);
return 0;
}
if (itype == 1) {
nxfrm = *m;
} else {
nxfrm = *n;
}
/* Initialize A to the identity matrix if desired */
if (strncmp(init, "I", 1)==0) {
zlaset_slu("Full", m, n, &c_b1, &c_b2, &a[a_offset], lda);
}
/* If no rotation possible, still multiply by
a random complex number from the circle |x| = 1
2) Compute Rotation by computing Householder
Transformations H(2), H(3), ..., H(n). Note that the
order in which they are computed is irrelevant. */
i__1 = nxfrm;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
x[i__2].r = 0., x[i__2].i = 0.;
/* L10: */
}
i__1 = nxfrm;
for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
kbeg = nxfrm - ixfrm + 1;
/* Generate independent normal( 0, 1 ) random numbers */
i__2 = nxfrm;
for (j = kbeg; j <= i__2; ++j) {
i__3 = j;
zlarnd_slu(&z__1, &c__3, &iseed[1]);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
/* L20: */
}
/* Generate a Householder transformation from the random vector
X */
xnorm = dznrm2_(&ixfrm, &x[kbeg], &c__1);
xabs = z_abs(&x[kbeg]);
if (xabs != 0.) {
i__2 = kbeg;
z__1.r = x[i__2].r / xabs, z__1.i = x[i__2].i / xabs;
csign.r = z__1.r, csign.i = z__1.i;
} else {
csign.r = 1., csign.i = 0.;
}
z__1.r = xnorm * csign.r, z__1.i = xnorm * csign.i;
xnorms.r = z__1.r, xnorms.i = z__1.i;
i__2 = nxfrm + kbeg;
z__1.r = -csign.r, z__1.i = -csign.i;
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
factor = xnorm * (xnorm + xabs);
if (abs(factor) < 1e-20) {
*info = 1;
i__2 = -(*info);
input_error("ZLAROR", &i__2);
return 0;
} else {
factor = 1. / factor;
}
i__2 = kbeg;
i__3 = kbeg;
z__1.r = x[i__3].r + xnorms.r, z__1.i = x[i__3].i + xnorms.i;
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
/* Apply Householder transformation to A */
if (itype == 1 || itype == 3 || itype == 4) {
/* Apply H(k) on the left of A */
zgemv_("C", &ixfrm, n, &c_b2, &a[kbeg + a_dim1], lda, &x[kbeg], &
c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
z__2.r = factor, z__2.i = 0.;
z__1.r = -z__2.r, z__1.i = -z__2.i;
zgerc_(&ixfrm, n, &z__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
c__1, &a[kbeg + a_dim1], lda);
}
if (itype >= 2 && itype <= 4) {
/* Apply H(k)* (or H(k)') on the right of A */
if (itype == 4) {
zlacgv_slu(&ixfrm, &x[kbeg], &c__1);
}
zgemv_("N", m, &ixfrm, &c_b2, &a[kbeg * a_dim1 + 1], lda, &x[kbeg]
, &c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
z__2.r = factor, z__2.i = 0.;
z__1.r = -z__2.r, z__1.i = -z__2.i;
zgerc_(m, &ixfrm, &z__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
c__1, &a[kbeg * a_dim1 + 1], lda);
}
/* L30: */
}
zlarnd_slu(&z__1, &c__3, &iseed[1]);
x[1].r = z__1.r, x[1].i = z__1.i;
xabs = z_abs(&x[1]);
if (xabs != 0.) {
z__1.r = x[1].r / xabs, z__1.i = x[1].i / xabs;
csign.r = z__1.r, csign.i = z__1.i;
} else {
csign.r = 1., csign.i = 0.;
}
i__1 = nxfrm << 1;
x[i__1].r = csign.r, x[i__1].i = csign.i;
/* Scale the matrix A by D. */
if (itype == 1 || itype == 3 || itype == 4) {
i__1 = *m;
for (irow = 1; irow <= i__1; ++irow) {
d_cnjg(&z__1, &x[nxfrm + irow]);
zscal_(n, &z__1, &a[irow + a_dim1], lda);
/* L40: */
}
}
if (itype == 2 || itype == 3) {
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
zscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
/* L50: */
}
}
if (itype == 4) {
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
d_cnjg(&z__1, &x[nxfrm + jcol]);
zscal_(m, &z__1, &a[jcol * a_dim1 + 1], &c__1);
/* L60: */
}
}
return 0;
/* End of ZLAROR */
} /* zlaror_slu */
double cblas_dznrm2( const integer N, const void *X, const integer incX)
{
#define F77_N N
#define F77_incX incX
return dznrm2_( &F77_N, X, &F77_incX );
}
