int main()
{
const unsigned int N = 100;
const unsigned int ONE = 1;
dcomp a[N];
dcomp b[N];
for (unsigned int i = 0; i < N; ++i) {
a[i] = dcomp(i, i / 10.);
b[i] = dcomp(i / 3., i);
}
dcomp exact_result(0., 0.);
for (unsigned int i = 0; i < N; ++i)
exact_result += conj(a[i]) * b[i];
dcomp result(0., 0.);
result = zdotc_(&N, a, &ONE, b, &ONE);
if (std::abs(result - exact_result) < 1e-13 * std::abs(exact_result)) {
std::cout << "SUCCESS" << std::endl;
return 0;
} else {
std::cout << "FAILED" << std::endl;
return 1;
}
}
void cblas_zdotc_sub( const integer N, const void *X, const integer incX,
const void *Y, const integer incY, void *dotc)
{
#define F77_N N
#define F77_incX incX
#define F77_incY incY
zdotc_( dotc, &F77_N, X, &F77_incX, Y, &F77_incY );
}
void
f2c_zdotc(doublecomplex* retval,
integer* N,
doublecomplex* X, integer* incX,
doublecomplex* Y, integer* incY)
{
zdotc_(retval, N, X, incX, Y, incY);
}
doublecomplex zdotc( int n, doublecomplex *x, int incx, doublecomplex *y, int incy)
{
doublecomplex ans;
#if defined( _WIN32 ) || defined( _WIN64 )
ans = zdotc_(&n, x, &incx, y, &incy);
#else
zdotcsub_(&n, x, &incx, y, &incy, &ans);
#endif
return ans;
}
/* Subroutine */ int zunt01_(char *rowcol, integer *m, integer *n,
doublecomplex *u, integer *ldu, doublecomplex *work, integer *lwork,
doublereal *rwork, doublereal *resid)
{
/* System generated locals */
integer u_dim1, u_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer i__, j, k;
doublereal eps;
doublecomplex tmp;
extern logical lsame_(char *, char *);
integer mnmin;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zherk_(char *, char *, integer *, integer *,
doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
integer ldwork;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
char transu[1];
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZUNT01 checks that the matrix U is unitary by computing the ratio */
/* RESID = norm( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R', */
/* or */
/* RESID = norm( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'. */
/* Alternatively, if there isn't sufficient workspace to form */
/* I - U*U' or I - U'*U, the ratio is computed as */
/* RESID = abs( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R', */
/* or */
/* RESID = abs( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'. */
/* where EPS is the machine precision. ROWCOL is used only if m = n; */
/* if m > n, ROWCOL is assumed to be 'C', and if m < n, ROWCOL is */
/* assumed to be 'R'. */
/* Arguments */
/* ========= */
/* ROWCOL (input) CHARACTER */
/* Specifies whether the rows or columns of U should be checked */
/* for orthogonality. Used only if M = N. */
/* = 'R': Check for orthogonal rows of U */
/* = 'C': Check for orthogonal columns of U */
/* M (input) INTEGER */
/* The number of rows of the matrix U. */
/* N (input) INTEGER */
/* The number of columns of the matrix U. */
/* U (input) COMPLEX*16 array, dimension (LDU,N) */
/* The unitary matrix U. U is checked for orthogonal columns */
/* if m > n or if m = n and ROWCOL = 'C'. U is checked for */
/* orthogonal rows if m < n or if m = n and ROWCOL = 'R'. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,M). */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of the array WORK. For best performance, LWORK */
/* should be at least N*N if ROWCOL = 'C' or M*M if */
/* ROWCOL = 'R', but the test will be done even if LWORK is 0. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (min(M,N)) */
/* Used only if LWORK is large enough to use the Level 3 BLAS */
/* code. */
/* RESID (output) DOUBLE PRECISION */
/* RESID = norm( I - U * U' ) / ( n * EPS ), if ROWCOL = 'R', or */
/* RESID = norm( I - U' * U ) / ( m * EPS ), if ROWCOL = 'C'. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--work;
--rwork;
/* Function Body */
*resid = 0.;
/* Quick return if possible */
if (*m <= 0 || *n <= 0) {
return 0;
}
eps = dlamch_("Precision");
if (*m < *n || *m == *n && lsame_(rowcol, "R")) {
*(unsigned char *)transu = 'N';
k = *n;
} else {
*(unsigned char *)transu = 'C';
k = *m;
}
mnmin = min(*m,*n);
if ((mnmin + 1) * mnmin <= *lwork) {
ldwork = mnmin;
} else {
ldwork = 0;
}
if (ldwork > 0) {
/* Compute I - U*U' or I - U'*U. */
zlaset_("Upper", &mnmin, &mnmin, &c_b7, &c_b8, &work[1], &ldwork);
zherk_("Upper", transu, &mnmin, &k, &c_b10, &u[u_offset], ldu, &c_b11,
&work[1], &ldwork);
/* Compute norm( I - U*U' ) / ( K * EPS ) . */
*resid = zlansy_("1", "Upper", &mnmin, &work[1], &ldwork, &rwork[1]);
*resid = *resid / (doublereal) k / eps;
} else if (*(unsigned char *)transu == 'C') {
/* Find the maximum element in abs( I - U'*U ) / ( m * EPS ) */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
if (i__ != j) {
tmp.r = 0., tmp.i = 0.;
} else {
tmp.r = 1., tmp.i = 0.;
}
zdotc_(&z__2, m, &u[i__ * u_dim1 + 1], &c__1, &u[j * u_dim1 +
1], &c__1);
z__1.r = tmp.r - z__2.r, z__1.i = tmp.i - z__2.i;
tmp.r = z__1.r, tmp.i = z__1.i;
/* Computing MAX */
d__3 = *resid, d__4 = (d__1 = tmp.r, abs(d__1)) + (d__2 =
d_imag(&tmp), abs(d__2));
*resid = max(d__3,d__4);
/* L10: */
}
/* L20: */
}
*resid = *resid / (doublereal) (*m) / eps;
} else {
/* Find the maximum element in abs( I - U*U' ) / ( n * EPS ) */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
if (i__ != j) {
tmp.r = 0., tmp.i = 0.;
} else {
tmp.r = 1., tmp.i = 0.;
}
zdotc_(&z__2, n, &u[j + u_dim1], ldu, &u[i__ + u_dim1], ldu);
z__1.r = tmp.r - z__2.r, z__1.i = tmp.i - z__2.i;
tmp.r = z__1.r, tmp.i = z__1.i;
/* Computing MAX */
d__3 = *resid, d__4 = (d__1 = tmp.r, abs(d__1)) + (d__2 =
d_imag(&tmp), abs(d__2));
*resid = max(d__3,d__4);
/* L30: */
}
/* L40: */
}
*resid = *resid / (doublereal) (*n) / eps;
}
return 0;
/* End of ZUNT01 */
} /* zunt01_ */
/* ----------------------------------------------------------------------| */
/* 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 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 zlaic1_(integer *job, integer *j, doublecomplex *x,
doublereal *sest, doublecomplex *w, doublecomplex *gamma, doublereal *
sestpr, doublecomplex *s, doublecomplex *c__)
{
/* System generated locals */
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *), z_sqrt(doublecomplex *,
doublecomplex *);
double sqrt(doublereal);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
doublereal b, t, s1, s2, scl, eps, tmp;
doublecomplex sine;
doublereal test, zeta1, zeta2;
doublecomplex alpha;
doublereal norma;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *);
doublereal absgam, absalp;
doublecomplex cosine;
doublereal absest;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAIC1 applies one step of incremental condition estimation in */
/* its simplest version: */
/* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j */
/* lower triangular matrix L, such that */
/* twonorm(L*x) = sest */
/* Then ZLAIC1 computes sestpr, s, c such that */
/* the vector */
/* [ s*x ] */
/* xhat = [ c ] */
/* is an approximate singular vector of */
/* [ L 0 ] */
/* Lhat = [ w' gamma ] */
/* in the sense that */
/* twonorm(Lhat*xhat) = sestpr. */
/* Depending on JOB, an estimate for the largest or smallest singular */
/* value is computed. */
/* Note that [s c]' and sestpr**2 is an eigenpair of the system */
/* diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ] */
/* [ conjg(gamma) ] */
/* where alpha = conjg(x)'*w. */
/* Arguments */
/* ========= */
/* JOB (input) INTEGER */
/* = 1: an estimate for the largest singular value is computed. */
/* = 2: an estimate for the smallest singular value is computed. */
/* J (input) INTEGER */
/* Length of X and W */
/* X (input) COMPLEX*16 array, dimension (J) */
/* The j-vector x. */
/* SEST (input) DOUBLE PRECISION */
/* Estimated singular value of j by j matrix L */
/* W (input) COMPLEX*16 array, dimension (J) */
/* The j-vector w. */
/* GAMMA (input) COMPLEX*16 */
/* The diagonal element gamma. */
/* SESTPR (output) DOUBLE PRECISION */
/* Estimated singular value of (j+1) by (j+1) matrix Lhat. */
/* S (output) COMPLEX*16 */
/* Sine needed in forming xhat. */
/* C (output) COMPLEX*16 */
/* Cosine needed in forming xhat. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--w;
--x;
/* Function Body */
eps = dlamch_("Epsilon");
zdotc_(&z__1, j, &x[1], &c__1, &w[1], &c__1);
alpha.r = z__1.r, alpha.i = z__1.i;
absalp = z_abs(&alpha);
absgam = z_abs(gamma);
absest = abs(*sest);
if (*job == 1) {
/* Estimating largest singular value */
/* special cases */
if (*sest == 0.) {
s1 = max(absgam,absalp);
if (s1 == 0.) {
s->r = 0., s->i = 0.;
c__->r = 1., c__->i = 0.;
*sestpr = 0.;
} else {
z__1.r = alpha.r / s1, z__1.i = alpha.i / s1;
s->r = z__1.r, s->i = z__1.i;
z__1.r = gamma->r / s1, z__1.i = gamma->i / s1;
c__->r = z__1.r, c__->i = z__1.i;
d_cnjg(&z__4, s);
z__3.r = s->r * z__4.r - s->i * z__4.i, z__3.i = s->r *
z__4.i + s->i * z__4.r;
d_cnjg(&z__6, c__);
z__5.r = c__->r * z__6.r - c__->i * z__6.i, z__5.i = c__->r *
z__6.i + c__->i * z__6.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z_sqrt(&z__1, &z__2);
tmp = z__1.r;
z__1.r = s->r / tmp, z__1.i = s->i / tmp;
s->r = z__1.r, s->i = z__1.i;
z__1.r = c__->r / tmp, z__1.i = c__->i / tmp;
c__->r = z__1.r, c__->i = z__1.i;
*sestpr = s1 * tmp;
}
return 0;
} else if (absgam <= eps * absest) {
s->r = 1., s->i = 0.;
c__->r = 0., c__->i = 0.;
tmp = max(absest,absalp);
s1 = absest / tmp;
s2 = absalp / tmp;
*sestpr = tmp * sqrt(s1 * s1 + s2 * s2);
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
s->r = 1., s->i = 0.;
c__->r = 0., c__->i = 0.;
*sestpr = s2;
} else {
s->r = 0., s->i = 0.;
c__->r = 1., c__->i = 0.;
*sestpr = s1;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
scl = sqrt(tmp * tmp + 1.);
*sestpr = s2 * scl;
z__2.r = alpha.r / s2, z__2.i = alpha.i / s2;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
s->r = z__1.r, s->i = z__1.i;
z__2.r = gamma->r / s2, z__2.i = gamma->i / s2;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
c__->r = z__1.r, c__->i = z__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.);
*sestpr = s1 * scl;
z__2.r = alpha.r / s1, z__2.i = alpha.i / s1;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
s->r = z__1.r, s->i = z__1.i;
z__2.r = gamma->r / s1, z__2.i = gamma->i / s1;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
c__->r = z__1.r, c__->i = z__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
b = (1. - zeta1 * zeta1 - zeta2 * zeta2) * .5;
d__1 = zeta1 * zeta1;
c__->r = d__1, c__->i = 0.;
if (b > 0.) {
d__1 = b * b;
z__4.r = d__1 + c__->r, z__4.i = c__->i;
z_sqrt(&z__3, &z__4);
z__2.r = b + z__3.r, z__2.i = z__3.i;
z_div(&z__1, c__, &z__2);
t = z__1.r;
} else {
d__1 = b * b;
z__3.r = d__1 + c__->r, z__3.i = c__->i;
z_sqrt(&z__2, &z__3);
z__1.r = z__2.r - b, z__1.i = z__2.i;
t = z__1.r;
}
z__3.r = alpha.r / absest, z__3.i = alpha.i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / t, z__1.i = z__2.i / t;
sine.r = z__1.r, sine.i = z__1.i;
z__3.r = gamma->r / absest, z__3.i = gamma->i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
d__1 = t + 1.;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
cosine.r = z__1.r, cosine.i = z__1.i;
d_cnjg(&z__4, &sine);
z__3.r = sine.r * z__4.r - sine.i * z__4.i, z__3.i = sine.r *
z__4.i + sine.i * z__4.r;
d_cnjg(&z__6, &cosine);
z__5.r = cosine.r * z__6.r - cosine.i * z__6.i, z__5.i = cosine.r
* z__6.i + cosine.i * z__6.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z_sqrt(&z__1, &z__2);
tmp = z__1.r;
z__1.r = sine.r / tmp, z__1.i = sine.i / tmp;
s->r = z__1.r, s->i = z__1.i;
z__1.r = cosine.r / tmp, z__1.i = cosine.i / tmp;
c__->r = z__1.r, c__->i = z__1.i;
*sestpr = sqrt(t + 1.) * absest;
return 0;
}
} else if (*job == 2) {
/* Estimating smallest singular value */
/* special cases */
if (*sest == 0.) {
*sestpr = 0.;
if (max(absgam,absalp) == 0.) {
sine.r = 1., sine.i = 0.;
cosine.r = 0., cosine.i = 0.;
} else {
d_cnjg(&z__2, gamma);
z__1.r = -z__2.r, z__1.i = -z__2.i;
sine.r = z__1.r, sine.i = z__1.i;
d_cnjg(&z__1, &alpha);
cosine.r = z__1.r, cosine.i = z__1.i;
}
/* Computing MAX */
d__1 = z_abs(&sine), d__2 = z_abs(&cosine);
s1 = max(d__1,d__2);
z__1.r = sine.r / s1, z__1.i = sine.i / s1;
s->r = z__1.r, s->i = z__1.i;
z__1.r = cosine.r / s1, z__1.i = cosine.i / s1;
c__->r = z__1.r, c__->i = z__1.i;
d_cnjg(&z__4, s);
z__3.r = s->r * z__4.r - s->i * z__4.i, z__3.i = s->r * z__4.i +
s->i * z__4.r;
d_cnjg(&z__6, c__);
z__5.r = c__->r * z__6.r - c__->i * z__6.i, z__5.i = c__->r *
z__6.i + c__->i * z__6.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z_sqrt(&z__1, &z__2);
tmp = z__1.r;
z__1.r = s->r / tmp, z__1.i = s->i / tmp;
s->r = z__1.r, s->i = z__1.i;
z__1.r = c__->r / tmp, z__1.i = c__->i / tmp;
c__->r = z__1.r, c__->i = z__1.i;
return 0;
} else if (absgam <= eps * absest) {
s->r = 0., s->i = 0.;
c__->r = 1., c__->i = 0.;
*sestpr = absgam;
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
s->r = 0., s->i = 0.;
c__->r = 1., c__->i = 0.;
*sestpr = s1;
} else {
s->r = 1., s->i = 0.;
c__->r = 0., c__->i = 0.;
*sestpr = s2;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
scl = sqrt(tmp * tmp + 1.);
*sestpr = absest * (tmp / scl);
d_cnjg(&z__4, gamma);
z__3.r = z__4.r / s2, z__3.i = z__4.i / s2;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
s->r = z__1.r, s->i = z__1.i;
d_cnjg(&z__3, &alpha);
z__2.r = z__3.r / s2, z__2.i = z__3.i / s2;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
c__->r = z__1.r, c__->i = z__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.);
*sestpr = absest / scl;
d_cnjg(&z__4, gamma);
z__3.r = z__4.r / s1, z__3.i = z__4.i / s1;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
s->r = z__1.r, s->i = z__1.i;
d_cnjg(&z__3, &alpha);
z__2.r = z__3.r / s1, z__2.i = z__3.i / s1;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
c__->r = z__1.r, c__->i = z__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
/* Computing MAX */
d__1 = zeta1 * zeta1 + 1. + zeta1 * zeta2, d__2 = zeta1 * zeta2 +
zeta2 * zeta2;
norma = max(d__1,d__2);
/* See if root is closer to zero or to ONE */
test = (zeta1 - zeta2) * 2. * (zeta1 + zeta2) + 1.;
if (test >= 0.) {
/* root is close to zero, compute directly */
b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.) * .5;
d__1 = zeta2 * zeta2;
c__->r = d__1, c__->i = 0.;
d__2 = b * b;
z__2.r = d__2 - c__->r, z__2.i = -c__->i;
d__1 = b + sqrt(z_abs(&z__2));
z__1.r = c__->r / d__1, z__1.i = c__->i / d__1;
t = z__1.r;
z__2.r = alpha.r / absest, z__2.i = alpha.i / absest;
d__1 = 1. - t;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
sine.r = z__1.r, sine.i = z__1.i;
z__3.r = gamma->r / absest, z__3.i = gamma->i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / t, z__1.i = z__2.i / t;
cosine.r = z__1.r, cosine.i = z__1.i;
*sestpr = sqrt(t + eps * 4. * eps * norma) * absest;
} else {
/* root is closer to ONE, shift by that amount */
b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.) * .5;
d__1 = zeta1 * zeta1;
c__->r = d__1, c__->i = 0.;
if (b >= 0.) {
z__2.r = -c__->r, z__2.i = -c__->i;
d__1 = b * b;
z__5.r = d__1 + c__->r, z__5.i = c__->i;
z_sqrt(&z__4, &z__5);
z__3.r = b + z__4.r, z__3.i = z__4.i;
z_div(&z__1, &z__2, &z__3);
t = z__1.r;
} else {
d__1 = b * b;
z__3.r = d__1 + c__->r, z__3.i = c__->i;
z_sqrt(&z__2, &z__3);
z__1.r = b - z__2.r, z__1.i = -z__2.i;
t = z__1.r;
}
z__3.r = alpha.r / absest, z__3.i = alpha.i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / t, z__1.i = z__2.i / t;
sine.r = z__1.r, sine.i = z__1.i;
z__3.r = gamma->r / absest, z__3.i = gamma->i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
d__1 = t + 1.;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
cosine.r = z__1.r, cosine.i = z__1.i;
*sestpr = sqrt(t + 1. + eps * 4. * eps * norma) * absest;
}
d_cnjg(&z__4, &sine);
z__3.r = sine.r * z__4.r - sine.i * z__4.i, z__3.i = sine.r *
z__4.i + sine.i * z__4.r;
d_cnjg(&z__6, &cosine);
z__5.r = cosine.r * z__6.r - cosine.i * z__6.i, z__5.i = cosine.r
* z__6.i + cosine.i * z__6.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z_sqrt(&z__1, &z__2);
tmp = z__1.r;
z__1.r = sine.r / tmp, z__1.i = sine.i / tmp;
s->r = z__1.r, s->i = z__1.i;
z__1.r = cosine.r / tmp, z__1.i = cosine.i / tmp;
c__->r = z__1.r, c__->i = z__1.i;
return 0;
}
}
return 0;
/* End of ZLAIC1 */
} /* zlaic1_ */
/* Subroutine */ int zlatdf_(integer *ijob, integer *n, doublecomplex *z__,
integer *ldz, doublecomplex *rhs, doublereal *rdsum, doublereal *
rdscal, integer *ipiv, integer *jpiv)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
void z_sqrt(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, k;
doublecomplex bm, bp, xm[2], xp[2];
integer info;
doublecomplex temp, work[8];
doublereal scale;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
doublecomplex pmone;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
doublereal rtemp, sminu, rwork[2];
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
doublereal splus;
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zgesc2_(
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
integer *, doublereal *), zgecon_(char *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *);
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *), zlaswp_(integer *, doublecomplex *,
integer *, integer *, integer *, integer *, integer *);
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATDF computes the contribution to the reciprocal Dif-estimate */
/* by solving for x in Z * x = b, where b is chosen such that the norm */
/* of x is as large as possible. It is assumed that LU decomposition */
/* of Z has been computed by ZGETC2. On entry RHS = f holds the */
/* contribution from earlier solved sub-systems, and on return RHS = x. */
/* The factorization of Z returned by ZGETC2 has the form */
/* Z = P * L * U * Q, where P and Q are permutation matrices. L is lower */
/* triangular with unit diagonal elements and U is upper triangular. */
/* Arguments */
/* ========= */
/* IJOB (input) INTEGER */
/* IJOB = 2: First compute an approximative null-vector e */
/* of Z using ZGECON, e is normalized and solve for */
/* Zx = +-e - f with the sign giving the greater value of */
/* 2-norm(x). About 5 times as expensive as Default. */
/* IJOB .ne. 2: Local look ahead strategy where */
/* all entries of the r.h.s. b is choosen as either +1 or */
/* -1. Default. */
/* N (input) INTEGER */
/* The number of columns of the matrix Z. */
/* Z (input) DOUBLE PRECISION array, dimension (LDZ, N) */
/* On entry, the LU part of the factorization of the n-by-n */
/* matrix Z computed by ZGETC2: Z = P * L * U * Q */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDA >= max(1, N). */
/* RHS (input/output) DOUBLE PRECISION array, dimension (N). */
/* On entry, RHS contains contributions from other subsystems. */
/* On exit, RHS contains the solution of the subsystem with */
/* entries according to the value of IJOB (see above). */
/* RDSUM (input/output) DOUBLE PRECISION */
/* On entry, the sum of squares of computed contributions to */
/* the Dif-estimate under computation by ZTGSYL, where the */
/* scaling factor RDSCAL (see below) has been factored out. */
/* On exit, the corresponding sum of squares updated with the */
/* contributions from the current sub-system. */
/* If TRANS = 'T' RDSUM is not touched. */
/* NOTE: RDSUM only makes sense when ZTGSY2 is called by CTGSYL. */
/* RDSCAL (input/output) DOUBLE PRECISION */
/* On entry, scaling factor used to prevent overflow in RDSUM. */
/* On exit, RDSCAL is updated w.r.t. the current contributions */
/* in RDSUM. */
/* If TRANS = 'T', RDSCAL is not touched. */
/* NOTE: RDSCAL only makes sense when ZTGSY2 is called by */
/* ZTGSYL. */
/* IPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= i <= N, row i of the */
/* matrix has been interchanged with row IPIV(i). */
/* JPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= j <= N, column j of the */
/* matrix has been interchanged with column JPIV(j). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* This routine is a further developed implementation of algorithm */
/* BSOLVE in [1] using complete pivoting in the LU factorization. */
/* [1] Bo Kagstrom and Lars Westin, */
/* Generalized Schur Methods with Condition Estimators for */
/* Solving the Generalized Sylvester Equation, IEEE Transactions */
/* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. */
/* [2] Peter Poromaa, */
/* On Efficient and Robust Estimators for the Separation */
/* between two Regular Matrix Pairs with Applications in */
/* Condition Estimation. Report UMINF-95.05, Department of */
/* Computing Science, Umea University, S-901 87 Umea, Sweden, */
/* 1995. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--rhs;
--ipiv;
--jpiv;
/* Function Body */
if (*ijob != 2) {
/* Apply permutations IPIV to RHS */
i__1 = *n - 1;
zlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1);
/* Solve for L-part choosing RHS either to +1 or -1. */
z__1.r = -1., z__1.i = -0.;
pmone.r = z__1.r, pmone.i = z__1.i;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__1.r = rhs[i__2].r + 1., z__1.i = rhs[i__2].i + 0.;
bp.r = z__1.r, bp.i = z__1.i;
i__2 = j;
z__1.r = rhs[i__2].r - 1., z__1.i = rhs[i__2].i - 0.;
bm.r = z__1.r, bm.i = z__1.i;
splus = 1.;
/* Lockahead for L- part RHS(1:N-1) = +-1 */
/* SPLUS and SMIN computed more efficiently than in BSOLVE[1]. */
i__2 = *n - j;
zdotc_(&z__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &z__[j + 1
+ j * z_dim1], &c__1);
splus += z__1.r;
i__2 = *n - j;
zdotc_(&z__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
&c__1);
sminu = z__1.r;
i__2 = j;
splus *= rhs[i__2].r;
if (splus > sminu) {
i__2 = j;
rhs[i__2].r = bp.r, rhs[i__2].i = bp.i;
} else if (sminu > splus) {
i__2 = j;
rhs[i__2].r = bm.r, rhs[i__2].i = bm.i;
} else {
/* In this case the updating sums are equal and we can */
/* choose RHS(J) +1 or -1. The first time this happens we */
/* choose -1, thereafter +1. This is a simple way to get */
/* good estimates of matrices like Byers well-known example */
/* (see [1]). (Not done in BSOLVE.) */
i__2 = j;
i__3 = j;
z__1.r = rhs[i__3].r + pmone.r, z__1.i = rhs[i__3].i +
pmone.i;
rhs[i__2].r = z__1.r, rhs[i__2].i = z__1.i;
pmone.r = 1., pmone.i = 0.;
}
/* Compute the remaining r.h.s. */
i__2 = j;
z__1.r = -rhs[i__2].r, z__1.i = -rhs[i__2].i;
temp.r = z__1.r, temp.i = z__1.i;
i__2 = *n - j;
zaxpy_(&i__2, &temp, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
&c__1);
/* L10: */
}
/* Solve for U- part, lockahead for RHS(N) = +-1. This is not done */
/* In BSOLVE and will hopefully give us a better estimate because */
/* any ill-conditioning of the original matrix is transfered to U */
/* and not to L. U(N, N) is an approximation to sigma_min(LU). */
i__1 = *n - 1;
zcopy_(&i__1, &rhs[1], &c__1, work, &c__1);
i__1 = *n - 1;
i__2 = *n;
z__1.r = rhs[i__2].r + 1., z__1.i = rhs[i__2].i + 0.;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = *n;
i__2 = *n;
z__1.r = rhs[i__2].r - 1., z__1.i = rhs[i__2].i - 0.;
rhs[i__1].r = z__1.r, rhs[i__1].i = z__1.i;
splus = 0.;
sminu = 0.;
for (i__ = *n; i__ >= 1; --i__) {
z_div(&z__1, &c_b1, &z__[i__ + i__ * z_dim1]);
temp.r = z__1.r, temp.i = z__1.i;
i__1 = i__ - 1;
i__2 = i__ - 1;
z__1.r = work[i__2].r * temp.r - work[i__2].i * temp.i, z__1.i =
work[i__2].r * temp.i + work[i__2].i * temp.r;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = i__;
i__2 = i__;
z__1.r = rhs[i__2].r * temp.r - rhs[i__2].i * temp.i, z__1.i =
rhs[i__2].r * temp.i + rhs[i__2].i * temp.r;
rhs[i__1].r = z__1.r, rhs[i__1].i = z__1.i;
i__1 = *n;
for (k = i__ + 1; k <= i__1; ++k) {
i__2 = i__ - 1;
i__3 = i__ - 1;
i__4 = k - 1;
i__5 = i__ + k * z_dim1;
z__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, z__3.i =
z__[i__5].r * temp.i + z__[i__5].i * temp.r;
z__2.r = work[i__4].r * z__3.r - work[i__4].i * z__3.i,
z__2.i = work[i__4].r * z__3.i + work[i__4].i *
z__3.r;
z__1.r = work[i__3].r - z__2.r, z__1.i = work[i__3].i -
z__2.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
i__2 = i__;
i__3 = i__;
i__4 = k;
i__5 = i__ + k * z_dim1;
z__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, z__3.i =
z__[i__5].r * temp.i + z__[i__5].i * temp.r;
z__2.r = rhs[i__4].r * z__3.r - rhs[i__4].i * z__3.i, z__2.i =
rhs[i__4].r * z__3.i + rhs[i__4].i * z__3.r;
z__1.r = rhs[i__3].r - z__2.r, z__1.i = rhs[i__3].i - z__2.i;
rhs[i__2].r = z__1.r, rhs[i__2].i = z__1.i;
/* L20: */
}
splus += z_abs(&work[i__ - 1]);
sminu += z_abs(&rhs[i__]);
/* L30: */
}
if (splus > sminu) {
zcopy_(n, work, &c__1, &rhs[1], &c__1);
}
/* Apply the permutations JPIV to the computed solution (RHS) */
i__1 = *n - 1;
zlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1);
/* Compute the sum of squares */
zlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
return 0;
}
/* ENTRY IJOB = 2 */
/* Compute approximate nullvector XM of Z */
zgecon_("I", n, &z__[z_offset], ldz, &c_b24, &rtemp, work, rwork, &info);
zcopy_(n, &work[*n], &c__1, xm, &c__1);
/* Compute RHS */
i__1 = *n - 1;
zlaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1);
zdotc_(&z__3, n, xm, &c__1, xm, &c__1);
z_sqrt(&z__2, &z__3);
z_div(&z__1, &c_b1, &z__2);
temp.r = z__1.r, temp.i = z__1.i;
zscal_(n, &temp, xm, &c__1);
zcopy_(n, xm, &c__1, xp, &c__1);
zaxpy_(n, &c_b1, &rhs[1], &c__1, xp, &c__1);
z__1.r = -1., z__1.i = -0.;
zaxpy_(n, &z__1, xm, &c__1, &rhs[1], &c__1);
zgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &scale);
zgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &scale);
if (dzasum_(n, xp, &c__1) > dzasum_(n, &rhs[1], &c__1)) {
zcopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Compute the sum of squares */
zlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
return 0;
/* End of ZLATDF */
} /* zlatdf_ */
/* Subroutine */ int zpptri_(char *uplo, integer *n, doublecomplex *ap,
integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
/* Local variables */
static integer j, jc, jj;
static doublereal ajj;
static integer jjn;
extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static logical upper;
extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *,
doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen,
ftnlen), xerbla_(char *, integer *, ftnlen), zdscal_(integer *,
doublereal *, doublecomplex *, integer *), ztptri_(char *, char *,
integer *, doublecomplex *, integer *, ftnlen, ftnlen);
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPPTRI computes the inverse of a complex Hermitian positive definite */
/* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H */
/* computed by ZPPTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangular factor is stored in AP; */
/* = 'L': Lower triangular factor is stored in AP. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* On entry, the triangular factor U or L from the Cholesky */
/* factorization A = U**H*U or A = L*L**H, packed columnwise as */
/* a linear array. The j-th column of U or L is stored in the */
/* array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
/* On exit, the upper or lower triangle of the (Hermitian) */
/* inverse of A, overwriting the input factor U or L. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
/* zero, and the inverse could not be computed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPPTRI", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Invert the triangular Cholesky factor U or L. */
ztptri_(uplo, "Non-unit", n, &ap[1], info, (ftnlen)1, (ftnlen)8);
if (*info > 0) {
return 0;
}
if (upper) {
/* Compute the product inv(U) * inv(U)'. */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jc = jj + 1;
jj += j;
if (j > 1) {
i__2 = j - 1;
zhpr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1], (ftnlen)
5);
}
i__2 = jj;
ajj = ap[i__2].r;
zdscal_(&j, &ajj, &ap[jc], &c__1);
/* L10: */
}
} else {
/* Compute the product inv(L)' * inv(L). */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jjn = jj + *n - j + 1;
i__2 = jj;
i__3 = *n - j + 1;
zdotc_(&z__1, &i__3, &ap[jj], &c__1, &ap[jj], &c__1);
d__1 = z__1.r;
ap[i__2].r = d__1, ap[i__2].i = 0.;
if (j < *n) {
i__2 = *n - j;
ztpmv_("Lower", "Conjugate transpose", "Non-unit", &i__2, &ap[
jjn], &ap[jj + 1], &c__1, (ftnlen)5, (ftnlen)19, (
ftnlen)8);
}
jj = jjn;
/* L20: */
}
}
return 0;
/* End of ZPPTRI */
} /* zpptri_ */
/* Subroutine */ int zhetri_(char *uplo, integer *n, doublecomplex *a,
integer *lda, integer *ipiv, 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;
/* Local variables */
doublereal d__;
integer j, k;
doublereal t, ak;
integer kp;
doublereal akp1;
doublecomplex temp, akkp1;
integer kstep;
logical upper;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZHETRI computes the inverse of a complex Hermitian indefinite matrix */
/* A using the factorization A = U*D*U**H or A = L*D*L**H computed by */
/* ZHETRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the details of the factorization are stored */
/* as an upper or lower triangular matrix. */
/* = 'U': Upper triangular, form is A = U*D*U**H; */
/* = 'L': Lower triangular, form is A = L*D*L**H. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the block diagonal matrix D and the multipliers */
/* used to obtain the factor U or L as computed by ZHETRF. */
/* On exit, if INFO = 0, the (Hermitian) inverse of the original */
/* matrix. If UPLO = 'U', the upper triangular part of the */
/* inverse is formed and the part of A below the diagonal is not */
/* referenced; if UPLO = 'L' the lower triangular part of the */
/* inverse is formed and the part of A above the diagonal is */
/* not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by ZHETRF. */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */
/* inverse could not be computed. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
--work;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHETRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check that the diagonal matrix D is nonsingular. */
if (upper) {
/* Upper triangular storage: examine D from bottom to top */
for (*info = *n; *info >= 1; --(*info)) {
i__1 = *info + *info * a_dim1;
if (ipiv[*info] > 0 && (a[i__1].r == 0. && a[i__1].i == 0.)) {
return 0;
}
}
} else {
/* Lower triangular storage: examine D from top to bottom. */
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
i__2 = *info + *info * a_dim1;
if (ipiv[*info] > 0 && (a[i__2].r == 0. && a[i__2].i == 0.)) {
return 0;
}
}
}
*info = 0;
if (upper) {
/* Compute inv(A) from the factorization A = U*D*U'. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L30:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = 1. / a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zhemv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1,
&c_b2, &a[k * a_dim1 + 1], &c__1);
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
i__3 = k - 1;
zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], &
c__1);
d__1 = z__2.r;
z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
t = z_abs(&a[k + (k + 1) * a_dim1]);
i__1 = k + k * a_dim1;
ak = a[i__1].r / t;
i__1 = k + 1 + (k + 1) * a_dim1;
akp1 = a[i__1].r / t;
i__1 = k + (k + 1) * a_dim1;
z__1.r = a[i__1].r / t, z__1.i = a[i__1].i / t;
akkp1.r = z__1.r, akkp1.i = z__1.i;
d__ = t * (ak * akp1 - 1.);
i__1 = k + k * a_dim1;
d__1 = akp1 / d__;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = k + 1 + (k + 1) * a_dim1;
d__1 = ak / d__;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = k + (k + 1) * a_dim1;
z__2.r = -akkp1.r, z__2.i = -akkp1.i;
z__1.r = z__2.r / d__, z__1.i = z__2.i / d__;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* Compute columns K and K+1 of the inverse. */
if (k > 1) {
i__1 = k - 1;
zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zhemv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1,
&c_b2, &a[k * a_dim1 + 1], &c__1);
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
i__3 = k - 1;
zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], &
c__1);
d__1 = z__2.r;
z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = k + (k + 1) * a_dim1;
i__2 = k + (k + 1) * a_dim1;
i__3 = k - 1;
zdotc_(&z__2, &i__3, &a[k * a_dim1 + 1], &c__1, &a[(k + 1) *
a_dim1 + 1], &c__1);
z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = k - 1;
zcopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &
c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zhemv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1,
&c_b2, &a[(k + 1) * a_dim1 + 1], &c__1);
i__1 = k + 1 + (k + 1) * a_dim1;
i__2 = k + 1 + (k + 1) * a_dim1;
i__3 = k - 1;
zdotc_(&z__2, &i__3, &work[1], &c__1, &a[(k + 1) * a_dim1 + 1]
, &c__1);
d__1 = z__2.r;
z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
kstep = 2;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the leading */
/* submatrix A(1:k+1,1:k+1) */
i__1 = kp - 1;
zswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &
c__1);
i__1 = k - 1;
for (j = kp + 1; j <= i__1; ++j) {
d_cnjg(&z__1, &a[j + k * a_dim1]);
temp.r = z__1.r, temp.i = z__1.i;
i__2 = j + k * a_dim1;
d_cnjg(&z__1, &a[kp + j * a_dim1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = kp + j * a_dim1;
a[i__2].r = temp.r, a[i__2].i = temp.i;
}
i__1 = kp + k * a_dim1;
d_cnjg(&z__1, &a[kp + k * a_dim1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = k + k * a_dim1;
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = k + k * a_dim1;
i__2 = kp + kp * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kp + kp * a_dim1;
a[i__1].r = temp.r, a[i__1].i = temp.i;
if (kstep == 2) {
i__1 = k + (k + 1) * a_dim1;
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = k + (k + 1) * a_dim1;
i__2 = kp + (k + 1) * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kp + (k + 1) * a_dim1;
a[i__1].r = temp.r, a[i__1].i = temp.i;
}
}
k += kstep;
goto L30;
L50:
;
} else {
/* Compute inv(A) from the factorization A = L*D*L'. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L60:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L80;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = 1. / a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zhemv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda,
&work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1);
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
i__3 = *n - k;
zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1],
&c__1);
d__1 = z__2.r;
z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
t = z_abs(&a[k + (k - 1) * a_dim1]);
i__1 = k - 1 + (k - 1) * a_dim1;
ak = a[i__1].r / t;
i__1 = k + k * a_dim1;
akp1 = a[i__1].r / t;
i__1 = k + (k - 1) * a_dim1;
z__1.r = a[i__1].r / t, z__1.i = a[i__1].i / t;
akkp1.r = z__1.r, akkp1.i = z__1.i;
d__ = t * (ak * akp1 - 1.);
i__1 = k - 1 + (k - 1) * a_dim1;
d__1 = akp1 / d__;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = k + k * a_dim1;
d__1 = ak / d__;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = k + (k - 1) * a_dim1;
z__2.r = -akkp1.r, z__2.i = -akkp1.i;
z__1.r = z__2.r / d__, z__1.i = z__2.i / d__;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* Compute columns K-1 and K of the inverse. */
if (k < *n) {
i__1 = *n - k;
zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zhemv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda,
&work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1);
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
i__3 = *n - k;
zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1],
&c__1);
d__1 = z__2.r;
z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = k + (k - 1) * a_dim1;
i__2 = k + (k - 1) * a_dim1;
i__3 = *n - k;
zdotc_(&z__2, &i__3, &a[k + 1 + k * a_dim1], &c__1, &a[k + 1
+ (k - 1) * a_dim1], &c__1);
z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = *n - k;
zcopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], &
c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zhemv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda,
&work[1], &c__1, &c_b2, &a[k + 1 + (k - 1) * a_dim1],
&c__1);
i__1 = k - 1 + (k - 1) * a_dim1;
i__2 = k - 1 + (k - 1) * a_dim1;
i__3 = *n - k;
zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + (k - 1) *
a_dim1], &c__1);
d__1 = z__2.r;
z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
kstep = 2;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the trailing */
/* submatrix A(k-1:n,k-1:n) */
if (kp < *n) {
i__1 = *n - kp;
zswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp *
a_dim1], &c__1);
}
i__1 = kp - 1;
for (j = k + 1; j <= i__1; ++j) {
d_cnjg(&z__1, &a[j + k * a_dim1]);
temp.r = z__1.r, temp.i = z__1.i;
i__2 = j + k * a_dim1;
d_cnjg(&z__1, &a[kp + j * a_dim1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = kp + j * a_dim1;
a[i__2].r = temp.r, a[i__2].i = temp.i;
}
i__1 = kp + k * a_dim1;
d_cnjg(&z__1, &a[kp + k * a_dim1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = k + k * a_dim1;
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = k + k * a_dim1;
i__2 = kp + kp * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kp + kp * a_dim1;
a[i__1].r = temp.r, a[i__1].i = temp.i;
if (kstep == 2) {
i__1 = k + (k - 1) * a_dim1;
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = k + (k - 1) * a_dim1;
i__2 = kp + (k - 1) * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kp + (k - 1) * a_dim1;
a[i__1].r = temp.r, a[i__1].i = temp.i;
}
}
k -= kstep;
goto L60;
L80:
;
}
return 0;
/* End of ZHETRI */
} /* zhetri_ */
/* Subroutine */ int zpotf2_(char *uplo, integer *n, doublecomplex *a,
integer *lda, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer j;
doublereal ajj;
extern logical lsame_(char *, char *);
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 *);
logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
integer *, doublecomplex *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPOTF2 computes the Cholesky factorization of a complex Hermitian */
/* positive definite matrix A. */
/* The factorization has the form */
/* A = U' * U , if UPLO = 'U', or */
/* A = L * L', if UPLO = 'L', */
/* where U is an upper triangular matrix and L is lower triangular. */
/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */
/* n by n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if INFO = 0, the factor U or L from the Cholesky */
/* factorization A = U'*U or A = L*L'. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, the leading minor of order k is not */
/* positive definite, and the factorization could not be */
/* completed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPOTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = j + j * a_dim1;
d__1 = a[i__2].r;
i__3 = j - 1;
zdotc_(&z__2, &i__3, &a[j * a_dim1 + 1], &c__1, &a[j * a_dim1 + 1]
, &c__1);
z__1.r = d__1 - z__2.r, z__1.i = -z__2.i;
ajj = z__1.r;
if (ajj <= 0.) {
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.;
/* Compute elements J+1:N of row J. */
if (j < *n) {
i__2 = j - 1;
zlacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
i__2 = j - 1;
i__3 = *n - j;
z__1.r = -1., z__1.i = -0.;
zgemv_("Transpose", &i__2, &i__3, &z__1, &a[(j + 1) * a_dim1
+ 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b1, &a[j + (
j + 1) * a_dim1], lda);
i__2 = j - 1;
zlacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
i__2 = *n - j;
d__1 = 1. / ajj;
zdscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = j + j * a_dim1;
d__1 = a[i__2].r;
i__3 = j - 1;
zdotc_(&z__2, &i__3, &a[j + a_dim1], lda, &a[j + a_dim1], lda);
z__1.r = d__1 - z__2.r, z__1.i = -z__2.i;
ajj = z__1.r;
if (ajj <= 0.) {
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.;
/* Compute elements J+1:N of column J. */
if (j < *n) {
i__2 = j - 1;
zlacgv_(&i__2, &a[j + a_dim1], lda);
i__2 = *n - j;
i__3 = j - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[j + 1 + a_dim1]
, lda, &a[j + a_dim1], lda, &c_b1, &a[j + 1 + j *
a_dim1], &c__1);
i__2 = j - 1;
zlacgv_(&i__2, &a[j + a_dim1], lda);
i__2 = *n - j;
d__1 = 1. / ajj;
zdscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
}
/* L20: */
}
}
goto L40;
L30:
*info = j;
L40:
return 0;
/* End of ZPOTF2 */
} /* zpotf2_ */
/* 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 zpotf2_(char *uplo, integer *n, doublecomplex *a,
integer *lda, 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
=======
ZPOTF2 computes the Cholesky factorization of a complex Hermitian
positive definite matrix A.
The factorization has the form
A = U' * U , if UPLO = 'U', or
A = L * L', if UPLO = 'L',
where U is an upper triangular matrix and L is lower triangular.
This is the unblocked version of the algorithm, calling Level 2 BLAS.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored.
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the Hermitian matrix A. If UPLO = 'U', the leading
n by n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n by n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, if INFO = 0, the factor U or L from the Cholesky
factorization A = U'*U or A = L*L'.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
> 0: if INFO = k, the leading minor of order k is not
positive definite, and the factorization could not be
completed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
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, z__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer j;
extern logical lsame_(char *, char *);
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 *);
static logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
integer *, doublecomplex *, integer *);
static doublereal ajj;
#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)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPOTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = a_subscr(j, j);
d__1 = a[i__2].r;
i__3 = j - 1;
zdotc_(&z__2, &i__3, &a_ref(1, j), &c__1, &a_ref(1, j), &c__1);
z__1.r = d__1 - z__2.r, z__1.i = -z__2.i;
ajj = z__1.r;
if (ajj <= 0.) {
i__2 = a_subscr(j, j);
a[i__2].r = ajj, a[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = a_subscr(j, j);
a[i__2].r = ajj, a[i__2].i = 0.;
/* Compute elements J+1:N of row J. */
if (j < *n) {
i__2 = j - 1;
zlacgv_(&i__2, &a_ref(1, j), &c__1);
i__2 = j - 1;
i__3 = *n - j;
z__1.r = -1., z__1.i = 0.;
zgemv_("Transpose", &i__2, &i__3, &z__1, &a_ref(1, j + 1),
lda, &a_ref(1, j), &c__1, &c_b1, &a_ref(j, j + 1),
lda);
i__2 = j - 1;
zlacgv_(&i__2, &a_ref(1, j), &c__1);
i__2 = *n - j;
d__1 = 1. / ajj;
zdscal_(&i__2, &d__1, &a_ref(j, j + 1), lda);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = a_subscr(j, j);
d__1 = a[i__2].r;
i__3 = j - 1;
zdotc_(&z__2, &i__3, &a_ref(j, 1), lda, &a_ref(j, 1), lda);
z__1.r = d__1 - z__2.r, z__1.i = -z__2.i;
ajj = z__1.r;
if (ajj <= 0.) {
i__2 = a_subscr(j, j);
a[i__2].r = ajj, a[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = a_subscr(j, j);
a[i__2].r = ajj, a[i__2].i = 0.;
/* Compute elements J+1:N of column J. */
if (j < *n) {
i__2 = j - 1;
zlacgv_(&i__2, &a_ref(j, 1), lda);
i__2 = *n - j;
i__3 = j - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a_ref(j + 1, 1),
lda, &a_ref(j, 1), lda, &c_b1, &a_ref(j + 1, j), &
c__1);
i__2 = j - 1;
zlacgv_(&i__2, &a_ref(j, 1), lda);
i__2 = *n - j;
d__1 = 1. / ajj;
zdscal_(&i__2, &d__1, &a_ref(j + 1, j), &c__1);
}
/* L20: */
}
}
goto L40;
L30:
*info = j;
L40:
return 0;
/* End of ZPOTF2 */
} /* zpotf2_ */
/* Subroutine */ int zlatps_(char *uplo, char *trans, char *diag, char *
normin, integer *n, doublecomplex *ap, doublecomplex *x, doublereal *
scale, doublereal *cnorm, 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
October 31, 1992
Purpose
=======
ZLATPS solves one of the triangular systems
A * x = s*b, A**T * x = s*b, or A**H * x = s*b,
with scaling to prevent overflow, where A is an upper or lower
triangular matrix stored in packed form. Here A**T denotes the
transpose of A, A**H denotes the conjugate transpose of A, x and b
are n-element vectors, and s is a scaling factor, usually less than
or equal to 1, chosen so that the components of x will be less than
the overflow threshold. If the unscaled problem will not cause
overflow, the Level 2 BLAS routine ZTPSV is called. If the matrix A
is singular (A(j,j) = 0 for some j), then s is set to 0 and a
non-trivial solution to A*x = 0 is returned.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
TRANS (input) CHARACTER*1
Specifies the operation applied to A.
= 'N': Solve A * x = s*b (No transpose)
= 'T': Solve A**T * x = s*b (Transpose)
= 'C': Solve A**H * x = s*b (Conjugate transpose)
DIAG (input) CHARACTER*1
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
NORMIN (input) CHARACTER*1
Specifies whether CNORM has been set or not.
= 'Y': CNORM contains the column norms on entry
= 'N': CNORM is not set on entry. On exit, the norms will
be computed and stored in CNORM.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
The upper or lower triangular matrix A, packed columnwise in
a linear array. The j-th column of A is stored in the array
AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
X (input/output) COMPLEX*16 array, dimension (N)
On entry, the right hand side b of the triangular system.
On exit, X is overwritten by the solution vector x.
SCALE (output) DOUBLE PRECISION
The scaling factor s for the triangular system
A * x = s*b, A**T * x = s*b, or A**H * x = s*b.
If SCALE = 0, the matrix A is singular or badly scaled, and
the vector x is an exact or approximate solution to A*x = 0.
CNORM (input or output) DOUBLE PRECISION array, dimension (N)
If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
contains the norm of the off-diagonal part of the j-th column
of A. If TRANS = 'N', CNORM(j) must be greater than or equal
to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
must be greater than or equal to the 1-norm.
If NORMIN = 'N', CNORM is an output argument and CNORM(j)
returns the 1-norm of the offdiagonal part of the j-th column
of A.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
Further Details
======= =======
A rough bound on x is computed; if that is less than overflow, ZTPSV
is called, otherwise, specific code is used which checks for possible
overflow or divide-by-zero at every operation.
A columnwise scheme is used for solving A*x = b. The basic algorithm
if A is lower triangular is
x[1:n] := b[1:n]
for j = 1, ..., n
x(j) := x(j) / A(j,j)
x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
end
Define bounds on the components of x after j iterations of the loop:
M(j) = bound on x[1:j]
G(j) = bound on x[j+1:n]
Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
Then for iteration j+1 we have
M(j+1) <= G(j) / | A(j+1,j+1) |
G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
<= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
where CNORM(j+1) is greater than or equal to the infinity-norm of
column j+1 of A, not counting the diagonal. Hence
G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
1<=i<=j
and
|x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
1<=i< j
Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTPSV if the
reciprocal of the largest M(j), j=1,..,n, is larger than
max(underflow, 1/overflow).
The bound on x(j) is also used to determine when a step in the
columnwise method can be performed without fear of overflow. If
the computed bound is greater than a large constant, x is scaled to
prevent overflow, but if the bound overflows, x is set to 0, x(j) to
1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
Similarly, a row-wise scheme is used to solve A**T *x = b or
A**H *x = b. The basic algorithm for A upper triangular is
for j = 1, ..., n
x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
end
We simultaneously compute two bounds
G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
M(j) = bound on x(i), 1<=i<=j
The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
Then the bound on x(j) is
M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
<= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
1<=i<=j
and we can safely call ZTPSV if 1/M(n) and 1/G(n) are both greater
than max(underflow, 1/overflow).
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b36 = .5;
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer jinc, jlen;
static doublereal xbnd;
static integer imax;
static doublereal tmax;
static doublecomplex tjjs;
static doublereal xmax, grow;
static integer i, j;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
static doublereal tscal;
static doublecomplex uscal;
static integer jlast;
static doublecomplex csumj;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static logical upper;
extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), ztpsv_(
char *, char *, char *, integer *, doublecomplex *, doublecomplex
*, integer *), dlabad_(doublereal *,
doublereal *);
extern doublereal dlamch_(char *);
static integer ip;
static doublereal xj;
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
static doublereal bignum;
extern integer izamax_(integer *, doublecomplex *, integer *);
extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
doublecomplex *);
static logical notran;
static integer jfirst;
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
static doublereal smlnum;
static logical nounit;
static doublereal rec, tjj;
#define CNORM(I) cnorm[(I)-1]
#define X(I) x[(I)-1]
#define AP(I) ap[(I)-1]
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
/* Test the input parameters. */
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans,
"C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (! lsame_(normin, "Y") && ! lsame_(normin, "N"))
{
*info = -4;
} else if (*n < 0) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLATPS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum /= dlamch_("Precision");
bignum = 1. / smlnum;
*scale = 1.;
if (lsame_(normin, "N")) {
/* Compute the 1-norm of each column, not including the diagona
l. */
if (upper) {
/* A is upper triangular. */
ip = 1;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = j - 1;
CNORM(j) = dzasum_(&i__2, &AP(ip), &c__1);
ip += j;
/* L10: */
}
} else {
/* A is lower triangular. */
ip = 1;
i__1 = *n - 1;
for (j = 1; j <= *n-1; ++j) {
i__2 = *n - j;
CNORM(j) = dzasum_(&i__2, &AP(ip + 1), &c__1);
ip = ip + *n - j + 1;
/* L20: */
}
CNORM(*n) = 0.;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is
greater than BIGNUM/2. */
imax = idamax_(n, &CNORM(1), &c__1);
tmax = CNORM(imax);
if (tmax <= bignum * .5) {
tscal = 1.;
} else {
tscal = .5 / (smlnum * tmax);
dscal_(n, &tscal, &CNORM(1), &c__1);
}
/* Compute a bound on the computed solution vector to see if the
Level 2 BLAS routine ZTPSV can be used. */
xmax = 0.;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
/* Computing MAX */
i__2 = j;
d__3 = xmax, d__4 = (d__1 = X(j).r / 2., abs(d__1)) + (d__2 =
d_imag(&X(j)) / 2., abs(d__2));
xmax = max(d__3,d__4);
/* L30: */
}
xbnd = xmax;
if (notran) {
/* Compute the growth in A * x = b. */
if (upper) {
jfirst = *n;
jlast = 1;
jinc = -1;
} else {
jfirst = 1;
jlast = *n;
jinc = 1;
}
if (tscal != 1.) {
grow = 0.;
goto L60;
}
if (nounit) {
/* A is non-unit triangular.
Compute GROW = 1/G(j) and XBND = 1/M(j).
Initially, G(0) = max{x(i), i=1,...,n}. */
grow = .5 / max(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = *n;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L60;
}
i__3 = ip;
tjjs.r = AP(ip).r, tjjs.i = AP(ip).i;
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj >= smlnum) {
/* M(j) = G(j-1) / abs(A(j,j))
Computing MIN */
d__1 = xbnd, d__2 = min(1.,tjj) * grow;
xbnd = min(d__1,d__2);
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
if (tjj + CNORM(j) >= smlnum) {
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,
j)) ) */
grow *= tjj / (tjj + CNORM(j));
} else {
/* G(j) could overflow, set GROW to 0. */
grow = 0.;
}
ip += jinc * jlen;
--jlen;
/* L40: */
}
grow = xbnd;
} else {
/* A is unit triangular.
Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...
,n}.
Computing MIN */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1. / (CNORM(j) + 1.);
/* L50: */
}
}
L60:
;
} else {
/* Compute the growth in A**T * x = b or A**H * x = b. */
if (upper) {
jfirst = 1;
jlast = *n;
jinc = 1;
} else {
jfirst = *n;
jlast = 1;
jinc = -1;
}
if (tscal != 1.) {
grow = 0.;
goto L90;
}
if (nounit) {
/* A is non-unit triangular.
Compute GROW = 1/G(j) and XBND = 1/M(j).
Initially, M(0) = max{x(i), i=1,...,n}. */
grow = .5 / max(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
*/
xj = CNORM(j) + 1.;
/* Computing MIN */
d__1 = grow, d__2 = xbnd / xj;
grow = min(d__1,d__2);
i__3 = ip;
tjjs.r = AP(ip).r, tjjs.i = AP(ip).i;
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj >= smlnum) {
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(
j,j)) */
if (xj > tjj) {
xbnd *= tjj / xj;
}
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
++jlen;
ip += jinc * jlen;
/* L70: */
}
grow = min(grow,xbnd);
} else {
/* A is unit triangular.
Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...
,n}.
Computing MIN */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = CNORM(j) + 1.;
grow /= xj;
/* L80: */
}
}
L90:
;
}
if (grow * tscal > smlnum) {
/* Use the Level 2 BLAS solve if the reciprocal of the bound on
elements of X is not too small. */
ztpsv_(uplo, trans, diag, n, &AP(1), &X(1), &c__1);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5) {
/* Scale X so that its components are less than or equal
to
BIGNUM in absolute value. */
*scale = bignum * .5 / xmax;
zdscal_(n, scale, &X(1), &c__1);
xmax = bignum;
} else {
xmax *= 2.;
}
if (notran) {
/* Solve A * x = b */
ip = jfirst * (jfirst + 1) / 2;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Compute x(j) = b(j) / A(j,j), scaling x if nec
essary. */
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)),
abs(d__2));
if (nounit) {
i__3 = ip;
z__1.r = tscal * AP(ip).r, z__1.i = tscal * AP(ip).i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L110;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1. / xj;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j))
, abs(d__2));
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(
A(j,j))*BIGNUM
to avoid overflow when dividi
ng by A(j,j). */
rec = tjj * bignum / xj;
if (CNORM(j) > 1.) {
/* Scale by 1/CNORM(j) to
avoid overflow when
multiplying x(j) times
column j. */
rec /= CNORM(j);
}
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j))
, abs(d__2));
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) =
1, and
scale = 0, and compute a solution to
A*x = 0. */
i__3 = *n;
for (i = 1; i <= *n; ++i) {
i__4 = i;
X(i).r = 0., X(i).i = 0.;
/* L100: */
}
i__3 = j;
X(j).r = 1., X(j).i = 0.;
xj = 1.;
*scale = 0.;
xmax = 0.;
}
L110:
/* Scale x if necessary to avoid overflow when ad
ding a
multiple of column j of A. */
if (xj > 1.) {
rec = 1. / xj;
if (CNORM(j) > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
}
} else if (xj * CNORM(j) > bignum - xmax) {
/* Scale x by 1/2. */
zdscal_(n, &c_b36, &X(1), &c__1);
*scale *= .5;
}
if (upper) {
if (j > 1) {
/* Compute the update
x(1:j-1) := x(1:j-1) - x(j) *
A(1:j-1,j) */
i__3 = j - 1;
i__4 = j;
z__2.r = -X(j).r, z__2.i = -X(j).i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &AP(ip - j + 1), &c__1, &X(1), &
c__1);
i__3 = j - 1;
i = izamax_(&i__3, &X(1), &c__1);
i__3 = i;
xmax = (d__1 = X(i).r, abs(d__1)) + (d__2 = d_imag(
&X(i)), abs(d__2));
}
ip -= j;
} else {
if (j < *n) {
/* Compute the update
x(j+1:n) := x(j+1:n) - x(j) *
A(j+1:n,j) */
i__3 = *n - j;
i__4 = j;
z__2.r = -X(j).r, z__2.i = -X(j).i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &AP(ip + 1), &c__1, &X(j + 1), &
c__1);
i__3 = *n - j;
i = j + izamax_(&i__3, &X(j + 1), &c__1);
i__3 = i;
xmax = (d__1 = X(i).r, abs(d__1)) + (d__2 = d_imag(
&X(i)), abs(d__2));
}
ip = ip + *n - j + 1;
}
/* L120: */
}
} else if (lsame_(trans, "T")) {
/* Solve A**T * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k).
k<>j */
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (CNORM(j) > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2
*XMAX). */
rec *= .5;
if (nounit) {
i__3 = ip;
z__1.r = tscal * AP(ip).r, z__1.i = tscal * AP(ip)
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling
x if A(j,j) > 1.
Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot
product is 1,
call ZDOTU to perform the dot product.
*/
if (upper) {
i__3 = j - 1;
zdotu_(&z__1, &i__3, &AP(ip - j + 1), &c__1, &X(1), &
c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotu_(&z__1, &i__3, &AP(ip + 1), &c__1, &X(j + 1), &
c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else {
/* Otherwise, use in-line code for the dot
product. */
if (upper) {
i__3 = j - 1;
for (i = 1; i <= j-1; ++i) {
i__4 = ip - j + i;
z__3.r = AP(ip-j+i).r * uscal.r - AP(ip-j+i).i *
uscal.i, z__3.i = AP(ip-j+i).r * uscal.i +
AP(ip-j+i).i * uscal.r;
i__5 = i;
z__2.r = z__3.r * X(i).r - z__3.i * X(i).i,
z__2.i = z__3.r * X(i).i + z__3.i * X(
i).r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L130: */
}
} else if (j < *n) {
i__3 = *n - j;
for (i = 1; i <= *n-j; ++i) {
i__4 = ip + i;
z__3.r = AP(ip+i).r * uscal.r - AP(ip+i).i *
uscal.i, z__3.i = AP(ip+i).r * uscal.i +
AP(ip+i).i * uscal.r;
i__5 = j + i;
z__2.r = z__3.r * X(j+i).r - z__3.i * X(j+i).i,
z__2.i = z__3.r * X(j+i).i + z__3.i * X(
j+i).r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L140: */
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,
j) if 1/A(j,j)
was not used to scale the dotproduct.
*/
i__3 = j;
i__4 = j;
z__1.r = X(j).r - csumj.r, z__1.i = X(j).i -
csumj.i;
X(j).r = z__1.r, X(j).i = z__1.i;
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j))
, abs(d__2));
if (nounit) {
/* Compute x(j) = x(j) / A(j,j), sc
aling if necessary. */
i__3 = ip;
z__1.r = tscal * AP(ip).r, z__1.i = tscal * AP(ip)
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L160;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/ab
s(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)
))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0,
x(j) = 1, and
scale = 0 and compute a solut
ion to A**T *x = 0. */
i__3 = *n;
for (i = 1; i <= *n; ++i) {
i__4 = i;
X(i).r = 0., X(i).i = 0.;
/* L150: */
}
i__3 = j;
X(j).r = 1., X(j).i = 0.;
*scale = 0.;
xmax = 0.;
}
L160:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ i
f the dot
product has already been divided by 1/A
(j,j). */
i__3 = j;
zladiv_(&z__2, &X(j), &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
X(j).r = z__1.r, X(j).i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = X(j).r, abs(d__1)) + (d__2 =
d_imag(&X(j)), abs(d__2));
xmax = max(d__3,d__4);
++jlen;
ip += jinc * jlen;
/* L170: */
}
} else {
/* Solve A**H * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k).
k<>j */
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (CNORM(j) > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2
*XMAX). */
rec *= .5;
if (nounit) {
d_cnjg(&z__2, &AP(ip));
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling
x if A(j,j) > 1.
Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot
product is 1,
call ZDOTC to perform the dot product.
*/
if (upper) {
i__3 = j - 1;
zdotc_(&z__1, &i__3, &AP(ip - j + 1), &c__1, &X(1), &
c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotc_(&z__1, &i__3, &AP(ip + 1), &c__1, &X(j + 1), &
c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else {
/* Otherwise, use in-line code for the dot
product. */
if (upper) {
i__3 = j - 1;
for (i = 1; i <= j-1; ++i) {
d_cnjg(&z__4, &AP(ip - j + i));
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = i;
z__2.r = z__3.r * X(i).r - z__3.i * X(i).i,
z__2.i = z__3.r * X(i).i + z__3.i * X(
i).r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L180: */
}
} else if (j < *n) {
i__3 = *n - j;
for (i = 1; i <= *n-j; ++i) {
d_cnjg(&z__4, &AP(ip + i));
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = j + i;
z__2.r = z__3.r * X(j+i).r - z__3.i * X(j+i).i,
z__2.i = z__3.r * X(j+i).i + z__3.i * X(
j+i).r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L190: */
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,
j) if 1/A(j,j)
was not used to scale the dotproduct.
*/
i__3 = j;
i__4 = j;
z__1.r = X(j).r - csumj.r, z__1.i = X(j).i -
csumj.i;
X(j).r = z__1.r, X(j).i = z__1.i;
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j))
, abs(d__2));
if (nounit) {
/* Compute x(j) = x(j) / A(j,j), sc
aling if necessary. */
d_cnjg(&z__2, &AP(ip));
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L210;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/ab
s(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)
))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0,
x(j) = 1, and
scale = 0 and compute a solut
ion to A**H *x = 0. */
i__3 = *n;
for (i = 1; i <= *n; ++i) {
i__4 = i;
X(i).r = 0., X(i).i = 0.;
/* L200: */
}
i__3 = j;
X(j).r = 1., X(j).i = 0.;
*scale = 0.;
xmax = 0.;
}
L210:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ i
f the dot
product has already been divided by 1/A
(j,j). */
i__3 = j;
zladiv_(&z__2, &X(j), &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
X(j).r = z__1.r, X(j).i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = X(j).r, abs(d__1)) + (d__2 =
d_imag(&X(j)), abs(d__2));
xmax = max(d__3,d__4);
++jlen;
ip += jinc * jlen;
/* L220: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.) {
d__1 = 1. / tscal;
dscal_(n, &d__1, &CNORM(1), &c__1);
}
return 0;
/* End of ZLATPS */
} /* zlatps_ */
/* 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 zhptri_(char *uplo, integer *n, doublecomplex *ap,
integer *ipiv, doublecomplex *work, 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
=======
ZHPTRI computes the inverse of a complex Hermitian indefinite matrix
A in packed storage using the factorization A = U*D*U**H or
A = L*D*L**H computed by ZHPTRF.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the details of the factorization are stored
as an upper or lower triangular matrix.
= 'U': Upper triangular, form is A = U*D*U**H;
= 'L': Lower triangular, form is A = L*D*L**H.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
On entry, the block diagonal matrix D and the multipliers
used to obtain the factor U or L as computed by ZHPTRF,
stored as a packed triangular matrix.
On exit, if INFO = 0, the (Hermitian) inverse of the original
matrix, stored as a packed triangular matrix. The j-th column
of inv(A) is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
if UPLO = 'L',
AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
IPIV (input) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D
as determined by ZHPTRF.
WORK (workspace) COMPLEX*16 array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
inverse could not be computed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b2 = {0.,0.};
static integer c__1 = 1;
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static doublecomplex temp, akkp1;
static doublereal d__;
static integer j, k;
static doublereal t;
extern logical lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer kstep;
static logical upper;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zhpmv_(char *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *), zswap_(
integer *, doublecomplex *, integer *, doublecomplex *, integer *)
;
static doublereal ak;
static integer kc, kp, kx;
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer kcnext, kpc, npp;
static doublereal akp1;
--work;
--ipiv;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHPTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check that the diagonal matrix D is nonsingular. */
if (upper) {
/* Upper triangular storage: examine D from bottom to top */
kp = *n * (*n + 1) / 2;
for (*info = *n; *info >= 1; --(*info)) {
i__1 = kp;
if (ipiv[*info] > 0 && (ap[i__1].r == 0. && ap[i__1].i == 0.)) {
return 0;
}
kp -= *info;
/* L10: */
}
} else {
/* Lower triangular storage: examine D from top to bottom. */
kp = 1;
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
i__2 = kp;
if (ipiv[*info] > 0 && (ap[i__2].r == 0. && ap[i__2].i == 0.)) {
return 0;
}
kp = kp + *n - *info + 1;
/* L20: */
}
}
*info = 0;
if (upper) {
/* Compute inv(A) from the factorization A = U*D*U'.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = 1;
kc = 1;
L30:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
kcnext = kc + k;
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Invert the diagonal block. */
i__1 = kc + k - 1;
i__2 = kc + k - 1;
d__1 = 1. / ap[i__2].r;
ap[i__1].r = d__1, ap[i__1].i = 0.;
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = 0.;
zhpmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, &
ap[kc], &c__1);
i__1 = kc + k - 1;
i__2 = kc + k - 1;
i__3 = k - 1;
zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
d__1 = z__2.r;
z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block
Invert the diagonal block. */
t = z_abs(&ap[kcnext + k - 1]);
i__1 = kc + k - 1;
ak = ap[i__1].r / t;
i__1 = kcnext + k;
akp1 = ap[i__1].r / t;
i__1 = kcnext + k - 1;
z__1.r = ap[i__1].r / t, z__1.i = ap[i__1].i / t;
akkp1.r = z__1.r, akkp1.i = z__1.i;
d__ = t * (ak * akp1 - 1.);
i__1 = kc + k - 1;
d__1 = akp1 / d__;
ap[i__1].r = d__1, ap[i__1].i = 0.;
i__1 = kcnext + k;
d__1 = ak / d__;
ap[i__1].r = d__1, ap[i__1].i = 0.;
i__1 = kcnext + k - 1;
z__2.r = -akkp1.r, z__2.i = -akkp1.i;
z__1.r = z__2.r / d__, z__1.i = z__2.i / d__;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
/* Compute columns K and K+1 of the inverse. */
if (k > 1) {
i__1 = k - 1;
zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = 0.;
zhpmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, &
ap[kc], &c__1);
i__1 = kc + k - 1;
i__2 = kc + k - 1;
i__3 = k - 1;
zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
d__1 = z__2.r;
z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = kcnext + k - 1;
i__2 = kcnext + k - 1;
i__3 = k - 1;
zdotc_(&z__2, &i__3, &ap[kc], &c__1, &ap[kcnext], &c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = k - 1;
zcopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = 0.;
zhpmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, &
ap[kcnext], &c__1);
i__1 = kcnext + k;
i__2 = kcnext + k;
i__3 = k - 1;
zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext], &c__1);
d__1 = z__2.r;
z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
}
kstep = 2;
kcnext = kcnext + k + 1;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the leading
submatrix A(1:k+1,1:k+1) */
kpc = (kp - 1) * kp / 2 + 1;
i__1 = kp - 1;
zswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1);
kx = kpc + kp - 1;
i__1 = k - 1;
for (j = kp + 1; j <= i__1; ++j) {
kx = kx + j - 1;
d_cnjg(&z__1, &ap[kc + j - 1]);
temp.r = z__1.r, temp.i = z__1.i;
i__2 = kc + j - 1;
d_cnjg(&z__1, &ap[kx]);
ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
i__2 = kx;
ap[i__2].r = temp.r, ap[i__2].i = temp.i;
/* L40: */
}
i__1 = kc + kp - 1;
d_cnjg(&z__1, &ap[kc + kp - 1]);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = kc + k - 1;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc + k - 1;
i__2 = kpc + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kpc + kp - 1;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
if (kstep == 2) {
i__1 = kc + k + k - 1;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc + k + k - 1;
i__2 = kc + k + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kc + k + kp - 1;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
}
}
k += kstep;
kc = kcnext;
goto L30;
L50:
;
} else {
/* Compute inv(A) from the factorization A = L*D*L'.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
npp = *n * (*n + 1) / 2;
k = *n;
kc = npp;
L60:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L80;
}
kcnext = kc - (*n - k + 2);
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Invert the diagonal block. */
i__1 = kc;
i__2 = kc;
d__1 = 1. / ap[i__2].r;
ap[i__1].r = d__1, ap[i__1].i = 0.;
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = 0.;
zhpmv_(uplo, &i__1, &z__1, &ap[kc + *n - k + 1], &work[1], &
c__1, &c_b2, &ap[kc + 1], &c__1);
i__1 = kc;
i__2 = kc;
i__3 = *n - k;
zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
d__1 = z__2.r;
z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block
Invert the diagonal block. */
t = z_abs(&ap[kcnext + 1]);
i__1 = kcnext;
ak = ap[i__1].r / t;
i__1 = kc;
akp1 = ap[i__1].r / t;
i__1 = kcnext + 1;
z__1.r = ap[i__1].r / t, z__1.i = ap[i__1].i / t;
akkp1.r = z__1.r, akkp1.i = z__1.i;
d__ = t * (ak * akp1 - 1.);
i__1 = kcnext;
d__1 = akp1 / d__;
ap[i__1].r = d__1, ap[i__1].i = 0.;
i__1 = kc;
d__1 = ak / d__;
ap[i__1].r = d__1, ap[i__1].i = 0.;
i__1 = kcnext + 1;
z__2.r = -akkp1.r, z__2.i = -akkp1.i;
z__1.r = z__2.r / d__, z__1.i = z__2.i / d__;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
/* Compute columns K-1 and K of the inverse. */
if (k < *n) {
i__1 = *n - k;
zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = 0.;
zhpmv_(uplo, &i__1, &z__1, &ap[kc + (*n - k + 1)], &work[1], &
c__1, &c_b2, &ap[kc + 1], &c__1);
i__1 = kc;
i__2 = kc;
i__3 = *n - k;
zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
d__1 = z__2.r;
z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = kcnext + 1;
i__2 = kcnext + 1;
i__3 = *n - k;
zdotc_(&z__2, &i__3, &ap[kc + 1], &c__1, &ap[kcnext + 2], &
c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = *n - k;
zcopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = 0.;
zhpmv_(uplo, &i__1, &z__1, &ap[kc + (*n - k + 1)], &work[1], &
c__1, &c_b2, &ap[kcnext + 2], &c__1);
i__1 = kcnext;
i__2 = kcnext;
i__3 = *n - k;
zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext + 2], &c__1);
d__1 = z__2.r;
z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
}
kstep = 2;
kcnext -= *n - k + 3;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the trailing
submatrix A(k-1:n,k-1:n) */
kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1;
if (kp < *n) {
i__1 = *n - kp;
zswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], &
c__1);
}
kx = kc + kp - k;
i__1 = kp - 1;
for (j = k + 1; j <= i__1; ++j) {
kx = kx + *n - j + 1;
d_cnjg(&z__1, &ap[kc + j - k]);
temp.r = z__1.r, temp.i = z__1.i;
i__2 = kc + j - k;
d_cnjg(&z__1, &ap[kx]);
ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
i__2 = kx;
ap[i__2].r = temp.r, ap[i__2].i = temp.i;
/* L70: */
}
i__1 = kc + kp - k;
d_cnjg(&z__1, &ap[kc + kp - k]);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = kc;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc;
i__2 = kpc;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kpc;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
if (kstep == 2) {
i__1 = kc - *n + k - 1;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc - *n + k - 1;
i__2 = kc - *n + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kc - *n + kp - 1;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
}
}
k -= kstep;
kc = kcnext;
goto L60;
L80:
;
}
return 0;
/* End of ZHPTRI */
} /* zhptri_ */
/* Subroutine */ int zlatrd_(char *uplo, integer *n, integer *nb,
doublecomplex *a, integer *lda, doublereal *e, doublecomplex *tau,
doublecomplex *w, integer *ldw)
{
/* -- 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
=======
ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to
Hermitian tridiagonal form by a unitary similarity
transformation Q' * A * Q, and returns the matrices V and W which are
needed to apply the transformation to the unreduced part of A.
If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a
matrix, of which the upper triangle is supplied;
if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a
matrix, of which the lower triangle is supplied.
This is an auxiliary routine called by ZHETRD.
Arguments
=========
UPLO (input) CHARACTER
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A.
NB (input) INTEGER
The number of rows and columns to be reduced.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the Hermitian matrix A. If UPLO = 'U', the leading
n-by-n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n-by-n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit:
if UPLO = 'U', the last NB columns have been reduced to
tridiagonal form, with the diagonal elements overwriting
the diagonal elements of A; the elements above the diagonal
with the array TAU, represent the unitary matrix Q as a
product of elementary reflectors;
if UPLO = 'L', the first NB columns have been reduced to
tridiagonal form, with the diagonal elements overwriting
the diagonal elements of A; the elements below the diagonal
with the array TAU, represent the unitary matrix Q as a
product of elementary reflectors.
See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
E (output) DOUBLE PRECISION array, dimension (N-1)
If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
elements of the last NB columns of the reduced matrix;
if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
the first NB columns of the reduced matrix.
TAU (output) COMPLEX*16 array, dimension (N-1)
The scalar factors of the elementary reflectors, stored in
TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
See Further Details.
W (output) COMPLEX*16 array, dimension (LDW,NB)
The n-by-nb matrix W required to update the unreduced part
of A.
LDW (input) INTEGER
The leading dimension of the array W. LDW >= max(1,N).
Further Details
===============
If UPLO = 'U', the matrix Q is represented as a product of elementary
reflectors
Q = H(n) H(n-1) . . . H(n-nb+1).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a complex scalar, and v is a complex vector with
v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
and tau in TAU(i-1).
If UPLO = 'L', the matrix Q is represented as a product of elementary
reflectors
Q = H(1) H(2) . . . H(nb).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a complex scalar, and v is a complex vector with
v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
and tau in TAU(i).
The elements of the vectors v together form the n-by-nb matrix V
which is needed, with W, to apply the transformation to the unreduced
part of the matrix, using a Hermitian rank-2k update of the form:
A := A - V*W' - W*V'.
The contents of A on exit are illustrated by the following examples
with n = 5 and nb = 2:
if UPLO = 'U': if UPLO = 'L':
( a a a v4 v5 ) ( d )
( a a v4 v5 ) ( 1 d )
( a 1 v5 ) ( v1 1 a )
( d 1 ) ( v1 v2 a a )
( d ) ( v1 v2 a a a )
where d denotes a diagonal element of the reduced matrix, a denotes
an element of the original matrix that is unchanged, and vi denotes
an element of the vector defining H(i).
=====================================================================
Quick return if possible
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
static integer i__;
static doublecomplex alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int 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 *);
static integer iw;
extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *), zlacgv_(integer *,
doublecomplex *, integer *);
#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 w_subscr(a_1,a_2) (a_2)*w_dim1 + a_1
#define w_ref(a_1,a_2) w[w_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--e;
--tau;
w_dim1 = *ldw;
w_offset = 1 + w_dim1 * 1;
w -= w_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U")) {
/* Reduce last NB columns of upper triangle */
i__1 = *n - *nb + 1;
for (i__ = *n; i__ >= i__1; --i__) {
iw = i__ - *n + *nb;
if (i__ < *n) {
/* Update A(1:i,i) */
i__2 = a_subscr(i__, i__);
i__3 = a_subscr(i__, i__);
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = *n - i__;
zlacgv_(&i__2, &w_ref(i__, iw + 1), ldw);
i__2 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__, &i__2, &z__1, &a_ref(1, i__ + 1),
lda, &w_ref(i__, iw + 1), ldw, &c_b2, &a_ref(1, i__),
&c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &w_ref(i__, iw + 1), ldw);
i__2 = *n - i__;
zlacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
i__2 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__, &i__2, &z__1, &w_ref(1, iw + 1),
ldw, &a_ref(i__, i__ + 1), lda, &c_b2, &a_ref(1, i__),
&c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
i__2 = a_subscr(i__, i__);
i__3 = a_subscr(i__, i__);
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
}
if (i__ > 1) {
/* Generate elementary reflector H(i) to annihilate
A(1:i-2,i) */
i__2 = a_subscr(i__ - 1, i__);
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = i__ - 1;
zlarfg_(&i__2, &alpha, &a_ref(1, i__), &c__1, &tau[i__ - 1]);
i__2 = i__ - 1;
e[i__2] = alpha.r;
i__2 = a_subscr(i__ - 1, i__);
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute W(1:i-1,i) */
i__2 = i__ - 1;
zhemv_("Upper", &i__2, &c_b2, &a[a_offset], lda, &a_ref(1,
i__), &c__1, &c_b1, &w_ref(1, iw), &c__1);
if (i__ < *n) {
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w_ref(
1, iw + 1), ldw, &a_ref(1, i__), &c__1, &c_b1, &
w_ref(i__ + 1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a_ref(1, i__
+ 1), lda, &w_ref(i__ + 1, iw), &c__1, &c_b2, &
w_ref(1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a_ref(
1, i__ + 1), lda, &a_ref(1, i__), &c__1, &c_b1, &
w_ref(i__ + 1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w_ref(1, iw
+ 1), ldw, &w_ref(i__ + 1, iw), &c__1, &c_b2, &
w_ref(1, iw), &c__1);
}
i__2 = i__ - 1;
zscal_(&i__2, &tau[i__ - 1], &w_ref(1, iw), &c__1);
z__3.r = -.5, z__3.i = 0.;
i__2 = i__ - 1;
z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i =
z__3.r * tau[i__2].i + z__3.i * tau[i__2].r;
i__3 = i__ - 1;
zdotc_(&z__4, &i__3, &w_ref(1, iw), &c__1, &a_ref(1, i__), &
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 = i__ - 1;
zaxpy_(&i__2, &alpha, &a_ref(1, i__), &c__1, &w_ref(1, iw), &
c__1);
}
/* L10: */
}
} else {
/* Reduce first NB columns of lower triangle */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:n,i) */
i__2 = a_subscr(i__, i__);
i__3 = a_subscr(i__, i__);
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = i__ - 1;
zlacgv_(&i__2, &w_ref(i__, 1), ldw);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a_ref(i__, 1), lda, &
w_ref(i__, 1), ldw, &c_b2, &a_ref(i__, i__), &c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &w_ref(i__, 1), ldw);
i__2 = i__ - 1;
zlacgv_(&i__2, &a_ref(i__, 1), lda);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w_ref(i__, 1), ldw, &
a_ref(i__, 1), lda, &c_b2, &a_ref(i__, i__), &c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &a_ref(i__, 1), lda);
i__2 = a_subscr(i__, i__);
i__3 = a_subscr(i__, i__);
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
if (i__ < *n) {
/* Generate elementary reflector H(i) to annihilate
A(i+2:n,i) */
i__2 = a_subscr(i__ + 1, i__);
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
/* Computing MIN */
i__2 = i__ + 2;
i__3 = *n - i__;
zlarfg_(&i__3, &alpha, &a_ref(min(i__2,*n), i__), &c__1, &tau[
i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = a_subscr(i__ + 1, i__);
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute W(i+1:n,i) */
i__2 = *n - i__;
zhemv_("Lower", &i__2, &c_b2, &a_ref(i__ + 1, i__ + 1), lda, &
a_ref(i__ + 1, i__), &c__1, &c_b1, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w_ref(i__
+ 1, 1), ldw, &a_ref(i__ + 1, i__), &c__1, &c_b1, &
w_ref(1, i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a_ref(i__ + 1, 1)
, lda, &w_ref(1, i__), &c__1, &c_b2, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a_ref(i__
+ 1, 1), lda, &a_ref(i__ + 1, i__), &c__1, &c_b1, &
w_ref(1, i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w_ref(i__ + 1, 1)
, ldw, &w_ref(1, i__), &c__1, &c_b2, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
zscal_(&i__2, &tau[i__], &w_ref(i__ + 1, i__), &c__1);
z__3.r = -.5, z__3.i = 0.;
i__2 = i__;
z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i =
z__3.r * tau[i__2].i + z__3.i * tau[i__2].r;
i__3 = *n - i__;
zdotc_(&z__4, &i__3, &w_ref(i__ + 1, i__), &c__1, &a_ref(i__
+ 1, i__), &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 - i__;
zaxpy_(&i__2, &alpha, &a_ref(i__ + 1, i__), &c__1, &w_ref(i__
+ 1, i__), &c__1);
}
/* L20: */
}
}
return 0;
/* End of ZLATRD */
} /* zlatrd_ */
/* 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 zlauu2_(char *uplo, integer *n, doublecomplex *a,
integer *lda, integer *info)
{
/* -- 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
=======
ZLAUU2 computes the product U * U' or L' * L, where the triangular
factor U or L is stored in the upper or lower triangular part of
the array A.
If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
overwriting the factor U in A.
If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
overwriting the factor L in A.
This is the unblocked form of the algorithm, calling Level 2 BLAS.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the triangular factor stored in the array A
is upper or lower triangular:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the triangular factor U or L. N >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the triangular factor U or L.
On exit, if UPLO = 'U', the upper triangle of A is
overwritten with the upper triangle of the product U * U';
if UPLO = 'L', the lower triangle of A is overwritten with
the lower triangle of the product L' * L.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
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;
/* Local variables */
static integer i__;
extern logical lsame_(char *, char *);
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 *);
static logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
integer *, doublecomplex *, integer *);
static doublereal aii;
#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)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLAUU2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the product U * U'. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = a_subscr(i__, i__);
aii = a[i__2].r;
if (i__ < *n) {
i__2 = a_subscr(i__, i__);
i__3 = *n - i__;
zdotc_(&z__1, &i__3, &a_ref(i__, i__ + 1), lda, &a_ref(i__,
i__ + 1), lda);
d__1 = aii * aii + z__1.r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = *n - i__;
zlacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = aii, z__1.i = 0.;
zgemv_("No transpose", &i__2, &i__3, &c_b1, &a_ref(1, i__ + 1)
, lda, &a_ref(i__, i__ + 1), lda, &z__1, &a_ref(1,
i__), &c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
} else {
zdscal_(&i__, &aii, &a_ref(1, i__), &c__1);
}
/* L10: */
}
} else {
/* Compute the product L' * L. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = a_subscr(i__, i__);
aii = a[i__2].r;
if (i__ < *n) {
i__2 = a_subscr(i__, i__);
i__3 = *n - i__;
zdotc_(&z__1, &i__3, &a_ref(i__ + 1, i__), &c__1, &a_ref(i__
+ 1, i__), &c__1);
d__1 = aii * aii + z__1.r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = i__ - 1;
zlacgv_(&i__2, &a_ref(i__, 1), lda);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = aii, z__1.i = 0.;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b1, &a_ref(i__
+ 1, 1), lda, &a_ref(i__ + 1, i__), &c__1, &z__1, &
a_ref(i__, 1), lda);
i__2 = i__ - 1;
zlacgv_(&i__2, &a_ref(i__, 1), lda);
} else {
zdscal_(&i__, &aii, &a_ref(i__, 1), lda);
}
/* L20: */
}
}
return 0;
/* End of ZLAUU2 */
} /* zlauu2_ */
/* Subroutine */ int zgbcon_(char *norm, integer *n, integer *kl, integer *ku,
doublecomplex *ab, integer *ldab, integer *ipiv, doublereal *anorm,
doublereal *rcond, doublecomplex *work, doublereal *rwork, integer *
info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer j;
doublecomplex t;
integer kd, lm, jp, ix, kase, kase1;
doublereal scale;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
logical lnoti;
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zlacn2_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
logical onenrm;
extern /* Subroutine */ int zlatbs_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *), zdrscl_(integer *, doublereal *, doublecomplex *,
integer *);
char normin[1];
doublereal smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGBCON estimates the reciprocal of the condition number of a complex */
/* general band matrix A, in either the 1-norm or the infinity-norm, */
/* using the LU factorization computed by ZGBTRF. */
/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
/* condition number is computed as */
/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies whether the 1-norm condition number or the */
/* infinity-norm condition number is required: */
/* = '1' or 'O': 1-norm; */
/* = 'I': Infinity-norm. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
/* Details of the LU factorization of the band matrix A, as */
/* computed by ZGBTRF. U is stored as an upper triangular band */
/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
/* the multipliers used during the factorization are stored in */
/* rows KL+KU+2 to 2*KL+KU+1. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices; for 1 <= i <= N, row i of the matrix was */
/* interchanged with row IPIV(i). */
/* ANORM (input) DOUBLE PRECISION */
/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
/* If NORM = 'I', the infinity-norm of the original matrix A. */
/* RCOND (output) DOUBLE PRECISION */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--ipiv;
--work;
--rwork;
/* Function Body */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*ldab < (*kl << 1) + *ku + 1) {
*info = -6;
} else if (*anorm < 0.) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGBCON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.;
if (*n == 0) {
*rcond = 1.;
return 0;
} else if (*anorm == 0.) {
return 0;
}
smlnum = dlamch_("Safe minimum");
/* Estimate the norm of inv(A). */
ainvnm = 0.;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kd = *kl + *ku + 1;
lnoti = *kl > 0;
kase = 0;
L10:
zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(L). */
if (lnoti) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kl, i__3 = *n - j;
lm = min(i__2,i__3);
jp = ipiv[j];
i__2 = jp;
t.r = work[i__2].r, t.i = work[i__2].i;
if (jp != j) {
i__2 = jp;
i__3 = j;
work[i__2].r = work[i__3].r, work[i__2].i = work[i__3]
.i;
i__2 = j;
work[i__2].r = t.r, work[i__2].i = t.i;
}
z__1.r = -t.r, z__1.i = -t.i;
zaxpy_(&lm, &z__1, &ab[kd + 1 + j * ab_dim1], &c__1, &
work[j + 1], &c__1);
/* L20: */
}
}
/* Multiply by inv(U). */
i__1 = *kl + *ku;
zlatbs_("Upper", "No transpose", "Non-unit", normin, n, &i__1, &
ab[ab_offset], ldab, &work[1], &scale, &rwork[1], info);
} else {
/* Multiply by inv(U'). */
i__1 = *kl + *ku;
zlatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &
i__1, &ab[ab_offset], ldab, &work[1], &scale, &rwork[1],
info);
/* Multiply by inv(L'). */
if (lnoti) {
for (j = *n - 1; j >= 1; --j) {
/* Computing MIN */
i__1 = *kl, i__2 = *n - j;
lm = min(i__1,i__2);
i__1 = j;
i__2 = j;
zdotc_(&z__2, &lm, &ab[kd + 1 + j * ab_dim1], &c__1, &
work[j + 1], &c__1);
z__1.r = work[i__2].r - z__2.r, z__1.i = work[i__2].i -
z__2.i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
jp = ipiv[j];
if (jp != j) {
i__1 = jp;
t.r = work[i__1].r, t.i = work[i__1].i;
i__1 = jp;
i__2 = j;
work[i__1].r = work[i__2].r, work[i__1].i = work[i__2]
.i;
i__1 = j;
work[i__1].r = t.r, work[i__1].i = t.i;
}
/* L30: */
}
}
}
/* Divide X by 1/SCALE if doing so will not cause overflow. */
*(unsigned char *)normin = 'Y';
if (scale != 1.) {
ix = izamax_(n, &work[1], &c__1);
i__1 = ix;
if (scale < ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
work[ix]), abs(d__2))) * smlnum || scale == 0.) {
goto L40;
}
zdrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / ainvnm / *anorm;
}
L40:
return 0;
/* End of ZGBCON */
} /* zgbcon_ */
/* Subroutine */ int zppt01_(char *uplo, integer *n, doublecomplex *a,
doublecomplex *afac, doublereal *rwork, doublereal *resid)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer i__, k, kc;
doublecomplex tc;
doublereal tr, eps;
extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *);
extern logical lsame_(char *, char *);
doublereal anorm;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *,
doublecomplex *, doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlanhp_(char *, char *,
integer *, doublecomplex *, doublereal *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPPT01 reconstructs a Hermitian positive definite packed matrix A */
/* from its L*L' or U'*U factorization and computes the residual */
/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon, L' is the conjugate transpose of */
/* L, and U' is the conjugate transpose of U. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* The original Hermitian matrix A, stored as a packed */
/* triangular matrix. */
/* AFAC (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* On entry, the factor L or U from the L*L' or U'*U */
/* factorization of A, stored as a packed triangular matrix. */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference L*L' - A (or U'*U - A). */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESID (output) DOUBLE PRECISION */
/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 */
/* Parameter adjustments */
--rwork;
--afac;
--a;
/* Function Body */
if (*n <= 0) {
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
anorm = zlanhp_("1", uplo, n, &a[1], &rwork[1]);
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Check the imaginary parts of the diagonal elements and return with */
/* an error code if any are nonzero. */
kc = 1;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (d_imag(&afac[kc]) != 0.) {
*resid = 1. / eps;
return 0;
}
kc = kc + k + 1;
/* L10: */
}
} else {
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (d_imag(&afac[kc]) != 0.) {
*resid = 1. / eps;
return 0;
}
kc = kc + *n - k + 1;
/* L20: */
}
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
kc = *n * (*n - 1) / 2 + 1;
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
zdotc_(&z__1, &k, &afac[kc], &c__1, &afac[kc], &c__1);
tr = z__1.r;
i__1 = kc + k - 1;
afac[i__1].r = tr, afac[i__1].i = 0.;
/* Compute the rest of column K. */
if (k > 1) {
i__1 = k - 1;
ztpmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[1], &
afac[kc], &c__1);
kc -= k - 1;
}
/* L30: */
}
/* Compute the difference L*L' - A */
kc = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = kc + i__ - 1;
i__4 = kc + i__ - 1;
i__5 = kc + i__ - 1;
z__1.r = afac[i__4].r - a[i__5].r, z__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = z__1.r, afac[i__3].i = z__1.i;
/* L40: */
}
i__2 = kc + k - 1;
i__3 = kc + k - 1;
i__4 = kc + k - 1;
d__1 = a[i__4].r;
z__1.r = afac[i__3].r - d__1, z__1.i = afac[i__3].i;
afac[i__2].r = z__1.r, afac[i__2].i = z__1.i;
kc += k;
/* L50: */
}
/* Compute the product L*L', overwriting L. */
} else {
kc = *n * (*n + 1) / 2;
for (k = *n; k >= 1; --k) {
/* Add a multiple of column K of the factor L to each of */
/* columns K+1 through N. */
if (k < *n) {
i__1 = *n - k;
zhpr_("Lower", &i__1, &c_b19, &afac[kc + 1], &c__1, &afac[kc
+ *n - k + 1]);
}
/* Scale column K by the diagonal element. */
i__1 = kc;
tc.r = afac[i__1].r, tc.i = afac[i__1].i;
i__1 = *n - k + 1;
zscal_(&i__1, &tc, &afac[kc], &c__1);
kc -= *n - k + 2;
/* L60: */
}
/* Compute the difference U'*U - A */
kc = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = kc;
i__3 = kc;
i__4 = kc;
d__1 = a[i__4].r;
z__1.r = afac[i__3].r - d__1, z__1.i = afac[i__3].i;
afac[i__2].r = z__1.r, afac[i__2].i = z__1.i;
i__2 = *n;
for (i__ = k + 1; i__ <= i__2; ++i__) {
i__3 = kc + i__ - k;
i__4 = kc + i__ - k;
i__5 = kc + i__ - k;
z__1.r = afac[i__4].r - a[i__5].r, z__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = z__1.r, afac[i__3].i = z__1.i;
/* L70: */
}
kc = kc + *n - k + 1;
/* L80: */
}
}
/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
*resid = zlanhp_("1", uplo, n, &afac[1], &rwork[1]);
*resid = *resid / (doublereal) (*n) / anorm / eps;
return 0;
/* End of ZPPT01 */
} /* zppt01_ */
/* Subroutine */ int zhptrd_(char *uplo, integer *n, doublecomplex *ap,
doublereal *d__, doublereal *e, doublecomplex *tau, 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
=======
ZHPTRD reduces a complex Hermitian matrix A stored in packed form to
real symmetric tridiagonal form T by a unitary similarity
transformation: Q**H * A * Q = T.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the Hermitian matrix
A, packed columnwise in a linear array. The j-th column of A
is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
On exit, if UPLO = 'U', the diagonal and first superdiagonal
of A are overwritten by the corresponding elements of the
tridiagonal matrix T, and the elements above the first
superdiagonal, with the array TAU, represent the unitary
matrix Q as a product of elementary reflectors; if UPLO
= 'L', the diagonal and first subdiagonal of A are over-
written by the corresponding elements of the tridiagonal
matrix T, and the elements below the first subdiagonal, with
the array TAU, represent the unitary matrix Q as a product
of elementary reflectors. See Further Details.
D (output) DOUBLE PRECISION array, dimension (N)
The diagonal elements of the tridiagonal matrix T:
D(i) = A(i,i).
E (output) DOUBLE PRECISION array, dimension (N-1)
The off-diagonal elements of the tridiagonal matrix T:
E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
TAU (output) COMPLEX*16 array, dimension (N-1)
The scalar factors of the elementary reflectors (see Further
Details).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
If UPLO = 'U', the matrix Q is represented as a product of elementary
reflectors
Q = H(n-1) . . . H(2) H(1).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a complex scalar, and v is a complex vector with
v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
If UPLO = 'L', the matrix Q is represented as a product of elementary
reflectors
Q = H(1) H(2) . . . H(n-1).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a complex scalar, and v is a complex vector with
v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
overwriting A(i+2:n,i), and tau is stored in TAU(i).
=====================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b2 = {0.,0.};
static integer c__1 = 1;
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
static doublecomplex taui;
extern /* Subroutine */ int zhpr2_(char *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *);
static integer i__;
static doublecomplex alpha;
extern logical lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer i1;
static logical upper;
extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), zaxpy_(integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *);
static integer ii;
extern /* Subroutine */ int xerbla_(char *, integer *), zlarfg_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
static integer i1i1;
--tau;
--e;
--d__;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHPTRD", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
if (upper) {
/* Reduce the upper triangle of A.
I1 is the index in AP of A(1,I+1). */
i1 = *n * (*n - 1) / 2 + 1;
i__1 = i1 + *n - 1;
i__2 = i1 + *n - 1;
d__1 = ap[i__2].r;
ap[i__1].r = d__1, ap[i__1].i = 0.;
for (i__ = *n - 1; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) = I - tau * v * v'
to annihilate A(1:i-1,i+1) */
i__1 = i1 + i__ - 1;
alpha.r = ap[i__1].r, alpha.i = ap[i__1].i;
zlarfg_(&i__, &alpha, &ap[i1], &c__1, &taui);
i__1 = i__;
e[i__1] = alpha.r;
if (taui.r != 0. || taui.i != 0.) {
/* Apply H(i) from both sides to A(1:i,1:i) */
i__1 = i1 + i__ - 1;
ap[i__1].r = 1., ap[i__1].i = 0.;
/* Compute y := tau * A * v storing y in TAU(1:i) */
zhpmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b2, &tau[
1], &c__1);
/* Compute w := y - 1/2 * tau * (y'*v) * v */
z__3.r = -.5, z__3.i = 0.;
z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r *
taui.i + z__3.i * taui.r;
zdotc_(&z__4, &i__, &tau[1], &c__1, &ap[i1], &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;
zaxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1);
/* Apply the transformation as a rank-2 update:
A := A - v * w' - w * v' */
z__1.r = -1., z__1.i = 0.;
zhpr2_(uplo, &i__, &z__1, &ap[i1], &c__1, &tau[1], &c__1, &ap[
1]);
}
i__1 = i1 + i__ - 1;
i__2 = i__;
ap[i__1].r = e[i__2], ap[i__1].i = 0.;
i__1 = i__ + 1;
i__2 = i1 + i__;
d__[i__1] = ap[i__2].r;
i__1 = i__;
tau[i__1].r = taui.r, tau[i__1].i = taui.i;
i1 -= i__;
/* L10: */
}
d__[1] = ap[1].r;
} else {
/* Reduce the lower triangle of A. II is the index in AP of
A(i,i) and I1I1 is the index of A(i+1,i+1). */
ii = 1;
d__1 = ap[1].r;
ap[1].r = d__1, ap[1].i = 0.;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i1i1 = ii + *n - i__ + 1;
/* Generate elementary reflector H(i) = I - tau * v * v'
to annihilate A(i+2:n,i) */
i__2 = ii + 1;
alpha.r = ap[i__2].r, alpha.i = ap[i__2].i;
i__2 = *n - i__;
zlarfg_(&i__2, &alpha, &ap[ii + 2], &c__1, &taui);
i__2 = i__;
e[i__2] = alpha.r;
if (taui.r != 0. || taui.i != 0.) {
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
i__2 = ii + 1;
ap[i__2].r = 1., ap[i__2].i = 0.;
/* Compute y := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
zhpmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, &
c_b2, &tau[i__], &c__1);
/* Compute w := y - 1/2 * tau * (y'*v) * v */
z__3.r = -.5, z__3.i = 0.;
z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r *
taui.i + z__3.i * taui.r;
i__2 = *n - i__;
zdotc_(&z__4, &i__2, &tau[i__], &c__1, &ap[ii + 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__2 = *n - i__;
zaxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1);
/* Apply the transformation as a rank-2 update:
A := A - v * w' - w * v' */
i__2 = *n - i__;
z__1.r = -1., z__1.i = 0.;
zhpr2_(uplo, &i__2, &z__1, &ap[ii + 1], &c__1, &tau[i__], &
c__1, &ap[i1i1]);
}
i__2 = ii + 1;
i__3 = i__;
ap[i__2].r = e[i__3], ap[i__2].i = 0.;
i__2 = i__;
i__3 = ii;
d__[i__2] = ap[i__3].r;
i__2 = i__;
tau[i__2].r = taui.r, tau[i__2].i = taui.i;
ii = i1i1;
/* L20: */
}
i__1 = *n;
i__2 = ii;
d__[i__1] = ap[i__2].r;
}
return 0;
/* End of ZHPTRD */
} /* zhptrd_ */
/* Subroutine */ int zlatrs_(char *uplo, char *trans, char *diag, char *
normin, integer *n, doublecomplex *a, integer *lda, doublecomplex *x,
doublereal *scale, doublereal *cnorm, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
integer i__, j;
doublereal xj, rec, tjj;
integer jinc;
doublereal xbnd;
integer imax;
doublereal tmax;
doublecomplex tjjs;
doublereal xmax, grow;
doublereal tscal;
doublecomplex uscal;
integer jlast;
doublecomplex csumj;
logical upper;
doublereal bignum;
logical notran;
integer jfirst;
doublereal smlnum;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZLATRS solves one of the triangular systems */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */
/* with scaling to prevent overflow. Here A is an upper or lower */
/* triangular matrix, A**T denotes the transpose of A, A**H denotes the */
/* conjugate transpose of A, x and b are n-element vectors, and s is a */
/* scaling factor, usually less than or equal to 1, chosen so that the */
/* components of x will be less than the overflow threshold. If the */
/* unscaled problem will not cause overflow, the Level 2 BLAS routine */
/* ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */
/* then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation applied to A. */
/* = 'N': Solve A * x = s*b (No transpose) */
/* = 'T': Solve A**T * x = s*b (Transpose) */
/* = 'C': Solve A**H * x = s*b (Conjugate transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* NORMIN (input) CHARACTER*1 */
/* Specifies whether CNORM has been set or not. */
/* = 'Y': CNORM contains the column norms on entry */
/* = 'N': CNORM is not set on entry. On exit, the norms will */
/* be computed and stored in CNORM. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading n by n */
/* upper triangular part of the array A contains the upper */
/* triangular matrix, and the strictly lower triangular part of */
/* A is not referenced. If UPLO = 'L', the leading n by n lower */
/* triangular part of the array A contains the lower triangular */
/* matrix, and the strictly upper triangular part of A is not */
/* referenced. If DIAG = 'U', the diagonal elements of A are */
/* also not referenced and are assumed to be 1. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max (1,N). */
/* X (input/output) COMPLEX*16 array, dimension (N) */
/* On entry, the right hand side b of the triangular system. */
/* On exit, X is overwritten by the solution vector x. */
/* SCALE (output) DOUBLE PRECISION */
/* The scaling factor s for the triangular system */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */
/* If SCALE = 0, the matrix A is singular or badly scaled, and */
/* the vector x is an exact or approximate solution to A*x = 0. */
/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */
/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
/* contains the norm of the off-diagonal part of the j-th column */
/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
/* must be greater than or equal to the 1-norm. */
/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
/* returns the 1-norm of the offdiagonal part of the j-th column */
/* of A. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* Further Details */
/* ======= ======= */
/* A rough bound on x is computed; if that is less than overflow, ZTRSV */
/* is called, otherwise, specific code is used which checks for possible */
/* overflow or divide-by-zero at every operation. */
/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
/* if A is lower triangular is */
/* x[1:n] := b[1:n] */
/* x(j) := x(j) / A(j,j) */
/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
/* end */
/* Define bounds on the components of x after j iterations of the loop: */
/* M(j) = bound on x[1:j] */
/* G(j) = bound on x[j+1:n] */
/* Then for iteration j+1 we have */
/* M(j+1) <= G(j) / | A(j+1,j+1) | */
/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
/* column j+1 of A, not counting the diagonal. Hence */
/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
/* 1<=i<=j */
/* and */
/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
/* 1<=i< j */
/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the */
/* max(underflow, 1/overflow). */
/* The bound on x(j) is also used to determine when a step in the */
/* columnwise method can be performed without fear of overflow. If */
/* the computed bound is greater than a large constant, x is scaled to */
/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
/* Similarly, a row-wise scheme is used to solve A**T *x = b or */
/* A**H *x = b. The basic algorithm for A upper triangular is */
/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
/* end */
/* We simultaneously compute two bounds */
/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
/* M(j) = bound on x(i), 1<=i<=j */
/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
/* Then the bound on x(j) is */
/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
/* 1<=i<=j */
/* and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater */
/* than max(underflow, 1/overflow). */
/* ===================================================================== */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--x;
--cnorm;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
/* Test the input parameters. */
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (! lsame_(normin, "Y") && ! lsame_(normin,
"N")) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLATRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum /= dlamch_("Precision");
bignum = 1. / smlnum;
*scale = 1.;
if (lsame_(normin, "N")) {
/* Compute the 1-norm of each column, not including the diagonal. */
if (upper) {
/* A is upper triangular. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
cnorm[j] = dzasum_(&i__2, &a[j * a_dim1 + 1], &c__1);
}
} else {
/* A is lower triangular. */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
cnorm[j] = dzasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1);
}
cnorm[*n] = 0.;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM/2. */
imax = idamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5) {
tscal = 1.;
} else {
tscal = .5 / (smlnum * tmax);
dscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine ZTRSV can be used. */
xmax = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j;
d__3 = xmax, d__4 = (d__1 = x[i__2].r / 2., abs(d__1)) + (d__2 =
d_imag(&x[j]) / 2., abs(d__2));
xmax = max(d__3,d__4);
}
xbnd = xmax;
if (notran) {
/* Compute the growth in A * x = b. */
if (upper) {
jfirst = *n;
jlast = 1;
jinc = -1;
} else {
jfirst = 1;
jlast = *n;
jinc = 1;
}
if (tscal != 1.) {
grow = 0.;
goto L60;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
grow = .5 / max(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj >= smlnum) {
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
d__1 = xbnd, d__2 = min(1.,tjj) * grow;
xbnd = min(d__1,d__2);
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
if (tjj + cnorm[j] >= smlnum) {
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
grow *= tjj / (tjj + cnorm[j]);
} else {
/* G(j) could overflow, set GROW to 0. */
grow = 0.;
}
}
grow = xbnd;
} else {
/* A is unit triangular. */
/* Computing MIN */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1. / (cnorm[j] + 1.);
}
}
L60:
;
} else {
/* Compute the growth in A**T * x = b or A**H * x = b. */
if (upper) {
jfirst = 1;
jlast = *n;
jinc = 1;
} else {
jfirst = *n;
jlast = 1;
jinc = -1;
}
if (tscal != 1.) {
grow = 0.;
goto L90;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
grow = .5 / max(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
xj = cnorm[j] + 1.;
/* Computing MIN */
d__1 = grow, d__2 = xbnd / xj;
grow = min(d__1,d__2);
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj >= smlnum) {
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
if (xj > tjj) {
xbnd *= tjj / xj;
}
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
}
grow = min(grow,xbnd);
} else {
/* A is unit triangular. */
/* Computing MIN */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.;
grow /= xj;
}
}
L90:
;
}
if (grow * tscal > smlnum) {
/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
/* elements of X is not too small. */
ztrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5) {
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum * .5 / xmax;
zdscal_(n, scale, &x[1], &c__1);
xmax = bignum;
} else {
xmax *= 2.;
}
if (notran) {
/* Solve A * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
if (nounit) {
i__3 = j + j * a_dim1;
z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3].i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L110;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
/* to avoid overflow when dividing by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.) {
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0, and compute a solution to A*x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0., x[i__4].i = 0.;
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
xj = 1.;
*scale = 0.;
xmax = 0.;
}
L110:
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.) {
rec = 1. / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
zdscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5;
}
if (upper) {
if (j > 1) {
/* Compute the update */
/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
i__3 = j - 1;
i__4 = j;
z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
i__3 = j - 1;
i__ = izamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x[i__]), abs(d__2));
}
} else {
if (j < *n) {
/* Compute the update */
/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
i__3 = *n - j;
i__4 = j;
z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
i__3 = *n - j;
i__ = j + izamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x[i__]), abs(d__2));
}
}
}
} else if (lsame_(trans, "T")) {
/* Solve A**T * x = b */
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5;
if (nounit) {
i__3 = j + j * a_dim1;
z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3]
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot product is 1, */
/* call ZDOTU to perform the dot product. */
if (upper) {
i__3 = j - 1;
zdotu_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotu_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
z__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, z__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
z__2.i = z__3.r * x[i__5].i + z__3.i * x[
i__5].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
z__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, z__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
z__2.i = z__3.r * x[i__5].i + z__3.i * x[
i__5].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
if (nounit) {
i__3 = j + j * a_dim1;
z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3]
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L160;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**T *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0., x[i__4].i = 0.;
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
*scale = 0.;
xmax = 0.;
}
L160:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
zladiv_(&z__2, &x[j], &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[j]), abs(d__2));
xmax = max(d__3,d__4);
}
} else {
/* Solve A**H * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5;
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot product is 1, */
/* call ZDOTC to perform the dot product. */
if (upper) {
i__3 = j - 1;
zdotc_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotc_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d_cnjg(&z__4, &a[i__ + j * a_dim1]);
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
z__2.i = z__3.r * x[i__4].i + z__3.i * x[
i__4].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
d_cnjg(&z__4, &a[i__ + j * a_dim1]);
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
z__2.i = z__3.r * x[i__4].i + z__3.i * x[
i__4].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L210;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**H *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0., x[i__4].i = 0.;
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
*scale = 0.;
xmax = 0.;
}
L210:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
zladiv_(&z__2, &x[j], &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[j]), abs(d__2));
xmax = max(d__3,d__4);
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.) {
d__1 = 1. / tscal;
dscal_(n, &d__1, &cnorm[1], &c__1);
}
return 0;
/* End of ZLATRS */
} /* zlatrs_ */
/* Subroutine */ int zpst01_(char *uplo, integer *n, doublecomplex *a,
integer *lda, doublecomplex *afac, integer *ldafac, doublecomplex *
perm, integer *ldperm, integer *piv, doublereal *rwork, doublereal *
resid, integer *rank)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, perm_dim1, perm_offset,
i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
doublecomplex z__1;
/* Local variables */
integer i__, j, k;
doublecomplex tc;
doublereal tr, eps;
doublereal anorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPST01 reconstructs an Hermitian positive semidefinite matrix A */
/* from its L or U factors and the permutation matrix P and computes */
/* the residual */
/* norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or */
/* norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon, L' is the conjugate transpose of L, */
/* and U' is the conjugate transpose of U. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The original Hermitian matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* AFAC (input) COMPLEX*16 array, dimension (LDAFAC,N) */
/* The factor L or U from the L*L' or U'*U */
/* factorization of A. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
/* PERM (output) COMPLEX*16 array, dimension (LDPERM,N) */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference P*L*L'*P' - A (or P*U'*U*P' - A) */
/* LDPERM (input) INTEGER */
/* The leading dimension of the array PERM. */
/* LDAPERM >= max(1,N). */
/* PIV (input) INTEGER array, dimension (N) */
/* PIV is such that the nonzero entries are */
/* P( PIV( K ), K ) = 1. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESID (output) DOUBLE PRECISION */
/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
perm_dim1 = *ldperm;
perm_offset = 1 + perm_dim1;
perm -= perm_offset;
--piv;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
anorm = zlanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Check the imaginary parts of the diagonal elements and return with */
/* an error code if any are nonzero. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (d_imag(&afac[j + j * afac_dim1]) != 0.) {
*resid = 1. / eps;
return 0;
}
/* L100: */
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = *rank + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
afac[i__3].r = 0., afac[i__3].i = 0.;
/* L110: */
}
/* L120: */
}
}
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
zdotc_(&z__1, &k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
afac_dim1 + 1], &c__1);
tr = z__1.r;
i__1 = k + k * afac_dim1;
afac[i__1].r = tr, afac[i__1].i = 0.;
/* Compute the rest of column K. */
i__1 = k - 1;
ztrmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[afac_offset]
, ldafac, &afac[k * afac_dim1 + 1], &c__1);
/* L130: */
}
/* Compute the product L*L', overwriting L. */
} else {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
afac[i__3].r = 0., afac[i__3].i = 0.;
/* L140: */
}
/* L150: */
}
}
for (k = *n; k >= 1; --k) {
/* Add a multiple of column K of the factor L to each of */
/* columns K+1 through N. */
if (k + 1 <= *n) {
i__1 = *n - k;
zher_("Lower", &i__1, &c_b20, &afac[k + 1 + k * afac_dim1], &
c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
}
/* Scale column K by the diagonal element. */
i__1 = k + k * afac_dim1;
tc.r = afac[i__1].r, tc.i = afac[i__1].i;
i__1 = *n - k + 1;
zscal_(&i__1, &tc, &afac[k + k * afac_dim1], &c__1);
/* L160: */
}
}
/* Form P*L*L'*P' or P*U'*U*P' */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] <= piv[j]) {
if (i__ <= j) {
i__3 = piv[i__] + piv[j] * perm_dim1;
i__4 = i__ + j * afac_dim1;
perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
.i;
} else {
i__3 = piv[i__] + piv[j] * perm_dim1;
d_cnjg(&z__1, &afac[j + i__ * afac_dim1]);
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
}
}
/* L170: */
}
/* L180: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] >= piv[j]) {
if (i__ >= j) {
i__3 = piv[i__] + piv[j] * perm_dim1;
i__4 = i__ + j * afac_dim1;
perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
.i;
} else {
i__3 = piv[i__] + piv[j] * perm_dim1;
d_cnjg(&z__1, &afac[j + i__ * afac_dim1]);
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
}
}
/* L190: */
}
/* L200: */
}
}
/* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A). */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * perm_dim1;
i__4 = i__ + j * perm_dim1;
i__5 = i__ + j * a_dim1;
z__1.r = perm[i__4].r - a[i__5].r, z__1.i = perm[i__4].i - a[
i__5].i;
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
/* L210: */
}
i__2 = j + j * perm_dim1;
i__3 = j + j * perm_dim1;
i__4 = j + j * a_dim1;
d__1 = a[i__4].r;
z__1.r = perm[i__3].r - d__1, z__1.i = perm[i__3].i;
perm[i__2].r = z__1.r, perm[i__2].i = z__1.i;
/* L220: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * perm_dim1;
i__3 = j + j * perm_dim1;
i__4 = j + j * a_dim1;
d__1 = a[i__4].r;
z__1.r = perm[i__3].r - d__1, z__1.i = perm[i__3].i;
perm[i__2].r = z__1.r, perm[i__2].i = z__1.i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * perm_dim1;
i__4 = i__ + j * perm_dim1;
i__5 = i__ + j * a_dim1;
z__1.r = perm[i__4].r - a[i__5].r, z__1.i = perm[i__4].i - a[
i__5].i;
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
/* L230: */
}
/* L240: */
}
}
/* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or */
/* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). */
*resid = zlanhe_("1", uplo, n, &perm[perm_offset], ldafac, &rwork[1]);
*resid = *resid / (doublereal) (*n) / anorm / eps;
return 0;
/* End of ZPST01 */
} /* zpst01_ */
/* Subroutine */ int zlaic1_(integer *job, integer *j, doublecomplex *x,
doublereal *sest, doublecomplex *w, doublecomplex *gamma, doublereal *
sestpr, doublecomplex *s, doublecomplex *c)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
ZLAIC1 applies one step of incremental condition estimation in
its simplest version:
Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
lower triangular matrix L, such that
twonorm(L*x) = sest
Then ZLAIC1 computes sestpr, s, c such that
the vector
[ s*x ]
xhat = [ c ]
is an approximate singular vector of
[ L 0 ]
Lhat = [ w' gamma ]
in the sense that
twonorm(Lhat*xhat) = sestpr.
Depending on JOB, an estimate for the largest or smallest singular
value is computed.
Note that [s c]' and sestpr**2 is an eigenpair of the system
diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ]
[ conjg(gamma) ]
where alpha = conjg(x)'*w.
Arguments
=========
JOB (input) INTEGER
= 1: an estimate for the largest singular value is computed.
= 2: an estimate for the smallest singular value is computed.
J (input) INTEGER
Length of X and W
X (input) COMPLEX*16 array, dimension (J)
The j-vector x.
SEST (input) DOUBLE PRECISION
Estimated singular value of j by j matrix L
W (input) COMPLEX*16 array, dimension (J)
The j-vector w.
GAMMA (input) COMPLEX*16
The diagonal element gamma.
SEDTPR (output) DOUBLE PRECISION
Estimated singular value of (j+1) by (j+1) matrix Lhat.
S (output) COMPLEX*16
Sine needed in forming xhat.
C (output) COMPLEX*16
Cosine needed in forming xhat.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *), z_sqrt(doublecomplex *,
doublecomplex *);
double sqrt(doublereal);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
static doublecomplex sine;
static doublereal test, zeta1, zeta2, b, t;
static doublecomplex alpha;
static doublereal norma;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal s1, s2;
extern doublereal dlamch_(char *);
static doublereal absgam, absalp;
static doublecomplex cosine;
static doublereal absest, scl, eps, tmp;
#define W(I) w[(I)-1]
#define X(I) x[(I)-1]
eps = dlamch_("Epsilon");
zdotc_(&z__1, j, &X(1), &c__1, &W(1), &c__1);
alpha.r = z__1.r, alpha.i = z__1.i;
absalp = z_abs(&alpha);
absgam = z_abs(gamma);
absest = abs(*sest);
if (*job == 1) {
/* Estimating largest singular value
special cases */
if (*sest == 0.) {
s1 = max(absgam,absalp);
if (s1 == 0.) {
s->r = 0., s->i = 0.;
c->r = 1., c->i = 0.;
*sestpr = 0.;
} else {
z__1.r = alpha.r / s1, z__1.i = alpha.i / s1;
s->r = z__1.r, s->i = z__1.i;
z__1.r = gamma->r / s1, z__1.i = gamma->i / s1;
c->r = z__1.r, c->i = z__1.i;
d_cnjg(&z__4, s);
z__3.r = s->r * z__4.r - s->i * z__4.i, z__3.i = s->r *
z__4.i + s->i * z__4.r;
d_cnjg(&z__6, c);
z__5.r = c->r * z__6.r - c->i * z__6.i, z__5.i = c->r *
z__6.i + c->i * z__6.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z_sqrt(&z__1, &z__2);
tmp = z__1.r;
z__1.r = s->r / tmp, z__1.i = s->i / tmp;
s->r = z__1.r, s->i = z__1.i;
z__1.r = c->r / tmp, z__1.i = c->i / tmp;
c->r = z__1.r, c->i = z__1.i;
*sestpr = s1 * tmp;
}
return 0;
} else if (absgam <= eps * absest) {
s->r = 1., s->i = 0.;
c->r = 0., c->i = 0.;
tmp = max(absest,absalp);
s1 = absest / tmp;
s2 = absalp / tmp;
*sestpr = tmp * sqrt(s1 * s1 + s2 * s2);
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
s->r = 1., s->i = 0.;
c->r = 0., c->i = 0.;
*sestpr = s2;
} else {
s->r = 0., s->i = 0.;
c->r = 1., c->i = 0.;
*sestpr = s1;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
scl = sqrt(tmp * tmp + 1.);
*sestpr = s2 * scl;
z__2.r = alpha.r / s2, z__2.i = alpha.i / s2;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
s->r = z__1.r, s->i = z__1.i;
z__2.r = gamma->r / s2, z__2.i = gamma->i / s2;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
c->r = z__1.r, c->i = z__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.);
*sestpr = s1 * scl;
z__2.r = alpha.r / s1, z__2.i = alpha.i / s1;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
s->r = z__1.r, s->i = z__1.i;
z__2.r = gamma->r / s1, z__2.i = gamma->i / s1;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
c->r = z__1.r, c->i = z__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
b = (1. - zeta1 * zeta1 - zeta2 * zeta2) * .5;
d__1 = zeta1 * zeta1;
c->r = d__1, c->i = 0.;
if (b > 0.) {
d__1 = b * b;
z__4.r = d__1 + c->r, z__4.i = c->i;
z_sqrt(&z__3, &z__4);
z__2.r = b + z__3.r, z__2.i = z__3.i;
z_div(&z__1, c, &z__2);
t = z__1.r;
} else {
d__1 = b * b;
z__3.r = d__1 + c->r, z__3.i = c->i;
z_sqrt(&z__2, &z__3);
z__1.r = z__2.r - b, z__1.i = z__2.i;
t = z__1.r;
}
z__3.r = alpha.r / absest, z__3.i = alpha.i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / t, z__1.i = z__2.i / t;
sine.r = z__1.r, sine.i = z__1.i;
z__3.r = gamma->r / absest, z__3.i = gamma->i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
d__1 = t + 1.;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
cosine.r = z__1.r, cosine.i = z__1.i;
d_cnjg(&z__4, &sine);
z__3.r = sine.r * z__4.r - sine.i * z__4.i, z__3.i = sine.r *
z__4.i + sine.i * z__4.r;
d_cnjg(&z__6, &cosine);
z__5.r = cosine.r * z__6.r - cosine.i * z__6.i, z__5.i = cosine.r
* z__6.i + cosine.i * z__6.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z_sqrt(&z__1, &z__2);
tmp = z__1.r;
z__1.r = sine.r / tmp, z__1.i = sine.i / tmp;
s->r = z__1.r, s->i = z__1.i;
z__1.r = cosine.r / tmp, z__1.i = cosine.i / tmp;
c->r = z__1.r, c->i = z__1.i;
*sestpr = sqrt(t + 1.) * absest;
return 0;
}
} else if (*job == 2) {
/* Estimating smallest singular value
special cases */
if (*sest == 0.) {
*sestpr = 0.;
if (max(absgam,absalp) == 0.) {
sine.r = 1., sine.i = 0.;
cosine.r = 0., cosine.i = 0.;
} else {
d_cnjg(&z__2, gamma);
z__1.r = -z__2.r, z__1.i = -z__2.i;
sine.r = z__1.r, sine.i = z__1.i;
d_cnjg(&z__1, &alpha);
cosine.r = z__1.r, cosine.i = z__1.i;
}
/* Computing MAX */
d__1 = z_abs(&sine), d__2 = z_abs(&cosine);
s1 = max(d__1,d__2);
z__1.r = sine.r / s1, z__1.i = sine.i / s1;
s->r = z__1.r, s->i = z__1.i;
z__1.r = cosine.r / s1, z__1.i = cosine.i / s1;
c->r = z__1.r, c->i = z__1.i;
d_cnjg(&z__4, s);
z__3.r = s->r * z__4.r - s->i * z__4.i, z__3.i = s->r * z__4.i +
s->i * z__4.r;
d_cnjg(&z__6, c);
z__5.r = c->r * z__6.r - c->i * z__6.i, z__5.i = c->r * z__6.i +
c->i * z__6.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z_sqrt(&z__1, &z__2);
tmp = z__1.r;
z__1.r = s->r / tmp, z__1.i = s->i / tmp;
s->r = z__1.r, s->i = z__1.i;
z__1.r = c->r / tmp, z__1.i = c->i / tmp;
c->r = z__1.r, c->i = z__1.i;
return 0;
} else if (absgam <= eps * absest) {
s->r = 0., s->i = 0.;
c->r = 1., c->i = 0.;
*sestpr = absgam;
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
s->r = 0., s->i = 0.;
c->r = 1., c->i = 0.;
*sestpr = s1;
} else {
s->r = 1., s->i = 0.;
c->r = 0., c->i = 0.;
*sestpr = s2;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
scl = sqrt(tmp * tmp + 1.);
*sestpr = absest * (tmp / scl);
d_cnjg(&z__4, gamma);
z__3.r = z__4.r / s2, z__3.i = z__4.i / s2;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
s->r = z__1.r, s->i = z__1.i;
d_cnjg(&z__3, &alpha);
z__2.r = z__3.r / s2, z__2.i = z__3.i / s2;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
c->r = z__1.r, c->i = z__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.);
*sestpr = absest / scl;
d_cnjg(&z__4, gamma);
z__3.r = z__4.r / s1, z__3.i = z__4.i / s1;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
s->r = z__1.r, s->i = z__1.i;
d_cnjg(&z__3, &alpha);
z__2.r = z__3.r / s1, z__2.i = z__3.i / s1;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
c->r = z__1.r, c->i = z__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
/* Computing MAX */
d__1 = zeta1 * zeta1 + 1. + zeta1 * zeta2, d__2 = zeta1 * zeta2 +
zeta2 * zeta2;
norma = max(d__1,d__2);
/* See if root is closer to zero or to ONE */
test = (zeta1 - zeta2) * 2. * (zeta1 + zeta2) + 1.;
if (test >= 0.) {
/* root is close to zero, compute directly */
b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.) * .5;
d__1 = zeta2 * zeta2;
c->r = d__1, c->i = 0.;
d__2 = b * b;
z__2.r = d__2 - c->r, z__2.i = -c->i;
d__1 = b + sqrt(z_abs(&z__2));
z__1.r = c->r / d__1, z__1.i = c->i / d__1;
t = z__1.r;
z__2.r = alpha.r / absest, z__2.i = alpha.i / absest;
d__1 = 1. - t;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
sine.r = z__1.r, sine.i = z__1.i;
z__3.r = gamma->r / absest, z__3.i = gamma->i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / t, z__1.i = z__2.i / t;
cosine.r = z__1.r, cosine.i = z__1.i;
*sestpr = sqrt(t + eps * 4. * eps * norma) * absest;
} else {
/* root is closer to ONE, shift by that amount */
b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.) * .5;
d__1 = zeta1 * zeta1;
c->r = d__1, c->i = 0.;
if (b >= 0.) {
z__2.r = -c->r, z__2.i = -c->i;
d__1 = b * b;
z__5.r = d__1 + c->r, z__5.i = c->i;
z_sqrt(&z__4, &z__5);
z__3.r = b + z__4.r, z__3.i = z__4.i;
z_div(&z__1, &z__2, &z__3);
t = z__1.r;
} else {
d__1 = b * b;
z__3.r = d__1 + c->r, z__3.i = c->i;
z_sqrt(&z__2, &z__3);
z__1.r = b - z__2.r, z__1.i = -z__2.i;
t = z__1.r;
}
z__3.r = alpha.r / absest, z__3.i = alpha.i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / t, z__1.i = z__2.i / t;
sine.r = z__1.r, sine.i = z__1.i;
z__3.r = gamma->r / absest, z__3.i = gamma->i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
d__1 = t + 1.;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
cosine.r = z__1.r, cosine.i = z__1.i;
*sestpr = sqrt(t + 1. + eps * 4. * eps * norma) * absest;
}
d_cnjg(&z__4, &sine);
z__3.r = sine.r * z__4.r - sine.i * z__4.i, z__3.i = sine.r *
z__4.i + sine.i * z__4.r;
d_cnjg(&z__6, &cosine);
z__5.r = cosine.r * z__6.r - cosine.i * z__6.i, z__5.i = cosine.r
* z__6.i + cosine.i * z__6.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z_sqrt(&z__1, &z__2);
tmp = z__1.r;
z__1.r = sine.r / tmp, z__1.i = sine.i / tmp;
s->r = z__1.r, s->i = z__1.i;
z__1.r = cosine.r / tmp, z__1.i = cosine.i / tmp;
c->r = z__1.r, c->i = z__1.i;
return 0;
}
}
return 0;
/* End of ZLAIC1 */
} /* zlaic1_ */
int zlatrd_(char *uplo, int *n, int *nb,
doublecomplex *a, int *lda, double *e, doublecomplex *tau,
doublecomplex *w, int *ldw)
{
/* System generated locals */
int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
double d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
int i__, iw;
doublecomplex alpha;
extern int lsame_(char *, char *);
extern int zscal_(int *, doublecomplex *,
doublecomplex *, int *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, int *,
doublecomplex *, int *, doublecomplex *, int *);
extern int zgemv_(char *, int *, int *,
doublecomplex *, doublecomplex *, int *, doublecomplex *,
int *, doublecomplex *, doublecomplex *, int *),
zhemv_(char *, int *, doublecomplex *, doublecomplex *,
int *, doublecomplex *, int *, doublecomplex *,
doublecomplex *, int *), zaxpy_(int *,
doublecomplex *, doublecomplex *, int *, doublecomplex *,
int *), zlarfg_(int *, doublecomplex *, doublecomplex *,
int *, doublecomplex *), zlacgv_(int *, doublecomplex *,
int *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to */
/* Hermitian tridiagonal form by a unitary similarity */
/* transformation Q' * A * Q, and returns the matrices V and W which are */
/* needed to apply the transformation to the unreduced part of A. */
/* If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a */
/* matrix, of which the upper triangle is supplied; */
/* if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a */
/* matrix, of which the lower triangle is supplied. */
/* This is an auxiliary routine called by ZHETRD. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* NB (input) INTEGER */
/* The number of rows and columns to be reduced. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */
/* n-by-n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n-by-n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit: */
/* if UPLO = 'U', the last NB columns have been reduced to */
/* tridiagonal form, with the diagonal elements overwriting */
/* the diagonal elements of A; the elements above the diagonal */
/* with the array TAU, represent the unitary matrix Q as a */
/* product of elementary reflectors; */
/* if UPLO = 'L', the first NB columns have been reduced to */
/* tridiagonal form, with the diagonal elements overwriting */
/* the diagonal elements of A; the elements below the diagonal */
/* with the array TAU, represent the unitary matrix Q as a */
/* product of elementary reflectors. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* E (output) DOUBLE PRECISION array, dimension (N-1) */
/* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */
/* elements of the last NB columns of the reduced matrix; */
/* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */
/* the first NB columns of the reduced matrix. */
/* TAU (output) COMPLEX*16 array, dimension (N-1) */
/* The scalar factors of the elementary reflectors, stored in */
/* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */
/* See Further Details. */
/* W (output) COMPLEX*16 array, dimension (LDW,NB) */
/* The n-by-nb matrix W required to update the unreduced part */
/* of A. */
/* LDW (input) INTEGER */
/* The leading dimension of the array W. LDW >= MAX(1,N). */
/* Further Details */
/* =============== */
/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(n) H(n-1) . . . H(n-nb+1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */
/* and tau in TAU(i-1). */
/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(1) H(2) . . . H(nb). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */
/* and tau in TAU(i). */
/* The elements of the vectors v together form the n-by-nb matrix V */
/* which is needed, with W, to apply the transformation to the unreduced */
/* part of the matrix, using a Hermitian rank-2k update of the form: */
/* A := A - V*W' - W*V'. */
/* The contents of A on exit are illustrated by the following examples */
/* with n = 5 and nb = 2: */
/* if UPLO = 'U': if UPLO = 'L': */
/* ( a a a v4 v5 ) ( d ) */
/* ( a a v4 v5 ) ( 1 d ) */
/* ( a 1 v5 ) ( v1 1 a ) */
/* ( d 1 ) ( v1 v2 a a ) */
/* ( d ) ( v1 v2 a a a ) */
/* where d denotes a diagonal element of the reduced matrix, a denotes */
/* an element of the original matrix that is unchanged, and vi denotes */
/* an element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--e;
--tau;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U")) {
/* Reduce last NB columns of upper triangle */
i__1 = *n - *nb + 1;
for (i__ = *n; i__ >= i__1; --i__) {
iw = i__ - *n + *nb;
if (i__ < *n) {
/* Update A(1:i,i) */
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = *n - i__;
zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
i__2 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__, &i__2, &z__1, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, &
c_b2, &a[i__ * a_dim1 + 1], &c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__, &i__2, &z__1, &w[(iw + 1) *
w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b2, &a[i__ * a_dim1 + 1], &c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
}
if (i__ > 1) {
/* Generate elementary reflector H(i) to annihilate */
/* A(1:i-2,i) */
i__2 = i__ - 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = i__ - 1;
zlarfg_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &tau[i__
- 1]);
i__2 = i__ - 1;
e[i__2] = alpha.r;
i__2 = i__ - 1 + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute W(1:i-1,i) */
i__2 = i__ - 1;
zhemv_("Upper", &i__2, &c_b2, &a[a_offset], lda, &a[i__ *
a_dim1 + 1], &c__1, &c_b1, &w[iw * w_dim1 + 1], &c__1);
if (i__ < *n) {
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[(iw
+ 1) * w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &
c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[(
i__ + 1) * a_dim1 + 1], lda, &a[i__ * a_dim1 + 1],
&c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w[(iw + 1) *
w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1);
}
i__2 = i__ - 1;
zscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1);
z__3.r = -.5, z__3.i = -0.;
i__2 = i__ - 1;
z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i =
z__3.r * tau[i__2].i + z__3.i * tau[i__2].r;
i__3 = i__ - 1;
zdotc_(&z__4, &i__3, &w[iw * w_dim1 + 1], &c__1, &a[i__ *
a_dim1 + 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__2 = i__ - 1;
zaxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw *
w_dim1 + 1], &c__1);
}
/* L10: */
}
} else {
/* Reduce first NB columns of lower triangle */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:n,i) */
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = i__ - 1;
zlacgv_(&i__2, &w[i__ + w_dim1], ldw);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + a_dim1], lda,
&w[i__ + w_dim1], ldw, &c_b2, &a[i__ + i__ * a_dim1], &
c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &w[i__ + w_dim1], ldw);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w[i__ + w_dim1], ldw,
&a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1], &
c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
if (i__ < *n) {
/* Generate elementary reflector H(i) to annihilate */
/* A(i+2:n,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[MIN(i__3, *n)+ i__ * a_dim1], &c__1,
&tau[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute W(i+1:n,i) */
i__2 = *n - i__;
zhemv_("Lower", &i__2, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1]
, lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b1, &w[
i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[i__ + 1
+ w_dim1], ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &w[i__ * w_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 +
a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[
i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &w[i__ * w_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &w[i__ + 1 +
w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[
i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
zscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1);
z__3.r = -.5, z__3.i = -0.;
i__2 = i__;
z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i =
z__3.r * tau[i__2].i + z__3.i * tau[i__2].r;
i__3 = *n - i__;
zdotc_(&z__4, &i__3, &w[i__ + 1 + i__ * w_dim1], &c__1, &a[
i__ + 1 + 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 - i__;
zaxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[
i__ + 1 + i__ * w_dim1], &c__1);
}
/* L20: */
}
}
return 0;
/* End of ZLATRD */
} /* zlatrd_ */
/* Subroutine */ int zhpgst_(integer *itype, char *uplo, integer *n,
doublecomplex *ap, doublecomplex *bp, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3;
/* Local variables */
integer j, k, j1, k1, jj, kk;
doublecomplex ct;
doublereal ajj;
integer j1j1;
doublereal akk;
integer k1k1;
doublereal bjj, bkk;
extern /* Subroutine */ int zhpr2_(char *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *);
extern logical lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
logical upper;
extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), zaxpy_(integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *), ztpmv_(char *, char *, char *, integer *,
doublecomplex *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *, doublecomplex *
, doublecomplex *, integer *), xerbla_(
char *, integer *), zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHPGST reduces a complex Hermitian-definite generalized */
/* eigenproblem to standard form, using packed storage. */
/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
/* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H) */
/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
/* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. */
/* B must have been previously factorized as U**H*U or L*L**H by ZPPTRF. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); */
/* = 2 or 3: compute U*A*U**H or L**H*A*L. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored and B is factored as */
/* U**H*U; */
/* = 'L': Lower triangle of A is stored and B is factored as */
/* L*L**H. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, if INFO = 0, the transformed matrix, stored in the */
/* same format as A. */
/* BP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* The triangular factor from the Cholesky factorization of B, */
/* stored in the same format as A, as returned by ZPPTRF. */
/* 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 parameters. */
/* Parameter adjustments */
--bp;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHPGST", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
/* J1 and JJ are the indices of A(1,j) and A(j,j) */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
j1 = jj + 1;
jj += j;
/* Compute the j-th column of the upper triangle of A */
i__2 = jj;
i__3 = jj;
d__1 = ap[i__3].r;
ap[i__2].r = d__1, ap[i__2].i = 0.;
i__2 = jj;
bjj = bp[i__2].r;
ztpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], &
ap[j1], &c__1);
i__2 = j - 1;
z__1.r = -1., z__1.i = -0.;
zhpmv_(uplo, &i__2, &z__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[
j1], &c__1);
i__2 = j - 1;
d__1 = 1. / bjj;
zdscal_(&i__2, &d__1, &ap[j1], &c__1);
i__2 = jj;
i__3 = jj;
i__4 = j - 1;
zdotc_(&z__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1);
z__2.r = ap[i__3].r - z__3.r, z__2.i = ap[i__3].i - z__3.i;
z__1.r = z__2.r / bjj, z__1.i = z__2.i / bjj;
ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */
kk = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
k1k1 = kk + *n - k + 1;
/* Update the lower triangle of A(k:n,k:n) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
i__2 = kk;
ap[i__2].r = akk, ap[i__2].i = 0.;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
zdscal_(&i__2, &d__1, &ap[kk + 1], &c__1);
d__1 = akk * -.5;
ct.r = d__1, ct.i = 0.;
i__2 = *n - k;
zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
z__1.r = -1., z__1.i = -0.;
zhpr2_(uplo, &i__2, &z__1, &ap[kk + 1], &c__1, &bp[kk + 1]
, &c__1, &ap[k1k1]);
i__2 = *n - k;
zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
ztpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1],
&ap[kk + 1], &c__1);
}
kk = k1k1;
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
/* K1 and KK are the indices of A(1,k) and A(k,k) */
kk = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
k1 = kk + 1;
kk += k;
/* Update the upper triangle of A(1:k,1:k) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
i__2 = k - 1;
ztpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[
k1], &c__1);
d__1 = akk * .5;
ct.r = d__1, ct.i = 0.;
i__2 = k - 1;
zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
zhpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, &
ap[1]);
i__2 = k - 1;
zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
zdscal_(&i__2, &bkk, &ap[k1], &c__1);
i__2 = kk;
/* Computing 2nd power */
d__2 = bkk;
d__1 = akk * (d__2 * d__2);
ap[i__2].r = d__1, ap[i__2].i = 0.;
/* L30: */
}
} else {
/* Compute L'*A*L */
/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
j1j1 = jj + *n - j + 1;
/* Compute the j-th column of the lower triangle of A */
i__2 = jj;
ajj = ap[i__2].r;
i__2 = jj;
bjj = bp[i__2].r;
i__2 = jj;
d__1 = ajj * bjj;
i__3 = *n - j;
zdotc_(&z__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1);
z__1.r = d__1 + z__2.r, z__1.i = z__2.i;
ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
i__2 = *n - j;
zdscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
i__2 = *n - j;
zhpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, &
c_b1, &ap[jj + 1], &c__1);
i__2 = *n - j + 1;
ztpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj]
, &ap[jj], &c__1);
jj = j1j1;
/* L40: */
}
}
}
return 0;
/* End of ZHPGST */
} /* zhpgst_ */
/* 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 check2_(doublereal *sfac)
{
/* Initialized data */
static doublecomplex ca = {.4,-.7};
static integer incxs[4] = { 1,2,-2,-1 };
static integer incys[4] = { 1,-2,1,-2 };
static integer lens[8] /* was [4][2] */ = { 1,1,2,4,1,1,3,7 };
static integer ns[4] = { 0,1,2,4 };
static doublecomplex cx1[7] = { {.7,-.8},{-.4,-.7},{-.1,-.9},{.2,-.8},{
-.9,-.4
},{.1,.4},{-.6,.6}
};
static doublecomplex cy1[7] = { {.6,-.6},{-.9,.5},{.7,-.6},{.1,-.5},{
-.1,
-.2
},{-.5,-.3},{.8,-.7}
};
static doublecomplex ct8[112] /* was [7][4][4] */ = { {.6,-.6},{
0.,
0.
},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{0.,0.},{
0.,0.
},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{-1.55,.5},{
0.,
0.
},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{-1.55,.5},{
.03,
-.89
},{-.38,-.96},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.}
,{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{0.,0.},{0.,0.},{
0.,
0.
},{0.,0.},{0.,0.},{0.,0.},{-.07,-.89},{-.9,.5},{.42,-1.41},{
0.,
0.
},{0.,0.},{0.,0.},{0.,0.},{.78,.06},{-.9,.5},{.06,-.13},{.1,-.5}
,{-.77,-.49},{-.5,-.3},{.52,-1.51},{.6,-.6},{0.,0.},{0.,0.},{
0.,
0.
},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{0.,0.},{0.,0.},{0.,0.},{
0.,0.
},{0.,0.},{0.,0.},{-.07,-.89},{-1.18,-.31},{0.,0.},{0.,0.},{
0.,0.
},{0.,0.},{0.,0.},{.78,.06},{-1.54,.97},{.03,-.89},{
-.18,
-1.31
},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{
0.,0.
},{0.,0.},{0.,0.},{.32,-1.41},{0.,0.},{0.,0.},{0.,0.},{0.,0.}
,{0.,0.},{0.,0.},{.32,-1.41},{-.9,.5},{.05,-.6},{0.,0.},{0.,0.},{
0.,0.
},{0.,0.},{.32,-1.41},{-.9,.5},{.05,-.6},{.1,-.5},{-.77,-.49}
,{-.5,-.3},{.32,-1.16}
};
static doublecomplex ct7[16] /* was [4][4] */ = { {0.,0.},{
-.06,
-.9
},{.65,-.47},{-.34,-1.22},{0.,0.},{-.06,-.9},{-.59,-1.46},{
-1.04,-.04
},{0.,0.},{-.06,-.9},{-.83,.59},{.07,-.37},{0.,0.},{
-.06,-.9
},{-.76,-1.15},{-1.33,-1.82}
};
static doublecomplex ct6[16] /* was [4][4] */ = { {0.,0.},{.9,.06},
{.91,-.77},{1.8,-.1},{0.,0.},{.9,.06},{1.45,.74},{.2,.9},{0.,0.},{
.9,.06
},{-.55,.23},{.83,-.39},{0.,0.},{.9,.06},{1.04,.79},{
1.95,
1.22
}
};
static doublecomplex ct10x[112] /* was [7][4][4] */ = { {.7,-.8},{
0.,
0.
},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{
0.,
0.
},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{-.9,.5},{0.,0.},{
0.,
0.
},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{-.9,.5},{.7,-.6},{.1,-.5},{
0.,0.
},{0.,0.},{0.,0.},{.7,-.8},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{
0.,0.
},{0.,0.},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{
0.,0.
},{.7,-.6},{-.4,-.7},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0.,0.}
,{.8,-.7},{-.4,-.7},{-.1,-.2},{.2,-.8},{.7,-.6},{.1,.4},{.6,-.6},{
.7,-.8
},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{
0.,0.
},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{-.9,.5},{-.4,-.7},
{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.1,-.5},{-.4,-.7},{.7,
-.6
},{.2,-.8},{-.9,.5},{.1,.4},{.6,-.6},{.7,-.8},{0.,0.},{0.,0.},{
0.,0.
},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{
0.,0.
},{0.,0.},{0.,0.},{.6,-.6},{.7,-.6},{0.,0.},{0.,0.},{0.,0.},{
0.,0.
},{0.,0.},{.6,-.6},{.7,-.6},{-.1,-.2},{.8,-.7},{0.,0.},{
0.,
0.
},{0.,0.}
};
static doublecomplex ct10y[112] /* was [7][4][4] */ = { {.6,-.6},{
0.,
0.
},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{0.,0.},{
0.,
0.
},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{-.4,-.7},{0.,0.},{
0.,0.
},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{-.4,-.7},{-.1,-.9},{
.2,
-.8
},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{
0.,
0.
},{0.,0.},{0.,0.},{.7,-.8},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{
0.,
0.
},{0.,0.},{-.1,-.9},{-.9,.5},{.7,-.8},{0.,0.},{0.,0.},{0.,0.},{
0.,0.
},{-.6,.6},{-.9,.5},{-.9,-.4},{.1,-.5},{-.1,-.9},{-.5,-.3},{
.7,-.8
},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{
.7,-.8
},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{-.1,-.9},
{.7,-.8},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{-.6,.6},{-.9,
-.4
},{-.1,-.9},{.7,-.8},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{
0.,0.
},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{0.,0.},{0.,0.},{
0.,0.
},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{-.9,.5},{-.4,-.7},{0.,0.}
,{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{-.9,.5},{-.4,-.7},{.1,-.5},{
-.1,-.9
},{-.5,-.3},{.2,-.8}
};
static doublecomplex csize1[4] = { {0.,0.},{.9,.9},{1.63,1.73},{2.9,2.78}
};
static doublecomplex csize3[14] = { {0.,0.},{0.,0.},{0.,0.},{0.,0.},{
0.,
0.
},{0.,0.},{0.,0.},{1.17,1.17},{1.17,1.17},{1.17,1.17},{
1.17,
1.17
},{1.17,1.17},{1.17,1.17},{1.17,1.17}
};
static doublecomplex csize2[14] /* was [7][2] */ = { {0.,0.},{0.,0.},{
0.,0.
},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{1.54,1.54},{1.54,1.54},{
1.54,1.54
},{1.54,1.54},{1.54,1.54},{1.54,1.54},{1.54,1.54}
};
/* System generated locals */
integer i__1, i__2;
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 doublecomplex cdot[1];
static integer lenx, leny, i__;
extern /* Subroutine */ int ctest_(integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublereal *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer ksize;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer ki, kn;
static doublecomplex cx[7], cy[7];
static integer mx, my;
/* Fortran I/O blocks */
static cilist io___48 = { 0, 6, 0, 0, 0 };
#define ct10x_subscr(a_1,a_2,a_3) ((a_3)*4 + (a_2))*7 + a_1 - 36
#define ct10x_ref(a_1,a_2,a_3) ct10x[ct10x_subscr(a_1,a_2,a_3)]
#define ct10y_subscr(a_1,a_2,a_3) ((a_3)*4 + (a_2))*7 + a_1 - 36
#define ct10y_ref(a_1,a_2,a_3) ct10y[ct10y_subscr(a_1,a_2,a_3)]
#define lens_ref(a_1,a_2) lens[(a_2)*4 + a_1 - 5]
#define csize2_subscr(a_1,a_2) (a_2)*7 + a_1 - 8
#define csize2_ref(a_1,a_2) csize2[csize2_subscr(a_1,a_2)]
#define ct6_subscr(a_1,a_2) (a_2)*4 + a_1 - 5
#define ct6_ref(a_1,a_2) ct6[ct6_subscr(a_1,a_2)]
#define ct7_subscr(a_1,a_2) (a_2)*4 + a_1 - 5
#define ct7_ref(a_1,a_2) ct7[ct7_subscr(a_1,a_2)]
#define ct8_subscr(a_1,a_2,a_3) ((a_3)*4 + (a_2))*7 + a_1 - 36
#define ct8_ref(a_1,a_2,a_3) ct8[ct8_subscr(a_1,a_2,a_3)]
for (ki = 1; ki <= 4; ++ki) {
combla_1.incx = incxs[ki - 1];
combla_1.incy = incys[ki - 1];
mx = abs(combla_1.incx);
my = abs(combla_1.incy);
for (kn = 1; kn <= 4; ++kn) {
combla_1.n = ns[kn - 1];
ksize = min(2,kn);
lenx = lens_ref(kn, mx);
leny = lens_ref(kn, my);
for (i__ = 1; i__ <= 7; ++i__) {
i__1 = i__ - 1;
i__2 = i__ - 1;
cx[i__1].r = cx1[i__2].r, cx[i__1].i = cx1[i__2].i;
i__1 = i__ - 1;
i__2 = i__ - 1;
cy[i__1].r = cy1[i__2].r, cy[i__1].i = cy1[i__2].i;
/* L20: */
}
if (combla_1.icase == 1) {
zdotc_(&z__1, &combla_1.n, cx, &combla_1.incx, cy, &
combla_1.incy);
cdot[0].r = z__1.r, cdot[0].i = z__1.i;
ctest_(&c__1, cdot, &ct6_ref(kn, ki), &csize1[kn - 1], sfac);
} else if (combla_1.icase == 2) {
zdotu_(&z__1, &combla_1.n, cx, &combla_1.incx, cy, &
combla_1.incy);
cdot[0].r = z__1.r, cdot[0].i = z__1.i;
ctest_(&c__1, cdot, &ct7_ref(kn, ki), &csize1[kn - 1], sfac);
} else if (combla_1.icase == 3) {
zaxpy_(&combla_1.n, &ca, cx, &combla_1.incx, cy, &
combla_1.incy);
ctest_(&leny, cy, &ct8_ref(1, kn, ki), &csize2_ref(1, ksize),
sfac);
} else if (combla_1.icase == 4) {
zcopy_(&combla_1.n, cx, &combla_1.incx, cy, &combla_1.incy);
ctest_(&leny, cy, &ct10y_ref(1, kn, ki), csize3, &c_b43);
} else if (combla_1.icase == 5) {
zswap_(&combla_1.n, cx, &combla_1.incx, cy, &combla_1.incy);
ctest_(&lenx, cx, &ct10x_ref(1, kn, ki), csize3, &c_b43);
ctest_(&leny, cy, &ct10y_ref(1, kn, ki), csize3, &c_b43);
} else {
s_wsle(&io___48);
do_lio(&c__9, &c__1, " Shouldn't be here in CHECK2", (ftnlen)
28);
e_wsle();
s_stop("", (ftnlen)0);
}
/* L40: */
}
/* L60: */
}
return 0;
} /* check2_ */
