int32_t invert_matrix_checked(__CLPK_integer dim, double* matrix, MATRIX_INVERT_BUF1_TYPE* int_1d_buf, double* dbl_2d_buf) {
// This used to fall back on PLINK 1.07's SVD-based implementation when the
// rcond estimate was too small, but in practice that just slowed things down
// without meaningfully improving inversion of nonsingular matrices. So now
// this just exits a bit earlier, while leaving the old "binary search for
// the first row/column causing multicollinearity" logic to the caller.
__CLPK_integer lwork = dim * dim;
char cc = '1';
double norm = dlange_(&cc, &dim, &dim, matrix, &dim, dbl_2d_buf);
__CLPK_integer info;
double rcond;
dgetrf_(&dim, &dim, matrix, &dim, int_1d_buf, &info);
if (info > 0) {
return 1;
}
dgecon_(&cc, &dim, matrix, &dim, &norm, &rcond, dbl_2d_buf, &(int_1d_buf[dim]), &info);
if (rcond < MATRIX_SINGULAR_RCOND) {
return 1;
}
dgetri_(&dim, matrix, &dim, int_1d_buf, dbl_2d_buf, &lwork, &info);
return 0;
}
doublereal dtzt01_(integer *m, integer *n, doublereal *a, doublereal *af,
integer *lda, doublereal *tau, doublereal *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
doublereal ret_val;
/* Local variables */
integer i__, j;
doublereal norma;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
doublereal rwork[1];
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), dlatzm_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, 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 */
/* ======= */
/* DTZT01 returns */
/* || A - R*Q || / ( M * eps * ||A|| ) */
/* for an upper trapezoidal A that was factored with DTZRQF. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrices A and AF. */
/* N (input) INTEGER */
/* The number of columns of the matrices A and AF. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The original upper trapezoidal M by N matrix A. */
/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The output of DTZRQF for input matrix A. */
/* The lower triangle is not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A and AF. */
/* TAU (input) DOUBLE PRECISION array, dimension (M) */
/* Details of the Householder transformations as returned by */
/* DTZRQF. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= m*n + m. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
ret_val = 0.;
if (*lwork < *m * *n + *m) {
xerbla_("DTZT01", &c__8);
return ret_val;
}
/* Quick return if possible */
if (*m <= 0 || *n <= 0) {
return ret_val;
}
norma = dlange_("One-norm", m, n, &a[a_offset], lda, rwork);
/* Copy upper triangle R */
dlaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
work[(j - 1) * *m + i__] = af[i__ + j * af_dim1];
/* L10: */
}
/* L20: */
}
/* R = R * P(1) * ... *P(m) */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n - *m + 1;
dlatzm_("Right", &i__, &i__2, &af[i__ + (*m + 1) * af_dim1], lda, &
tau[i__], &work[(i__ - 1) * *m + 1], &work[*m * *m + 1], m, &
work[*m * *n + 1]);
/* L30: */
}
/* R = R - A */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
daxpy_(m, &c_b13, &a[i__ * a_dim1 + 1], &c__1, &work[(i__ - 1) * *m +
1], &c__1);
/* L40: */
}
ret_val = dlange_("One-norm", m, n, &work[1], m, rwork);
ret_val /= dlamch_("Epsilon") * (doublereal) max(*m,*n);
if (norma != 0.) {
ret_val /= norma;
}
return ret_val;
/* End of DTZT01 */
} /* dtzt01_ */
/* Subroutine */ int dlaqtr_(logical *ltran, logical *lreal, integer *n,
doublereal *t, integer *ldt, doublereal *b, doublereal *w, doublereal
*scale, doublereal *x, doublereal *work, integer *info)
{
/* System generated locals */
integer t_dim1, t_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
/* Local variables */
doublereal d__[4] /* was [2][2] */;
integer i__, j, k;
doublereal v[4] /* was [2][2] */, z__;
integer j1, j2, n1, n2;
doublereal si, xj, sr, rec, eps, tjj, tmp;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
integer ierr;
doublereal smin, xmax;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern doublereal dasum_(integer *, doublereal *, integer *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
integer jnext;
doublereal sminw, xnorm;
extern /* Subroutine */ int dlaln2_(logical *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *
, doublereal *, integer *, doublereal *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern integer idamax_(integer *, doublereal *, integer *);
doublereal scaloc;
extern /* Subroutine */ int dladiv_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *);
doublereal bignum;
logical notran;
doublereal smlnum;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAQTR solves the real quasi-triangular system */
/* op(T)*p = scale*c, if LREAL = .TRUE. */
/* or the complex quasi-triangular systems */
/* op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE. */
/* in real arithmetic, where T is upper quasi-triangular. */
/* If LREAL = .FALSE., then the first diagonal block of T must be */
/* 1 by 1, B is the specially structured matrix */
/* B = [ b(1) b(2) ... b(n) ] */
/* [ w ] */
/* [ w ] */
/* [ . ] */
/* [ w ] */
/* op(A) = A or A', A' denotes the conjugate transpose of */
/* matrix A. */
/* On input, X = [ c ]. On output, X = [ p ]. */
/* [ d ] [ q ] */
/* This subroutine is designed for the condition number estimation */
/* in routine DTRSNA. */
/* Arguments */
/* ========= */
/* LTRAN (input) LOGICAL */
/* On entry, LTRAN specifies the option of conjugate transpose: */
/* = .FALSE., op(T+i*B) = T+i*B, */
/* = .TRUE., op(T+i*B) = (T+i*B)'. */
/* LREAL (input) LOGICAL */
/* On entry, LREAL specifies the input matrix structure: */
/* = .FALSE., the input is complex */
/* = .TRUE., the input is real */
/* N (input) INTEGER */
/* On entry, N specifies the order of T+i*B. N >= 0. */
/* T (input) DOUBLE PRECISION array, dimension (LDT,N) */
/* On entry, T contains a matrix in Schur canonical form. */
/* If LREAL = .FALSE., then the first diagonal block of T mu */
/* be 1 by 1. */
/* LDT (input) INTEGER */
/* The leading dimension of the matrix T. LDT >= max(1,N). */
/* B (input) DOUBLE PRECISION array, dimension (N) */
/* On entry, B contains the elements to form the matrix */
/* B as described above. */
/* If LREAL = .TRUE., B is not referenced. */
/* W (input) DOUBLE PRECISION */
/* On entry, W is the diagonal element of the matrix B. */
/* If LREAL = .TRUE., W is not referenced. */
/* SCALE (output) DOUBLE PRECISION */
/* On exit, SCALE is the scale factor. */
/* X (input/output) DOUBLE PRECISION array, dimension (2*N) */
/* On entry, X contains the right hand side of the system. */
/* On exit, X is overwritten by the solution. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* On exit, INFO is set to */
/* 0: successful exit. */
/* 1: the some diagonal 1 by 1 block has been perturbed by */
/* a small number SMIN to keep nonsingularity. */
/* 2: the some diagonal 2 by 2 block has been perturbed by */
/* a small number in DLALN2 to keep nonsingularity. */
/* NOTE: In the interests of speed, this routine does not */
/* check the inputs for errors. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Do not test the input parameters for errors */
/* Parameter adjustments */
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
--b;
--x;
--work;
/* Function Body */
notran = ! (*ltran);
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Set constants to control overflow */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
bignum = 1. / smlnum;
xnorm = dlange_("M", n, n, &t[t_offset], ldt, d__);
if (! (*lreal)) {
/* Computing MAX */
d__1 = xnorm, d__2 = abs(*w), d__1 = max(d__1,d__2), d__2 = dlange_(
"M", n, &c__1, &b[1], n, d__);
xnorm = max(d__1,d__2);
}
/* Computing MAX */
d__1 = smlnum, d__2 = eps * xnorm;
smin = max(d__1,d__2);
/* Compute 1-norm of each column of strictly upper triangular */
/* part of T to control overflow in triangular solver. */
work[1] = 0.;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
work[j] = dasum_(&i__2, &t[j * t_dim1 + 1], &c__1);
/* L10: */
}
if (! (*lreal)) {
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
work[i__] += (d__1 = b[i__], abs(d__1));
/* L20: */
}
}
n2 = *n << 1;
n1 = *n;
if (! (*lreal)) {
n1 = n2;
}
k = idamax_(&n1, &x[1], &c__1);
xmax = (d__1 = x[k], abs(d__1));
*scale = 1.;
if (xmax > bignum) {
*scale = bignum / xmax;
dscal_(&n1, scale, &x[1], &c__1);
xmax = bignum;
}
if (*lreal) {
if (notran) {
/* Solve T*p = scale*c */
jnext = *n;
for (j = *n; j >= 1; --j) {
if (j > jnext) {
goto L30;
}
j1 = j;
j2 = j;
jnext = j - 1;
if (j > 1) {
if (t[j + (j - 1) * t_dim1] != 0.) {
j1 = j - 1;
jnext = j - 2;
}
}
if (j1 == j2) {
/* Meet 1 by 1 diagonal block */
/* Scale to avoid overflow when computing */
/* x(j) = b(j)/T(j,j) */
xj = (d__1 = x[j1], abs(d__1));
tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1));
tmp = t[j1 + j1 * t_dim1];
if (tjj < smin) {
tmp = smin;
tjj = smin;
*info = 1;
}
if (xj == 0.) {
goto L30;
}
if (tjj < 1.) {
if (xj > bignum * tjj) {
rec = 1. / xj;
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j1] /= tmp;
xj = (d__1 = x[j1], abs(d__1));
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j1 of T. */
if (xj > 1.) {
rec = 1. / xj;
if (work[j1] > (bignum - xmax) * rec) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
}
if (j1 > 1) {
i__1 = j1 - 1;
d__1 = -x[j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
k = idamax_(&i__1, &x[1], &c__1);
xmax = (d__1 = x[k], abs(d__1));
}
} else {
/* Meet 2 by 2 diagonal block */
/* Call 2 by 2 linear system solve, to take */
/* care of possible overflow by scaling factor. */
d__[0] = x[j1];
d__[1] = x[j2];
dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1
* t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &
c_b25, &c_b25, v, &c__2, &scaloc, &xnorm, &ierr);
if (ierr != 0) {
*info = 2;
}
if (scaloc != 1.) {
dscal_(n, &scaloc, &x[1], &c__1);
*scale *= scaloc;
}
x[j1] = v[0];
x[j2] = v[1];
/* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2)) */
/* to avoid overflow in updating right-hand side. */
/* Computing MAX */
d__1 = abs(v[0]), d__2 = abs(v[1]);
xj = max(d__1,d__2);
if (xj > 1.) {
rec = 1. / xj;
/* Computing MAX */
d__1 = work[j1], d__2 = work[j2];
if (max(d__1,d__2) > (bignum - xmax) * rec) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
}
/* Update right-hand side */
if (j1 > 1) {
i__1 = j1 - 1;
d__1 = -x[j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
d__1 = -x[j2];
daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
k = idamax_(&i__1, &x[1], &c__1);
xmax = (d__1 = x[k], abs(d__1));
}
}
L30:
;
}
} else {
/* Solve T'*p = scale*c */
jnext = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < jnext) {
goto L40;
}
j1 = j;
j2 = j;
jnext = j + 1;
if (j < *n) {
if (t[j + 1 + j * t_dim1] != 0.) {
j2 = j + 1;
jnext = j + 2;
}
}
if (j1 == j2) {
/* 1 by 1 diagonal block */
/* Scale if necessary to avoid overflow in forming the */
/* right-hand side element by inner product. */
xj = (d__1 = x[j1], abs(d__1));
if (xmax > 1.) {
rec = 1. / xmax;
if (work[j1] > (bignum - xj) * rec) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
x[j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &
c__1);
xj = (d__1 = x[j1], abs(d__1));
tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1));
tmp = t[j1 + j1 * t_dim1];
if (tjj < smin) {
tmp = smin;
tjj = smin;
*info = 1;
}
if (tjj < 1.) {
if (xj > bignum * tjj) {
rec = 1. / xj;
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j1] /= tmp;
/* Computing MAX */
d__2 = xmax, d__3 = (d__1 = x[j1], abs(d__1));
xmax = max(d__2,d__3);
} else {
/* 2 by 2 diagonal block */
/* Scale if necessary to avoid overflow in forming the */
/* right-hand side elements by inner product. */
/* Computing MAX */
d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2],
abs(d__2));
xj = max(d__3,d__4);
if (xmax > 1.) {
rec = 1. / xmax;
/* Computing MAX */
d__1 = work[j2], d__2 = work[j1];
if (max(d__1,d__2) > (bignum - xj) * rec) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
d__[0] = x[j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1,
&x[1], &c__1);
i__2 = j1 - 1;
d__[1] = x[j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &c__1,
&x[1], &c__1);
dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1 *
t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &c_b25,
&c_b25, v, &c__2, &scaloc, &xnorm, &ierr);
if (ierr != 0) {
*info = 2;
}
if (scaloc != 1.) {
dscal_(n, &scaloc, &x[1], &c__1);
*scale *= scaloc;
}
x[j1] = v[0];
x[j2] = v[1];
/* Computing MAX */
d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2],
abs(d__2)), d__3 = max(d__3,d__4);
xmax = max(d__3,xmax);
}
L40:
;
}
}
} else {
/* Computing MAX */
d__1 = eps * abs(*w);
sminw = max(d__1,smin);
if (notran) {
/* Solve (T + iB)*(p+iq) = c+id */
jnext = *n;
for (j = *n; j >= 1; --j) {
if (j > jnext) {
goto L70;
}
j1 = j;
j2 = j;
jnext = j - 1;
if (j > 1) {
if (t[j + (j - 1) * t_dim1] != 0.) {
j1 = j - 1;
jnext = j - 2;
}
}
if (j1 == j2) {
/* 1 by 1 diagonal block */
/* Scale if necessary to avoid overflow in division */
z__ = *w;
if (j1 == 1) {
z__ = b[1];
}
xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs(
d__2));
tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)) + abs(z__);
tmp = t[j1 + j1 * t_dim1];
if (tjj < sminw) {
tmp = sminw;
tjj = sminw;
*info = 1;
}
if (xj == 0.) {
goto L70;
}
if (tjj < 1.) {
if (xj > bignum * tjj) {
rec = 1. / xj;
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
dladiv_(&x[j1], &x[*n + j1], &tmp, &z__, &sr, &si);
x[j1] = sr;
x[*n + j1] = si;
xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs(
d__2));
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j1 of T. */
if (xj > 1.) {
rec = 1. / xj;
if (work[j1] > (bignum - xmax) * rec) {
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
}
}
if (j1 > 1) {
i__1 = j1 - 1;
d__1 = -x[j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
d__1 = -x[*n + j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[*
n + 1], &c__1);
x[1] += b[j1] * x[*n + j1];
x[*n + 1] -= b[j1] * x[j1];
xmax = 0.;
i__1 = j1 - 1;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__3 = xmax, d__4 = (d__1 = x[k], abs(d__1)) + (
d__2 = x[k + *n], abs(d__2));
xmax = max(d__3,d__4);
/* L50: */
}
}
} else {
/* Meet 2 by 2 diagonal block */
d__[0] = x[j1];
d__[1] = x[j2];
d__[2] = x[*n + j1];
d__[3] = x[*n + j2];
d__1 = -(*w);
dlaln2_(&c_false, &c__2, &c__2, &sminw, &c_b21, &t[j1 +
j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &
c_b25, &d__1, v, &c__2, &scaloc, &xnorm, &ierr);
if (ierr != 0) {
*info = 2;
}
if (scaloc != 1.) {
i__1 = *n << 1;
dscal_(&i__1, &scaloc, &x[1], &c__1);
*scale = scaloc * *scale;
}
x[j1] = v[0];
x[j2] = v[1];
x[*n + j1] = v[2];
x[*n + j2] = v[3];
/* Scale X(J1), .... to avoid overflow in */
/* updating right hand side. */
/* Computing MAX */
d__1 = abs(v[0]) + abs(v[2]), d__2 = abs(v[1]) + abs(v[3])
;
xj = max(d__1,d__2);
if (xj > 1.) {
rec = 1. / xj;
/* Computing MAX */
d__1 = work[j1], d__2 = work[j2];
if (max(d__1,d__2) > (bignum - xmax) * rec) {
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
}
}
/* Update the right-hand side. */
if (j1 > 1) {
i__1 = j1 - 1;
d__1 = -x[j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
d__1 = -x[j2];
daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
d__1 = -x[*n + j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[*
n + 1], &c__1);
i__1 = j1 - 1;
d__1 = -x[*n + j2];
daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[*
n + 1], &c__1);
x[1] = x[1] + b[j1] * x[*n + j1] + b[j2] * x[*n + j2];
x[*n + 1] = x[*n + 1] - b[j1] * x[j1] - b[j2] * x[j2];
xmax = 0.;
i__1 = j1 - 1;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__3 = (d__1 = x[k], abs(d__1)) + (d__2 = x[k + *
n], abs(d__2));
xmax = max(d__3,xmax);
/* L60: */
}
}
}
L70:
;
}
} else {
/* Solve (T + iB)'*(p+iq) = c+id */
jnext = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < jnext) {
goto L80;
}
j1 = j;
j2 = j;
jnext = j + 1;
if (j < *n) {
if (t[j + 1 + j * t_dim1] != 0.) {
j2 = j + 1;
jnext = j + 2;
}
}
if (j1 == j2) {
/* 1 by 1 diagonal block */
/* Scale if necessary to avoid overflow in forming the */
/* right-hand side element by inner product. */
xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs(
d__2));
if (xmax > 1.) {
rec = 1. / xmax;
if (work[j1] > (bignum - xj) * rec) {
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
x[j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &
c__1);
i__2 = j1 - 1;
x[*n + j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[
*n + 1], &c__1);
if (j1 > 1) {
x[j1] -= b[j1] * x[*n + 1];
x[*n + j1] += b[j1] * x[1];
}
xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs(
d__2));
z__ = *w;
if (j1 == 1) {
z__ = b[1];
}
/* Scale if necessary to avoid overflow in */
/* complex division */
tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)) + abs(z__);
tmp = t[j1 + j1 * t_dim1];
if (tjj < sminw) {
tmp = sminw;
tjj = sminw;
*info = 1;
}
if (tjj < 1.) {
if (xj > bignum * tjj) {
rec = 1. / xj;
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
d__1 = -z__;
dladiv_(&x[j1], &x[*n + j1], &tmp, &d__1, &sr, &si);
x[j1] = sr;
x[j1 + *n] = si;
/* Computing MAX */
d__3 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n],
abs(d__2));
xmax = max(d__3,xmax);
} else {
/* 2 by 2 diagonal block */
/* Scale if necessary to avoid overflow in forming the */
/* right-hand side element by inner product. */
/* Computing MAX */
d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1],
abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + (
d__4 = x[*n + j2], abs(d__4));
xj = max(d__5,d__6);
if (xmax > 1.) {
rec = 1. / xmax;
/* Computing MAX */
d__1 = work[j1], d__2 = work[j2];
if (max(d__1,d__2) > (bignum - xj) / xmax) {
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
d__[0] = x[j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1,
&x[1], &c__1);
i__2 = j1 - 1;
d__[1] = x[j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &c__1,
&x[1], &c__1);
i__2 = j1 - 1;
d__[2] = x[*n + j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &
c__1, &x[*n + 1], &c__1);
i__2 = j1 - 1;
d__[3] = x[*n + j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &
c__1, &x[*n + 1], &c__1);
d__[0] -= b[j1] * x[*n + 1];
d__[1] -= b[j2] * x[*n + 1];
d__[2] += b[j1] * x[1];
d__[3] += b[j2] * x[1];
dlaln2_(&c_true, &c__2, &c__2, &sminw, &c_b21, &t[j1 + j1
* t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &
c_b25, w, v, &c__2, &scaloc, &xnorm, &ierr);
if (ierr != 0) {
*info = 2;
}
if (scaloc != 1.) {
dscal_(&n2, &scaloc, &x[1], &c__1);
*scale = scaloc * *scale;
}
x[j1] = v[0];
x[j2] = v[1];
x[*n + j1] = v[2];
x[*n + j2] = v[3];
/* Computing MAX */
d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1],
abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + (
d__4 = x[*n + j2], abs(d__4)), d__5 = max(d__5,
d__6);
xmax = max(d__5,xmax);
}
L80:
;
}
}
}
return 0;
/* End of DLAQTR */
} /* dlaqtr_ */
/* Subroutine */ int dgegv_(char *jobvl, char *jobvr, integer *n, doublereal *
a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar,
doublereal *alphai, doublereal *beta, doublereal *vl, integer *ldvl,
doublereal *vr, integer *ldvr, doublereal *work, integer *lwork,
integer *info)
{
/* 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, d__3, d__4;
/* Local variables */
integer jc, nb, in, jr, nb1, nb2, nb3, ihi, ilo;
doublereal eps;
logical ilv;
doublereal absb, anrm, bnrm;
integer itau;
doublereal temp;
logical ilvl, ilvr;
integer lopt;
doublereal anrm1, anrm2, bnrm1, bnrm2, absai, scale, absar, sbeta;
integer ileft, iinfo, icols, iwork, irows;
doublereal salfai;
doublereal salfar;
doublereal safmin;
doublereal safmax;
char chtemp[1];
logical ldumma[1];
integer ijobvl, iright;
logical ilimit;
integer ijobvr;
doublereal onepls;
integer lwkmin;
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine DGGEV. */
/* DGEGV computes the eigenvalues and, optionally, the left and/or right */
/* eigenvectors of a real matrix pair (A,B). */
/* Given two square matrices A and B, */
/* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the */
/* eigenvalues lambda and corresponding (non-zero) eigenvectors x such */
/* that */
/* A*x = lambda*B*x. */
/* An alternate form is to find the eigenvalues mu and corresponding */
/* eigenvectors y such that */
/* mu*A*y = B*y. */
/* These two forms are equivalent with mu = 1/lambda and x = y if */
/* neither lambda nor mu is zero. In order to deal with the case that */
/* lambda or mu is zero or small, two values alpha and beta are returned */
/* for each eigenvalue, such that lambda = alpha/beta and */
/* mu = beta/alpha. */
/* The vectors x and y in the above equations are right eigenvectors of */
/* the matrix pair (A,B). Vectors u and v satisfying */
/* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B */
/* are left eigenvectors of (A,B). */
/* Note: this routine performs "full balancing" on A and B -- see */
/* "Further Details", below. */
/* Arguments */
/* ========= */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': do not compute the left generalized eigenvectors; */
/* = 'V': compute the left generalized eigenvectors (returned */
/* in VL). */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': do not compute the right generalized eigenvectors; */
/* = 'V': compute the right generalized eigenvectors (returned */
/* in VR). */
/* N (input) INTEGER */
/* The order of the matrices A, B, VL, and VR. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
/* On entry, the matrix A. */
/* If JOBVL = 'V' or JOBVR = 'V', then on exit A */
/* contains the real Schur form of A from the generalized Schur */
/* factorization of the pair (A,B) after balancing. */
/* If no eigenvectors were computed, then only the diagonal */
/* blocks from the Schur form will be correct. See DGGHRD and */
/* DHGEQZ for details. */
/* LDA (input) INTEGER */
/* The leading dimension of A. LDA >= max(1,N). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */
/* On entry, the matrix B. */
/* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the */
/* upper triangular matrix obtained from B in the generalized */
/* Schur factorization of the pair (A,B) after balancing. */
/* If no eigenvectors were computed, then only those elements of */
/* B corresponding to the diagonal blocks from the Schur form of */
/* A will be correct. See DGGHRD and DHGEQZ for details. */
/* LDB (input) INTEGER */
/* The leading dimension of B. LDB >= max(1,N). */
/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
/* The real parts of each scalar alpha defining an eigenvalue of */
/* GNEP. */
/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
/* The imaginary parts of each scalar alpha defining an */
/* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */
/* eigenvalue is real; if positive, then the j-th and */
/* (j+1)-st eigenvalues are a complex conjugate pair, with */
/* ALPHAI(j+1) = -ALPHAI(j). */
/* BETA (output) DOUBLE PRECISION array, dimension (N) */
/* The scalars beta that define the eigenvalues of GNEP. */
/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */
/* beta = BETA(j) represent the j-th eigenvalue of the matrix */
/* pair (A,B), in one of the forms lambda = alpha/beta or */
/* mu = beta/alpha. Since either lambda or mu may overflow, */
/* they should not, in general, be computed. */
/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored */
/* in the columns of VL, in the same order as their eigenvalues. */
/* If the j-th eigenvalue is real, then u(j) = VL(:,j). */
/* If the j-th and (j+1)-st eigenvalues form a complex conjugate */
/* pair, then */
/* u(j) = VL(:,j) + i*VL(:,j+1) */
/* and */
/* u(j+1) = VL(:,j) - i*VL(:,j+1). */
/* Each eigenvector is scaled so that its largest component has */
/* abs(real part) + abs(imag. part) = 1, except for eigenvectors */
/* corresponding to an eigenvalue with alpha = beta = 0, which */
/* are set to zero. */
/* Not referenced if JOBVL = 'N'. */
/* LDVL (input) INTEGER */
/* The leading dimension of the matrix VL. LDVL >= 1, and */
/* if JOBVL = 'V', LDVL >= N. */
/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors x(j) are stored */
/* in the columns of VR, in the same order as their eigenvalues. */
/* If the j-th eigenvalue is real, then x(j) = VR(:,j). */
/* If the j-th and (j+1)-st eigenvalues form a complex conjugate */
/* pair, then */
/* x(j) = VR(:,j) + i*VR(:,j+1) */
/* and */
/* x(j+1) = VR(:,j) - i*VR(:,j+1). */
/* Each eigenvector is scaled so that its largest component has */
/* abs(real part) + abs(imag. part) = 1, except for eigenvalues */
/* corresponding to an eigenvalue with alpha = beta = 0, which */
/* are set to zero. */
/* Not referenced if JOBVR = 'N'. */
/* LDVR (input) INTEGER */
/* The leading dimension of the matrix VR. LDVR >= 1, and */
/* if JOBVR = 'V', LDVR >= N. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,8*N). */
/* For good performance, LWORK must generally be larger. */
/* To compute the optimal value of LWORK, call ILAENV to get */
/* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute: */
/* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR; */
/* The optimal LWORK is: */
/* 2*N + MAX( 6*N, N*(NB+1) ). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* The QZ iteration failed. No eigenvectors have been */
/* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */
/* > N: errors that usually indicate LAPACK problems: */
/* =N+1: error return from DGGBAL */
/* =N+2: error return from DGEQRF */
/* =N+3: error return from DORMQR */
/* =N+4: error return from DORGQR */
/* =N+5: error return from DGGHRD */
/* =N+6: error return from DHGEQZ (other than failed */
/* iteration) */
/* =N+7: error return from DTGEVC */
/* =N+8: error return from DGGBAK (computing VL) */
/* =N+9: error return from DGGBAK (computing VR) */
/* =N+10: error return from DLASCL (various calls) */
/* Further Details */
/* =============== */
/* Balancing */
/* --------- */
/* This driver calls DGGBAL to both permute and scale rows and columns */
/* of A and B. The permutations PL and PR are chosen so that PL*A*PR */
/* and PL*B*R will be upper triangular except for the diagonal blocks */
/* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as */
/* possible. The diagonal scaling matrices DL and DR are chosen so */
/* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to */
/* one (except for the elements that start out zero.) */
/* After the eigenvalues and eigenvectors of the balanced matrices */
/* have been computed, DGGBAK transforms the eigenvectors back to what */
/* they would have been (in perfect arithmetic) if they had not been */
/* balanced. */
/* Contents of A and B on Exit */
/* -------- -- - --- - -- ---- */
/* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or */
/* both), then on exit the arrays A and B will contain the real Schur */
/* form[*] of the "balanced" versions of A and B. If no eigenvectors */
/* are computed, then only the diagonal blocks will be correct. */
/* [*] See DHGEQZ, DGEGS, or read the book "Matrix Computations", */
/* by Golub & van Loan, pub. by Johns Hopkins U. Press. */
/* ===================================================================== */
/* Decode the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alphar;
--alphai;
--beta;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--work;
/* Function Body */
if (lsame_(jobvl, "N")) {
ijobvl = 1;
ilvl = FALSE_;
} else if (lsame_(jobvl, "V")) {
ijobvl = 2;
ilvl = TRUE_;
} else {
ijobvl = -1;
ilvl = FALSE_;
}
if (lsame_(jobvr, "N")) {
ijobvr = 1;
ilvr = FALSE_;
} else if (lsame_(jobvr, "V")) {
ijobvr = 2;
ilvr = TRUE_;
} else {
ijobvr = -1;
ilvr = FALSE_;
}
ilv = ilvl || ilvr;
/* Test the input arguments */
/* Computing MAX */
i__1 = *n << 3;
lwkmin = max(i__1,1);
lwkopt = lwkmin;
work[1] = (doublereal) lwkopt;
lquery = *lwork == -1;
*info = 0;
if (ijobvl <= 0) {
*info = -1;
} else if (ijobvr <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || ilvl && *ldvl < *n) {
*info = -12;
} else if (*ldvr < 1 || ilvr && *ldvr < *n) {
*info = -14;
} else if (*lwork < lwkmin && ! lquery) {
*info = -16;
}
if (*info == 0) {
nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, n, &c_n1, &c_n1);
nb2 = ilaenv_(&c__1, "DORMQR", " ", n, n, n, &c_n1);
nb3 = ilaenv_(&c__1, "DORGQR", " ", n, n, n, &c_n1);
/* Computing MAX */
i__1 = max(nb1,nb2);
nb = max(i__1,nb3);
/* Computing MAX */
i__1 = *n * 6, i__2 = *n * (nb + 1);
lopt = (*n << 1) + max(i__1,i__2);
work[1] = (doublereal) lopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEGV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("E") * dlamch_("B");
safmin = dlamch_("S");
safmin += safmin;
safmax = 1. / safmin;
onepls = eps * 4 + 1.;
/* Scale A */
anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]);
anrm1 = anrm;
anrm2 = 1.;
if (anrm < 1.) {
if (safmax * anrm < 1.) {
anrm1 = safmin;
anrm2 = safmax * anrm;
}
}
if (anrm > 0.) {
dlascl_("G", &c_n1, &c_n1, &anrm, &c_b27, n, n, &a[a_offset], lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 10;
return 0;
}
}
/* Scale B */
bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]);
bnrm1 = bnrm;
bnrm2 = 1.;
if (bnrm < 1.) {
if (safmax * bnrm < 1.) {
bnrm1 = safmin;
bnrm2 = safmax * bnrm;
}
}
if (bnrm > 0.) {
dlascl_("G", &c_n1, &c_n1, &bnrm, &c_b27, n, n, &b[b_offset], ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 10;
return 0;
}
}
/* Permute the matrix to make it more nearly triangular */
/* Workspace layout: (8*N words -- "work" requires 6*N words) */
ileft = 1;
iright = *n + 1;
iwork = iright + *n;
dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
ileft], &work[iright], &work[iwork], &iinfo);
if (iinfo != 0) {
*info = *n + 1;
goto L120;
}
/* Reduce B to triangular form, and initialize VL and/or VR */
irows = ihi + 1 - ilo;
if (ilv) {
icols = *n + 1 - ilo;
} else {
icols = irows;
}
itau = iwork;
iwork = itau + irows;
i__1 = *lwork + 1 - iwork;
dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 2;
goto L120;
}
i__1 = *lwork + 1 - iwork;
dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, &
iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 3;
goto L120;
}
if (ilvl) {
dlaset_("Full", n, n, &c_b38, &c_b27, &vl[vl_offset], ldvl)
;
i__1 = irows - 1;
i__2 = irows - 1;
dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[ilo +
1 + ilo * vl_dim1], ldvl);
i__1 = *lwork + 1 - iwork;
dorgqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[
itau], &work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 4;
goto L120;
}
}
if (ilvr) {
dlaset_("Full", n, n, &c_b38, &c_b27, &vr[vr_offset], ldvr)
;
}
/* Reduce to generalized Hessenberg form */
if (ilv) {
/* Eigenvectors requested -- work on whole matrix. */
dgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &iinfo);
} else {
dgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda,
&b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
vr_offset], ldvr, &iinfo);
}
if (iinfo != 0) {
*info = *n + 5;
goto L120;
}
/* Perform QZ algorithm */
iwork = itau;
if (ilv) {
*(unsigned char *)chtemp = 'S';
} else {
*(unsigned char *)chtemp = 'E';
}
i__1 = *lwork + 1 - iwork;
dhgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[
b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
if (iinfo > 0 && iinfo <= *n) {
*info = iinfo;
} else if (iinfo > *n && iinfo <= *n << 1) {
*info = iinfo - *n;
} else {
*info = *n + 6;
}
goto L120;
}
if (ilv) {
/* Compute Eigenvectors (DTGEVC requires 6*N words of workspace) */
if (ilvl) {
if (ilvr) {
*(unsigned char *)chtemp = 'B';
} else {
*(unsigned char *)chtemp = 'L';
}
} else {
*(unsigned char *)chtemp = 'R';
}
dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb,
&vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[
iwork], &iinfo);
if (iinfo != 0) {
*info = *n + 7;
goto L120;
}
/* Undo balancing on VL and VR, rescale */
if (ilvl) {
dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &
vl[vl_offset], ldvl, &iinfo);
if (iinfo != 0) {
*info = *n + 8;
goto L120;
}
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
if (alphai[jc] < 0.) {
goto L50;
}
temp = 0.;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = vl[jr + jc * vl_dim1],
abs(d__1));
temp = max(d__2,d__3);
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__3 = temp, d__4 = (d__1 = vl[jr + jc * vl_dim1],
abs(d__1)) + (d__2 = vl[jr + (jc + 1) *
vl_dim1], abs(d__2));
temp = max(d__3,d__4);
}
}
if (temp < safmin) {
goto L50;
}
temp = 1. / temp;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vl[jr + jc * vl_dim1] *= temp;
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vl[jr + jc * vl_dim1] *= temp;
vl[jr + (jc + 1) * vl_dim1] *= temp;
}
}
L50:
;
}
}
if (ilvr) {
dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &
vr[vr_offset], ldvr, &iinfo);
if (iinfo != 0) {
*info = *n + 9;
goto L120;
}
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
if (alphai[jc] < 0.) {
goto L100;
}
temp = 0.;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = vr[jr + jc * vr_dim1],
abs(d__1));
temp = max(d__2,d__3);
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__3 = temp, d__4 = (d__1 = vr[jr + jc * vr_dim1],
abs(d__1)) + (d__2 = vr[jr + (jc + 1) *
vr_dim1], abs(d__2));
temp = max(d__3,d__4);
}
}
if (temp < safmin) {
goto L100;
}
temp = 1. / temp;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vr[jr + jc * vr_dim1] *= temp;
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vr[jr + jc * vr_dim1] *= temp;
vr[jr + (jc + 1) * vr_dim1] *= temp;
}
}
L100:
;
}
}
/* End of eigenvector calculation */
}
/* Undo scaling in alpha, beta */
/* Note: this does not give the alpha and beta for the unscaled */
/* problem. */
/* Un-scaling is limited to avoid underflow in alpha and beta */
/* if they are significant. */
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
absar = (d__1 = alphar[jc], abs(d__1));
absai = (d__1 = alphai[jc], abs(d__1));
absb = (d__1 = beta[jc], abs(d__1));
salfar = anrm * alphar[jc];
salfai = anrm * alphai[jc];
sbeta = bnrm * beta[jc];
ilimit = FALSE_;
scale = 1.;
/* Check for significant underflow in ALPHAI */
/* Computing MAX */
d__1 = safmin, d__2 = eps * absar, d__1 = max(d__1,d__2), d__2 = eps *
absb;
if (abs(salfai) < safmin && absai >= max(d__1,d__2)) {
ilimit = TRUE_;
/* Computing MAX */
d__1 = onepls * safmin, d__2 = anrm2 * absai;
scale = onepls * safmin / anrm1 / max(d__1,d__2);
} else if (salfai == 0.) {
/* If insignificant underflow in ALPHAI, then make the */
/* conjugate eigenvalue real. */
if (alphai[jc] < 0. && jc > 1) {
alphai[jc - 1] = 0.;
} else if (alphai[jc] > 0. && jc < *n) {
alphai[jc + 1] = 0.;
}
}
/* Check for significant underflow in ALPHAR */
/* Computing MAX */
d__1 = safmin, d__2 = eps * absai, d__1 = max(d__1,d__2), d__2 = eps *
absb;
if (abs(salfar) < safmin && absar >= max(d__1,d__2)) {
ilimit = TRUE_;
/* Computing MAX */
/* Computing MAX */
d__3 = onepls * safmin, d__4 = anrm2 * absar;
d__1 = scale, d__2 = onepls * safmin / anrm1 / max(d__3,d__4);
scale = max(d__1,d__2);
}
/* Check for significant underflow in BETA */
/* Computing MAX */
d__1 = safmin, d__2 = eps * absar, d__1 = max(d__1,d__2), d__2 = eps *
absai;
if (abs(sbeta) < safmin && absb >= max(d__1,d__2)) {
ilimit = TRUE_;
/* Computing MAX */
/* Computing MAX */
d__3 = onepls * safmin, d__4 = bnrm2 * absb;
d__1 = scale, d__2 = onepls * safmin / bnrm1 / max(d__3,d__4);
scale = max(d__1,d__2);
}
/* Check for possible overflow when limiting scaling */
if (ilimit) {
/* Computing MAX */
d__1 = abs(salfar), d__2 = abs(salfai), d__1 = max(d__1,d__2),
d__2 = abs(sbeta);
temp = scale * safmin * max(d__1,d__2);
if (temp > 1.) {
scale /= temp;
}
if (scale < 1.) {
ilimit = FALSE_;
}
}
/* Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary. */
if (ilimit) {
salfar = scale * alphar[jc] * anrm;
salfai = scale * alphai[jc] * anrm;
sbeta = scale * beta[jc] * bnrm;
}
alphar[jc] = salfar;
alphai[jc] = salfai;
beta[jc] = sbeta;
}
L120:
work[1] = (doublereal) lwkopt;
return 0;
/* End of DGEGV */
} /* dgegv_ */
DLLEXPORT double d_matrix_norm(char norm, MKL_INT m, MKL_INT n, double a[], double work[])
{
return dlange_(&norm, &m, &n, a, &m, work);
}
doublereal dqrt12_(integer *m, integer *n, doublereal *a, integer *lda,
doublereal *s, doublereal *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal ret_val;
/* Local variables */
integer i__, j, mn, iscl, info;
doublereal anrm;
extern doublereal dnrm2_(integer *, doublereal *, integer *), dasum_(
integer *, doublereal *, integer *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), dgebd2_(integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *
, doublereal *, doublereal *, integer *);
doublereal dummy[1];
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), dbdsqr_(char *, integer *,
integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *);
doublereal bignum, smlnum, nrmsvl;
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DQRT12 computes the singular values `svlues' of the upper trapezoid */
/* of A(1:M,1:N) and returns the ratio */
/* || s - svlues||/(||svlues||*eps*max(M,N)) */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The M-by-N matrix A. Only the upper trapezoid is referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* S (input) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The singular values of the matrix A. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= max(M*N + 4*min(M,N) + */
/* max(M,N), M*N+2*MIN( M, N )+4*N). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--s;
--work;
/* Function Body */
ret_val = 0.;
/* Test that enough workspace is supplied */
/* Computing MAX */
i__1 = *m * *n + (min(*m,*n) << 2) + max(*m,*n), i__2 = *m * *n + (min(*m,
*n) << 1) + (*n << 2);
if (*lwork < max(i__1,i__2)) {
xerbla_("DQRT12", &c__7);
return ret_val;
}
/* Quick return if possible */
mn = min(*m,*n);
if ((doublereal) mn <= 0.) {
return ret_val;
}
nrmsvl = dnrm2_(&mn, &s[1], &c__1);
/* Copy upper triangle of A into work */
dlaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
work[(j - 1) * *m + i__] = a[i__ + j * a_dim1];
/* L10: */
}
/* L20: */
}
/* Get machine parameters */
smlnum = dlamch_("S") / dlamch_("P");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Scale work if max entry outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", m, n, &work[1], m, dummy);
iscl = 0;
if (anrm > 0. && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &work[1], m, &info);
iscl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &work[1], m, &info);
iscl = 1;
}
if (anrm != 0.) {
/* Compute SVD of work */
dgebd2_(m, n, &work[1], m, &work[*m * *n + 1], &work[*m * *n + mn + 1]
, &work[*m * *n + (mn << 1) + 1], &work[*m * *n + mn * 3 + 1],
&work[*m * *n + (mn << 2) + 1], &info);
dbdsqr_("Upper", &mn, &c__0, &c__0, &c__0, &work[*m * *n + 1], &work[*
m * *n + mn + 1], dummy, &mn, dummy, &c__1, dummy, &mn, &work[
*m * *n + (mn << 1) + 1], &info);
if (iscl == 1) {
if (anrm > bignum) {
dlascl_("G", &c__0, &c__0, &bignum, &anrm, &mn, &c__1, &work[*
m * *n + 1], &mn, &info);
}
if (anrm < smlnum) {
dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &mn, &c__1, &work[*
m * *n + 1], &mn, &info);
}
}
} else {
i__1 = mn;
for (i__ = 1; i__ <= i__1; ++i__) {
work[*m * *n + i__] = 0.;
/* L30: */
}
}
/* Compare s and singular values of work */
daxpy_(&mn, &c_b33, &s[1], &c__1, &work[*m * *n + 1], &c__1);
ret_val = dasum_(&mn, &work[*m * *n + 1], &c__1) / (dlamch_("Epsilon") * (doublereal) max(*m,*n));
if (nrmsvl != 0.) {
ret_val /= nrmsvl;
}
return ret_val;
/* End of DQRT12 */
} /* dqrt12_ */
/* Subroutine */ int dlaexc_(logical *wantq, integer *n, doublereal *t,
integer *ldt, doublereal *q, integer *ldq, integer *j1, integer *n1,
integer *n2, doublereal *work, 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
February 29, 1992
Purpose
=======
DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
an upper quasi-triangular matrix T by an orthogonal similarity
transformation.
T must be in Schur canonical form, that is, block upper triangular
with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
has its diagonal elemnts equal and its off-diagonal elements of
opposite sign.
Arguments
=========
WANTQ (input) LOGICAL
= .TRUE. : accumulate the transformation in the matrix Q;
= .FALSE.: do not accumulate the transformation.
N (input) INTEGER
The order of the matrix T. N >= 0.
T (input/output) DOUBLE PRECISION array, dimension (LDT,N)
On entry, the upper quasi-triangular matrix T, in Schur
canonical form.
On exit, the updated matrix T, again in Schur canonical form.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= max(1,N).
Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
On entry, if WANTQ is .TRUE., the orthogonal matrix Q.
On exit, if WANTQ is .TRUE., the updated matrix Q.
If WANTQ is .FALSE., Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q.
LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.
J1 (input) INTEGER
The index of the first row of the first block T11.
N1 (input) INTEGER
The order of the first block T11. N1 = 0, 1 or 2.
N2 (input) INTEGER
The order of the second block T22. N2 = 0, 1 or 2.
WORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
= 1: the transformed matrix T would be too far from Schur
form; the blocks are not swapped and T and Q are
unchanged.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c__4 = 4;
static logical c_false = FALSE_;
static integer c_n1 = -1;
static integer c__2 = 2;
static integer c__3 = 3;
/* System generated locals */
integer q_dim1, q_offset, t_dim1, t_offset, i__1;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
/* Local variables */
static integer ierr;
static doublereal temp;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static doublereal d__[16] /* was [4][4] */;
static integer k;
static doublereal u[3], scale, x[4] /* was [2][2] */, dnorm;
static integer j2, j3, j4;
static doublereal xnorm, u1[3], u2[3];
extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), dlasy2_(
logical *, logical *, integer *, integer *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
static integer nd;
static doublereal cs, t11, t22;
extern doublereal dlamch_(char *);
static doublereal t33;
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
static doublereal sn;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), dlarfx_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *);
static doublereal thresh, smlnum, wi1, wi2, wr1, wr2, eps, tau, tau1,
tau2;
#define d___ref(a_1,a_2) d__[(a_2)*4 + a_1 - 5]
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*2 + a_1 - 3]
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0 || *n1 == 0 || *n2 == 0) {
return 0;
}
if (*j1 + *n1 > *n) {
return 0;
}
j2 = *j1 + 1;
j3 = *j1 + 2;
j4 = *j1 + 3;
if (*n1 == 1 && *n2 == 1) {
/* Swap two 1-by-1 blocks. */
t11 = t_ref(*j1, *j1);
t22 = t_ref(j2, j2);
/* Determine the transformation to perform the interchange. */
d__1 = t22 - t11;
dlartg_(&t_ref(*j1, j2), &d__1, &cs, &sn, &temp);
/* Apply transformation to the matrix T. */
if (j3 <= *n) {
i__1 = *n - *j1 - 1;
drot_(&i__1, &t_ref(*j1, j3), ldt, &t_ref(j2, j3), ldt, &cs, &sn);
}
i__1 = *j1 - 1;
drot_(&i__1, &t_ref(1, *j1), &c__1, &t_ref(1, j2), &c__1, &cs, &sn);
t_ref(*j1, *j1) = t22;
t_ref(j2, j2) = t11;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
drot_(n, &q_ref(1, *j1), &c__1, &q_ref(1, j2), &c__1, &cs, &sn);
}
} else {
/* Swapping involves at least one 2-by-2 block.
Copy the diagonal block of order N1+N2 to the local array D
and compute its norm. */
nd = *n1 + *n2;
dlacpy_("Full", &nd, &nd, &t_ref(*j1, *j1), ldt, d__, &c__4);
dnorm = dlange_("Max", &nd, &nd, d__, &c__4, &work[1]);
/* Compute machine-dependent threshold for test for accepting
swap. */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
/* Computing MAX */
d__1 = eps * 10. * dnorm;
thresh = max(d__1,smlnum);
/* Solve T11*X - X*T22 = scale*T12 for X. */
dlasy2_(&c_false, &c_false, &c_n1, n1, n2, d__, &c__4, &d___ref(*n1 +
1, *n1 + 1), &c__4, &d___ref(1, *n1 + 1), &c__4, &scale, x, &
c__2, &xnorm, &ierr);
/* Swap the adjacent diagonal blocks. */
k = *n1 + *n1 + *n2 - 3;
switch (k) {
case 1: goto L10;
case 2: goto L20;
case 3: goto L30;
}
L10:
/* N1 = 1, N2 = 2: generate elementary reflector H so that:
( scale, X11, X12 ) H = ( 0, 0, * ) */
u[0] = scale;
u[1] = x_ref(1, 1);
u[2] = x_ref(1, 2);
dlarfg_(&c__3, &u[2], u, &c__1, &tau);
u[2] = 1.;
t11 = t_ref(*j1, *j1);
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
d__4 = (d__1 = d___ref(3, 1), abs(d__1)), d__5 = (d__2 = d___ref(3, 2)
, abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = d___ref(3,
3) - t11, abs(d__3));
if (max(d__4,d__5) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u, &tau, &t_ref(*j1, *j1), ldt, &work[1]);
dlarfx_("R", &j2, &c__3, u, &tau, &t_ref(1, *j1), ldt, &work[1]);
t_ref(j3, *j1) = 0.;
t_ref(j3, j2) = 0.;
t_ref(j3, j3) = t11;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("R", n, &c__3, u, &tau, &q_ref(1, *j1), ldq, &work[1]);
}
goto L40;
L20:
/* N1 = 2, N2 = 1: generate elementary reflector H so that:
H ( -X11 ) = ( * )
( -X21 ) = ( 0 )
( scale ) = ( 0 ) */
u[0] = -x_ref(1, 1);
u[1] = -x_ref(2, 1);
u[2] = scale;
dlarfg_(&c__3, u, &u[1], &c__1, &tau);
u[0] = 1.;
t33 = t_ref(j3, j3);
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
d__4 = (d__1 = d___ref(2, 1), abs(d__1)), d__5 = (d__2 = d___ref(3, 1)
, abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = d___ref(1,
1) - t33, abs(d__3));
if (max(d__4,d__5) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
dlarfx_("R", &j3, &c__3, u, &tau, &t_ref(1, *j1), ldt, &work[1]);
i__1 = *n - *j1;
dlarfx_("L", &c__3, &i__1, u, &tau, &t_ref(*j1, j2), ldt, &work[1]);
t_ref(*j1, *j1) = t33;
t_ref(j2, *j1) = 0.;
t_ref(j3, *j1) = 0.;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("R", n, &c__3, u, &tau, &q_ref(1, *j1), ldq, &work[1]);
}
goto L40;
L30:
/* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so
that:
H(2) H(1) ( -X11 -X12 ) = ( * * )
( -X21 -X22 ) ( 0 * )
( scale 0 ) ( 0 0 )
( 0 scale ) ( 0 0 ) */
u1[0] = -x_ref(1, 1);
u1[1] = -x_ref(2, 1);
u1[2] = scale;
dlarfg_(&c__3, u1, &u1[1], &c__1, &tau1);
u1[0] = 1.;
temp = -tau1 * (x_ref(1, 2) + u1[1] * x_ref(2, 2));
u2[0] = -temp * u1[1] - x_ref(2, 2);
u2[1] = -temp * u1[2];
u2[2] = scale;
dlarfg_(&c__3, u2, &u2[1], &c__1, &tau2);
u2[0] = 1.;
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1])
;
dlarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1])
;
dlarfx_("L", &c__3, &c__4, u2, &tau2, &d___ref(2, 1), &c__4, &work[1]);
dlarfx_("R", &c__4, &c__3, u2, &tau2, &d___ref(1, 2), &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
d__5 = (d__1 = d___ref(3, 1), abs(d__1)), d__6 = (d__2 = d___ref(3, 2)
, abs(d__2)), d__5 = max(d__5,d__6), d__6 = (d__3 = d___ref(4,
1), abs(d__3)), d__5 = max(d__5,d__6), d__6 = (d__4 =
d___ref(4, 2), abs(d__4));
if (max(d__5,d__6) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u1, &tau1, &t_ref(*j1, *j1), ldt, &work[1]);
dlarfx_("R", &j4, &c__3, u1, &tau1, &t_ref(1, *j1), ldt, &work[1]);
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u2, &tau2, &t_ref(j2, *j1), ldt, &work[1]);
dlarfx_("R", &j4, &c__3, u2, &tau2, &t_ref(1, j2), ldt, &work[1]);
t_ref(j3, *j1) = 0.;
t_ref(j3, j2) = 0.;
t_ref(j4, *j1) = 0.;
t_ref(j4, j2) = 0.;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("R", n, &c__3, u1, &tau1, &q_ref(1, *j1), ldq, &work[1]);
dlarfx_("R", n, &c__3, u2, &tau2, &q_ref(1, j2), ldq, &work[1]);
}
L40:
if (*n2 == 2) {
/* Standardize new 2-by-2 block T11 */
dlanv2_(&t_ref(*j1, *j1), &t_ref(*j1, j2), &t_ref(j2, *j1), &
t_ref(j2, j2), &wr1, &wi1, &wr2, &wi2, &cs, &sn);
i__1 = *n - *j1 - 1;
drot_(&i__1, &t_ref(*j1, *j1 + 2), ldt, &t_ref(j2, *j1 + 2), ldt,
&cs, &sn);
i__1 = *j1 - 1;
drot_(&i__1, &t_ref(1, *j1), &c__1, &t_ref(1, j2), &c__1, &cs, &
sn);
if (*wantq) {
drot_(n, &q_ref(1, *j1), &c__1, &q_ref(1, j2), &c__1, &cs, &
sn);
}
}
if (*n1 == 2) {
/* Standardize new 2-by-2 block T22 */
j3 = *j1 + *n2;
j4 = j3 + 1;
dlanv2_(&t_ref(j3, j3), &t_ref(j3, j4), &t_ref(j4, j3), &t_ref(j4,
j4), &wr1, &wi1, &wr2, &wi2, &cs, &sn);
if (j3 + 2 <= *n) {
i__1 = *n - j3 - 1;
drot_(&i__1, &t_ref(j3, j3 + 2), ldt, &t_ref(j4, j3 + 2), ldt,
&cs, &sn);
}
i__1 = j3 - 1;
drot_(&i__1, &t_ref(1, j3), &c__1, &t_ref(1, j4), &c__1, &cs, &sn)
;
if (*wantq) {
drot_(n, &q_ref(1, j3), &c__1, &q_ref(1, j4), &c__1, &cs, &sn)
;
}
}
}
return 0;
/* Exit with INFO = 1 if swap was rejected. */
L50:
*info = 1;
return 0;
/* End of DLAEXC */
} /* dlaexc_ */
/* Subroutine */ int dsgesv_(integer *n, integer *nrhs, doublereal *a,
integer *lda, integer *ipiv, doublereal *b, integer *ldb, doublereal *
x, integer *ldx, doublereal *work, real *swork, integer *iter,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, work_dim1, work_offset,
x_dim1, x_offset, i__1;
doublereal d__1;
/* Local variables */
integer i__;
doublereal cte, eps, anrm;
integer ptsa;
doublereal rnrm, xnrm;
integer ptsx;
integer iiter;
/* -- LAPACK PROTOTYPE driver routine (version 3.2) -- */
/* February 2007 */
/* Purpose */
/* ======= */
/* DSGESV computes the solution to a real system of linear equations */
/* A * X = B, */
/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
/* DSGESV first attempts to factorize the matrix in SINGLE PRECISION */
/* and use this factorization within an iterative refinement procedure */
/* to produce a solution with DOUBLE PRECISION normwise backward error */
/* quality (see below). If the approach fails the method switches to a */
/* DOUBLE PRECISION factorization and solve. */
/* The iterative refinement is not going to be a winning strategy if */
/* the ratio SINGLE PRECISION performance over DOUBLE PRECISION */
/* performance is too small. A reasonable strategy should take the */
/* number of right-hand sides and the size of the matrix into account. */
/* This might be done with a call to ILAENV in the future. Up to now, we */
/* always try iterative refinement. */
/* The iterative refinement process is stopped if */
/* ITER > ITERMAX */
/* or for all the RHS we have: */
/* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX */
/* where */
/* o ITER is the number of the current iteration in the iterative */
/* refinement process */
/* o RNRM is the infinity-norm of the residual */
/* o XNRM is the infinity-norm of the solution */
/* o ANRM is the infinity-operator-norm of the matrix A */
/* o EPS is the machine epsilon returned by DLAMCH('Epsilon') */
/* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 */
/* respectively. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* A (input or input/ouptut) DOUBLE PRECISION array, */
/* dimension (LDA,N) */
/* On entry, the N-by-N coefficient matrix A. */
/* On exit, if iterative refinement has been successfully used */
/* (INFO.EQ.0 and ITER.GE.0, see description below), then A is */
/* unchanged, if double precision factorization has been used */
/* (INFO.EQ.0 and ITER.LT.0, see description below), then the */
/* array A contains the factors L and U from the factorization */
/* A = P*L*U; the unit diagonal elements of L are not stored. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (output) INTEGER array, dimension (N) */
/* The pivot indices that define the permutation matrix P; */
/* row i of the matrix was interchanged with row IPIV(i). */
/* Corresponds either to the single precision factorization */
/* (if INFO.EQ.0 and ITER.GE.0) or the double precision */
/* factorization (if INFO.EQ.0 and ITER.LT.0). */
/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* The N-by-NRHS right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* If INFO = 0, the N-by-NRHS solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N*NRHS) */
/* This array is used to hold the residual vectors. */
/* SWORK (workspace) REAL array, dimension (N*(N+NRHS)) */
/* This array is used to use the single precision matrix and the */
/* right-hand sides or solutions in single precision. */
/* ITER (output) INTEGER */
/* < 0: iterative refinement has failed, double precision */
/* factorization has been performed */
/* -1 : the routine fell back to full precision for */
/* implementation- or machine-specific reasons */
/* -2 : narrowing the precision induced an overflow, */
/* the routine fell back to full precision */
/* -3 : failure of SGETRF */
/* -31: stop the iterative refinement after the 30th */
/* iterations */
/* > 0: iterative refinement has been sucessfully used. */
/* Returns the number of iterations */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, U(i,i) computed in DOUBLE PRECISION is */
/* exactly zero. The factorization has been completed, */
/* but the factor U is exactly singular, so the solution */
/* could not be computed. */
/* ========= */
/* Parameter adjustments */
work_dim1 = *n;
work_offset = 1 + work_dim1;
work -= work_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--swork;
/* Function Body */
*info = 0;
*iter = 0;
/* Test the input parameters. */
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*ldb < max(1,*n)) {
*info = -7;
} else if (*ldx < max(1,*n)) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSGESV", &i__1);
return 0;
}
/* Quick return if (N.EQ.0). */
if (*n == 0) {
return 0;
}
/* Skip single precision iterative refinement if a priori slower */
/* than double precision factorization. */
if (FALSE_) {
*iter = -1;
goto L40;
}
/* Compute some constants. */
anrm = dlange_("I", n, n, &a[a_offset], lda, &work[work_offset]);
eps = dlamch_("Epsilon");
cte = anrm * eps * sqrt((doublereal) (*n)) * 1.;
/* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. */
ptsa = 1;
ptsx = ptsa + *n * *n;
/* Convert B from double precision to single precision and store the */
/* result in SX. */
dlag2s_(n, nrhs, &b[b_offset], ldb, &swork[ptsx], n, info);
if (*info != 0) {
*iter = -2;
goto L40;
}
/* Convert A from double precision to single precision and store the */
/* result in SA. */
dlag2s_(n, n, &a[a_offset], lda, &swork[ptsa], n, info);
if (*info != 0) {
*iter = -2;
goto L40;
}
/* Compute the LU factorization of SA. */
sgetrf_(n, n, &swork[ptsa], n, &ipiv[1], info);
if (*info != 0) {
*iter = -3;
goto L40;
}
/* Solve the system SA*SX = SB. */
sgetrs_("No transpose", n, nrhs, &swork[ptsa], n, &ipiv[1], &swork[ptsx],
n, info);
/* Convert SX back to double precision */
slag2d_(n, nrhs, &swork[ptsx], n, &x[x_offset], ldx, info);
/* Compute R = B - AX (R is WORK). */
dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n);
dgemm_("No Transpose", "No Transpose", n, nrhs, n, &c_b10, &a[a_offset],
lda, &x[x_offset], ldx, &c_b11, &work[work_offset], n);
/* Check whether the NRHS normwise backward errors satisfy the */
/* stopping criterion. If yes, set ITER=0 and return. */
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ *
x_dim1], abs(d__1));
rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) +
i__ * work_dim1], abs(d__1));
if (rnrm > xnrm * cte) {
goto L10;
}
}
/* If we are here, the NRHS normwise backward errors satisfy the */
/* stopping criterion. We are good to exit. */
*iter = 0;
return 0;
L10:
for (iiter = 1; iiter <= 30; ++iiter) {
/* Convert R (in WORK) from double precision to single precision */
/* and store the result in SX. */
dlag2s_(n, nrhs, &work[work_offset], n, &swork[ptsx], n, info);
if (*info != 0) {
*iter = -2;
goto L40;
}
/* Solve the system SA*SX = SR. */
sgetrs_("No transpose", n, nrhs, &swork[ptsa], n, &ipiv[1], &swork[
ptsx], n, info);
/* Convert SX back to double precision and update the current */
/* iterate. */
slag2d_(n, nrhs, &swork[ptsx], n, &work[work_offset], n, info);
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
daxpy_(n, &c_b11, &work[i__ * work_dim1 + 1], &c__1, &x[i__ *
x_dim1 + 1], &c__1);
}
/* Compute R = B - AX (R is WORK). */
dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n);
dgemm_("No Transpose", "No Transpose", n, nrhs, n, &c_b10, &a[
a_offset], lda, &x[x_offset], ldx, &c_b11, &work[work_offset],
n);
/* Check whether the NRHS normwise backward errors satisfy the */
/* stopping criterion. If yes, set ITER=IITER>0 and return. */
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ *
x_dim1], abs(d__1));
rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1)
+ i__ * work_dim1], abs(d__1));
if (rnrm > xnrm * cte) {
goto L20;
}
}
/* If we are here, the NRHS normwise backward errors satisfy the */
/* stopping criterion, we are good to exit. */
*iter = iiter;
return 0;
L20:
;
}
/* If we are at this place of the code, this is because we have */
/* performed ITER=ITERMAX iterations and never satisified the */
/* stopping criterion, set up the ITER flag accordingly and follow up */
/* on double precision routine. */
*iter = -31;
L40:
/* Single-precision iterative refinement failed to converge to a */
/* satisfactory solution, so we resort to double precision. */
dgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info);
if (*info != 0) {
return 0;
}
dlacpy_("All", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
dgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &x[x_offset]
, ldx, info);
return 0;
/* End of DSGESV. */
} /* dsgesv_ */
/* Subroutine */ int dggevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, doublereal *a, integer *lda, doublereal *b,
integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
beta, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr,
integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale,
doublereal *abnrm, doublereal *bbnrm, doublereal *rconde, doublereal *
rcondv, doublereal *work, integer *lwork, integer *iwork, logical *
bwork, integer *info)
{
/* 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, d__3, d__4;
/* Local variables */
integer i__, j, m, jc, in, mm, jr;
doublereal eps;
logical ilv, pair;
doublereal anrm, bnrm;
integer ierr, itau;
doublereal temp;
logical ilvl, ilvr;
integer iwrk, iwrk1;
integer icols;
logical noscl;
integer irows;
logical ilascl, ilbscl;
logical ldumma[1];
char chtemp[1];
doublereal bignum;
integer ijobvl;
integer ijobvr;
logical wantsb;
doublereal anrmto;
logical wantse;
doublereal bnrmto;
integer minwrk, maxwrk;
logical wantsn;
doublereal smlnum;
logical lquery, wantsv;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B) */
/* the generalized eigenvalues, and optionally, the left and/or right */
/* generalized eigenvectors. */
/* Optionally also, it computes a balancing transformation to improve */
/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
/* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for */
/* the eigenvalues (RCONDE), and reciprocal condition numbers for the */
/* right eigenvectors (RCONDV). */
/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar */
/* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */
/* singular. It is usually represented as the pair (alpha,beta), as */
/* there is a reasonable interpretation for beta=0, and even for both */
/* being zero. */
/* The right eigenvector v(j) corresponding to the eigenvalue lambda(j) */
/* of (A,B) satisfies */
/* A * v(j) = lambda(j) * B * v(j) . */
/* The left eigenvector u(j) corresponding to the eigenvalue lambda(j) */
/* of (A,B) satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H * B. */
/* where u(j)**H is the conjugate-transpose of u(j). */
/* Arguments */
/* ========= */
/* BALANC (input) CHARACTER*1 */
/* Specifies the balance option to be performed. */
/* = 'N': do not diagonally scale or permute; */
/* = 'P': permute only; */
/* = 'S': scale only; */
/* = 'B': both permute and scale. */
/* Computed reciprocal condition numbers will be for the */
/* matrices after permuting and/or balancing. Permuting does */
/* not change condition numbers (in exact arithmetic), but */
/* balancing does. */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': do not compute the left generalized eigenvectors; */
/* = 'V': compute the left generalized eigenvectors. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': do not compute the right generalized eigenvectors; */
/* = 'V': compute the right generalized eigenvectors. */
/* SENSE (input) CHARACTER*1 */
/* Determines which reciprocal condition numbers are computed. */
/* = 'N': none are computed; */
/* = 'E': computed for eigenvalues only; */
/* = 'V': computed for eigenvectors only; */
/* = 'B': computed for eigenvalues and eigenvectors. */
/* N (input) INTEGER */
/* The order of the matrices A, B, VL, and VR. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
/* On entry, the matrix A in the pair (A,B). */
/* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V' */
/* or both, then A contains the first part of the real Schur */
/* form of the "balanced" versions of the input A and B. */
/* LDA (input) INTEGER */
/* The leading dimension of A. LDA >= max(1,N). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */
/* On entry, the matrix B in the pair (A,B). */
/* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V' */
/* or both, then B contains the second part of the real Schur */
/* form of the "balanced" versions of the input A and B. */
/* LDB (input) INTEGER */
/* The leading dimension of B. LDB >= max(1,N). */
/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
/* BETA (output) DOUBLE PRECISION array, dimension (N) */
/* be the generalized eigenvalues. If ALPHAI(j) is zero, then */
/* the j-th eigenvalue is real; if positive, then the j-th and */
/* (j+1)-st eigenvalues are a complex conjugate pair, with */
/* ALPHAI(j+1) negative. */
/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */
/* may easily over- or underflow, and BETA(j) may even be zero. */
/* Thus, the user should avoid naively computing the ratio */
/* ALPHA/BETA. However, ALPHAR and ALPHAI will be always less */
/* than and usually comparable with norm(A) in magnitude, and */
/* BETA always less than and usually comparable with norm(B). */
/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order as */
/* their eigenvalues. If the j-th eigenvalue is real, then */
/* u(j) = VL(:,j), the j-th column of VL. If the j-th and */
/* (j+1)-th eigenvalues form a complex conjugate pair, then */
/* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). */
/* Each eigenvector will be scaled so the largest component have */
/* abs(real part) + abs(imag. part) = 1. */
/* Not referenced if JOBVL = 'N'. */
/* LDVL (input) INTEGER */
/* The leading dimension of the matrix VL. LDVL >= 1, and */
/* if JOBVL = 'V', LDVL >= N. */
/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order as */
/* their eigenvalues. If the j-th eigenvalue is real, then */
/* v(j) = VR(:,j), the j-th column of VR. If the j-th and */
/* (j+1)-th eigenvalues form a complex conjugate pair, then */
/* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). */
/* Each eigenvector will be scaled so the largest component have */
/* abs(real part) + abs(imag. part) = 1. */
/* Not referenced if JOBVR = 'N'. */
/* LDVR (input) INTEGER */
/* The leading dimension of the matrix VR. LDVR >= 1, and */
/* if JOBVR = 'V', LDVR >= N. */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are integer values such that on exit */
/* A(i,j) = 0 and B(i,j) = 0 if i > j and */
/* If BALANC = 'N' or 'S', ILO = 1 and IHI = N. */
/* LSCALE (output) DOUBLE PRECISION array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* to the left side of A and B. If PL(j) is the index of the */
/* row interchanged with row j, and DL(j) is the scaling */
/* factor applied to row j, then */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* RSCALE (output) DOUBLE PRECISION array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* to the right side of A and B. If PR(j) is the index of the */
/* column interchanged with column j, and DR(j) is the scaling */
/* factor applied to column j, then */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* ABNRM (output) DOUBLE PRECISION */
/* The one-norm of the balanced matrix A. */
/* BBNRM (output) DOUBLE PRECISION */
/* The one-norm of the balanced matrix B. */
/* RCONDE (output) DOUBLE PRECISION array, dimension (N) */
/* If SENSE = 'E' or 'B', the reciprocal condition numbers of */
/* the eigenvalues, stored in consecutive elements of the array. */
/* For a complex conjugate pair of eigenvalues two consecutive */
/* elements of RCONDE are set to the same value. Thus RCONDE(j), */
/* RCONDV(j), and the j-th columns of VL and VR all correspond */
/* to the j-th eigenpair. */
/* If SENSE = 'N or 'V', RCONDE is not referenced. */
/* RCONDV (output) DOUBLE PRECISION array, dimension (N) */
/* If SENSE = 'V' or 'B', the estimated reciprocal condition */
/* numbers of the eigenvectors, stored in consecutive elements */
/* of the array. For a complex eigenvector two consecutive */
/* elements of RCONDV are set to the same value. If the */
/* eigenvalues cannot be reordered to compute RCONDV(j), */
/* RCONDV(j) is set to 0; this can only occur when the true */
/* value would be very small anyway. */
/* If SENSE = 'N' or 'E', RCONDV is not referenced. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,2*N). */
/* If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V', */
/* LWORK >= max(1,6*N). */
/* If SENSE = 'E' or 'B', LWORK >= max(1,10*N). */
/* If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* IWORK (workspace) INTEGER array, dimension (N+6) */
/* If SENSE = 'E', IWORK is not referenced. */
/* BWORK (workspace) LOGICAL array, dimension (N) */
/* If SENSE = 'N', BWORK is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* The QZ iteration failed. No eigenvectors have been */
/* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */
/* > N: =N+1: other than QZ iteration failed in DHGEQZ. */
/* =N+2: error return from DTGEVC. */
/* Further Details */
/* =============== */
/* Balancing a matrix pair (A,B) includes, first, permuting rows and */
/* columns to isolate eigenvalues, second, applying diagonal similarity */
/* transformation to the rows and columns to make the rows and columns */
/* as close in norm as possible. The computed reciprocal condition */
/* numbers correspond to the balanced matrix. Permuting rows and columns */
/* will not change the condition numbers (in exact arithmetic) but */
/* diagonal scaling will. For further explanation of balancing, see */
/* section 4.11.1.2 of LAPACK Users' Guide. */
/* 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(ABNRM, BBNRM) / RCONDE(I) */
/* An approximate error bound for the angle between the i-th computed */
/* eigenvector VL(i) or VR(i) is given by */
/* EPS * norm(ABNRM, BBNRM) / DIF(i). */
/* For further explanation of the reciprocal condition numbers RCONDE */
/* and RCONDV, see section 4.11 of LAPACK User's Guide. */
/* ===================================================================== */
/* Decode the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alphar;
--alphai;
--beta;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--lscale;
--rscale;
--rconde;
--rcondv;
--work;
--iwork;
--bwork;
/* Function Body */
if (lsame_(jobvl, "N")) {
ijobvl = 1;
ilvl = FALSE_;
} else if (lsame_(jobvl, "V")) {
ijobvl = 2;
ilvl = TRUE_;
} else {
ijobvl = -1;
ilvl = FALSE_;
}
if (lsame_(jobvr, "N")) {
ijobvr = 1;
ilvr = FALSE_;
} else if (lsame_(jobvr, "V")) {
ijobvr = 2;
ilvr = TRUE_;
} else {
ijobvr = -1;
ilvr = FALSE_;
}
ilv = ilvl || ilvr;
noscl = lsame_(balanc, "N") || lsame_(balanc, "P");
wantsn = lsame_(sense, "N");
wantse = lsame_(sense, "E");
wantsv = lsame_(sense, "V");
wantsb = lsame_(sense, "B");
/* Test the input arguments */
*info = 0;
lquery = *lwork == -1;
if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
|| lsame_(balanc, "B"))) {
*info = -1;
} else if (ijobvl <= 0) {
*info = -2;
} else if (ijobvr <= 0) {
*info = -3;
} else if (! (wantsn || wantse || wantsb || wantsv)) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldvl < 1 || ilvl && *ldvl < *n) {
*info = -14;
} else if (*ldvr < 1 || ilvr && *ldvr < *n) {
*info = -16;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV. The workspace is */
/* computed assuming ILO = 1 and IHI = N, the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
if (noscl && ! ilv) {
minwrk = *n << 1;
} else {
minwrk = *n * 6;
}
if (wantse || wantsb) {
minwrk = *n * 10;
}
if (wantsv || wantsb) {
/* Computing MAX */
i__1 = minwrk, i__2 = (*n << 1) * (*n + 4) + 16;
minwrk = max(i__1,i__2);
}
maxwrk = minwrk;
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", n, &
c__1, n, &c__0);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DORMQR", " ", n, &
c__1, n, &c__0);
maxwrk = max(i__1,i__2);
if (ilvl) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DORGQR",
" ", n, &c__1, n, &c__0);
maxwrk = max(i__1,i__2);
}
}
work[1] = (doublereal) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -26;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGGEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]);
ilascl = FALSE_;
if (anrm > 0. && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
ierr);
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]);
ilbscl = FALSE_;
if (bnrm > 0. && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
ierr);
}
/* Permute and/or balance the matrix pair (A,B) */
/* (Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise) */
dggbal_(balanc, n, &a[a_offset], lda, &b[b_offset], ldb, ilo, ihi, &
lscale[1], &rscale[1], &work[1], &ierr);
/* Compute ABNRM and BBNRM */
*abnrm = dlange_("1", n, n, &a[a_offset], lda, &work[1]);
if (ilascl) {
work[1] = *abnrm;
dlascl_("G", &c__0, &c__0, &anrmto, &anrm, &c__1, &c__1, &work[1], &
c__1, &ierr);
*abnrm = work[1];
}
*bbnrm = dlange_("1", n, n, &b[b_offset], ldb, &work[1]);
if (ilbscl) {
work[1] = *bbnrm;
dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, &c__1, &c__1, &work[1], &
c__1, &ierr);
*bbnrm = work[1];
}
/* Reduce B to triangular form (QR decomposition of B) */
/* (Workspace: need N, prefer N*NB ) */
irows = *ihi + 1 - *ilo;
if (ilv || ! wantsn) {
icols = *n + 1 - *ilo;
} else {
icols = irows;
}
itau = 1;
iwrk = itau + irows;
i__1 = *lwork + 1 - iwrk;
dgeqrf_(&irows, &icols, &b[*ilo + *ilo * b_dim1], ldb, &work[itau], &work[
iwrk], &i__1, &ierr);
/* Apply the orthogonal transformation to A */
/* (Workspace: need N, prefer N*NB) */
i__1 = *lwork + 1 - iwrk;
dormqr_("L", "T", &irows, &icols, &irows, &b[*ilo + *ilo * b_dim1], ldb, &
work[itau], &a[*ilo + *ilo * a_dim1], lda, &work[iwrk], &i__1, &
ierr);
/* Initialize VL and/or VR */
/* (Workspace: need N, prefer N*NB) */
if (ilvl) {
dlaset_("Full", n, n, &c_b59, &c_b60, &vl[vl_offset], ldvl)
;
if (irows > 1) {
i__1 = irows - 1;
i__2 = irows - 1;
dlacpy_("L", &i__1, &i__2, &b[*ilo + 1 + *ilo * b_dim1], ldb, &vl[
*ilo + 1 + *ilo * vl_dim1], ldvl);
}
i__1 = *lwork + 1 - iwrk;
dorgqr_(&irows, &irows, &irows, &vl[*ilo + *ilo * vl_dim1], ldvl, &
work[itau], &work[iwrk], &i__1, &ierr);
}
if (ilvr) {
dlaset_("Full", n, n, &c_b59, &c_b60, &vr[vr_offset], ldvr)
;
}
/* Reduce to generalized Hessenberg form */
/* (Workspace: none needed) */
if (ilv || ! wantsn) {
/* Eigenvectors requested -- work on whole matrix. */
dgghrd_(jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
} else {
dgghrd_("N", "N", &irows, &c__1, &irows, &a[*ilo + *ilo * a_dim1],
lda, &b[*ilo + *ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
vr_offset], ldvr, &ierr);
}
/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */
/* Schur forms and Schur vectors) */
/* (Workspace: need N) */
if (ilv || ! wantsn) {
*(unsigned char *)chtemp = 'S';
} else {
*(unsigned char *)chtemp = 'E';
}
dhgeqz_(chtemp, jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset]
, ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], ldvl, &
vr[vr_offset], ldvr, &work[1], lwork, &ierr);
if (ierr != 0) {
if (ierr > 0 && ierr <= *n) {
*info = ierr;
} else if (ierr > *n && ierr <= *n << 1) {
*info = ierr - *n;
} else {
*info = *n + 1;
}
goto L130;
}
/* Compute Eigenvectors and estimate condition numbers if desired */
/* (Workspace: DTGEVC: need 6*N */
/* DTGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B', */
/* need N otherwise ) */
if (ilv || ! wantsn) {
if (ilv) {
if (ilvl) {
if (ilvr) {
*(unsigned char *)chtemp = 'B';
} else {
*(unsigned char *)chtemp = 'L';
}
} else {
*(unsigned char *)chtemp = 'R';
}
dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset],
ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &
work[1], &ierr);
if (ierr != 0) {
*info = *n + 2;
goto L130;
}
}
if (! wantsn) {
/* compute eigenvectors (DTGEVC) and estimate condition */
/* numbers (DTGSNA). Note that the definition of the condition */
/* number is not invariant under transformation (u,v) to */
/* (Q*u, Z*v), where (u,v) are eigenvectors of the generalized */
/* Schur form (S,T), Q and Z are orthogonal matrices. In order */
/* to avoid using extra 2*N*N workspace, we have to recalculate */
/* eigenvectors and estimate one condition numbers at a time. */
pair = FALSE_;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (pair) {
pair = FALSE_;
goto L20;
}
mm = 1;
if (i__ < *n) {
if (a[i__ + 1 + i__ * a_dim1] != 0.) {
pair = TRUE_;
mm = 2;
}
}
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
bwork[j] = FALSE_;
}
if (mm == 1) {
bwork[i__] = TRUE_;
} else if (mm == 2) {
bwork[i__] = TRUE_;
bwork[i__ + 1] = TRUE_;
}
iwrk = mm * *n + 1;
iwrk1 = iwrk + mm * *n;
/* Compute a pair of left and right eigenvectors. */
/* (compute workspace: need up to 4*N + 6*N) */
if (wantse || wantsb) {
dtgevc_("B", "S", &bwork[1], n, &a[a_offset], lda, &b[
b_offset], ldb, &work[1], n, &work[iwrk], n, &mm,
&m, &work[iwrk1], &ierr);
if (ierr != 0) {
*info = *n + 2;
goto L130;
}
}
i__2 = *lwork - iwrk1 + 1;
dtgsna_(sense, "S", &bwork[1], n, &a[a_offset], lda, &b[
b_offset], ldb, &work[1], n, &work[iwrk], n, &rconde[
i__], &rcondv[i__], &mm, &m, &work[iwrk1], &i__2, &
iwork[1], &ierr);
L20:
;
}
}
}
/* Undo balancing on VL and VR and normalization */
/* (Workspace: none needed) */
if (ilvl) {
dggbak_(balanc, "L", n, ilo, ihi, &lscale[1], &rscale[1], n, &vl[
vl_offset], ldvl, &ierr);
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
if (alphai[jc] < 0.) {
goto L70;
}
temp = 0.;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = vl[jr + jc * vl_dim1], abs(
d__1));
temp = max(d__2,d__3);
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__3 = temp, d__4 = (d__1 = vl[jr + jc * vl_dim1], abs(
d__1)) + (d__2 = vl[jr + (jc + 1) * vl_dim1], abs(
d__2));
temp = max(d__3,d__4);
}
}
if (temp < smlnum) {
goto L70;
}
temp = 1. / temp;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vl[jr + jc * vl_dim1] *= temp;
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vl[jr + jc * vl_dim1] *= temp;
vl[jr + (jc + 1) * vl_dim1] *= temp;
}
}
L70:
;
}
}
if (ilvr) {
dggbak_(balanc, "R", n, ilo, ihi, &lscale[1], &rscale[1], n, &vr[
vr_offset], ldvr, &ierr);
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
if (alphai[jc] < 0.) {
goto L120;
}
temp = 0.;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = vr[jr + jc * vr_dim1], abs(
d__1));
temp = max(d__2,d__3);
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__3 = temp, d__4 = (d__1 = vr[jr + jc * vr_dim1], abs(
d__1)) + (d__2 = vr[jr + (jc + 1) * vr_dim1], abs(
d__2));
temp = max(d__3,d__4);
}
}
if (temp < smlnum) {
goto L120;
}
temp = 1. / temp;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vr[jr + jc * vr_dim1] *= temp;
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vr[jr + jc * vr_dim1] *= temp;
vr[jr + (jc + 1) * vr_dim1] *= temp;
}
}
L120:
;
}
}
/* Undo scaling if necessary */
if (ilascl) {
dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
ierr);
dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
ierr);
}
if (ilbscl) {
dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
ierr);
}
L130:
work[1] = (doublereal) maxwrk;
return 0;
/* End of DGGEVX */
} /* dggevx_ */
doublereal dqrt11_(integer *m, integer *k, doublereal *a, integer *lda,
doublereal *tau, doublereal *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
doublereal ret_val;
/* Local variables */
integer j, info;
doublereal rdummy[1];
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DQRT11 computes the test ratio */
/* || Q'*Q - I || / (eps * m) */
/* where the orthogonal matrix Q is represented as a product of */
/* elementary transformations. Each transformation has the form */
/* H(k) = I - tau(k) v(k) v(k)' */
/* where tau(k) is stored in TAU(k) and v(k) is an m-vector of the form */
/* [ 0 ... 0 1 x(k) ]', where x(k) is a vector of length m-k stored */
/* in A(k+1:m,k). */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. */
/* K (input) INTEGER */
/* The number of columns of A whose subdiagonal entries */
/* contain information about orthogonal transformations. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,K) */
/* The (possibly partial) output of a QR reduction routine. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* TAU (input) DOUBLE PRECISION array, dimension (K) */
/* The scaling factors tau for the elementary transformations as */
/* computed by the QR factorization routine. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= M*M + M. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
ret_val = 0.;
/* Test for sufficient workspace */
if (*lwork < *m * *m + *m) {
this_xerbla_("DQRT11", &c__7);
return ret_val;
}
/* Quick return if possible */
if (*m <= 0) {
return ret_val;
}
dlaset_("Full", m, m, &c_b5, &c_b6, &work[1], m);
/* Form Q */
dorm2r_("Left", "No transpose", m, m, k, &a[a_offset], lda, &tau[1], &
work[1], m, &work[*m * *m + 1], &info);
/* Form Q'*Q */
dorm2r_("Left", "Transpose", m, m, k, &a[a_offset], lda, &tau[1], &work[1]
, m, &work[*m * *m + 1], &info);
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
work[(j - 1) * *m + j] += -1.;
/* L10: */
}
ret_val = dlange_("One-norm", m, m, &work[1], m, rdummy) / ((
doublereal) (*m) * dlamch_("Epsilon"));
return ret_val;
/* End of DQRT11 */
} /* dqrt11_ */
/* Subroutine */ int ddrvrf3_(integer *nout, integer *nn, integer *nval,
doublereal *thresh, doublereal *a, integer *lda, doublereal *arf,
doublereal *b1, doublereal *b2, doublereal *d_work_dlange__,
doublereal *d_work_dgeqrf__, doublereal *tau)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char forms[1*2] = "N" "T";
static char sides[1*2] = "L" "R";
static char transs[1*2] = "N" "T";
static char diags[1*2] = "N" "U";
/* Format strings */
static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
"ing DTFSM ***\002)";
static char fmt_9997[] = "(1x,\002 Failure in \002,a5,\002, CFORM="
"'\002,a1,\002',\002,\002 SIDE='\002,a1,\002',\002,\002 UPLO='"
"\002,a1,\002',\002,\002 TRANS='\002,a1,\002',\002,\002 DIAG='"
"\002,a1,\002',\002,\002 M=\002,i3,\002, N =\002,i3,\002, test"
"=\002,g12.5)";
static char fmt_9996[] = "(1x,\002All tests for \002,a5,\002 auxiliary r"
"outine passed the \002,\002threshold (\002,i5,\002 tests run)"
"\002)";
static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
" of \002,i5,\002 tests failed to pass the threshold\002)";
/* System generated locals */
integer a_dim1, a_offset, b1_dim1, b1_offset, b2_dim1, b2_offset, i__1,
i__2, i__3, i__4;
/* Local variables */
integer i__, j, m, n, na, iim, iin;
doublereal eps;
char diag[1], side[1];
integer info;
char uplo[1];
integer nrun, idiag;
doublereal alpha;
integer nfail, iseed[4], iside;
char cform[1];
integer iform;
char trans[1];
integer iuplo;
integer ialpha;
integer itrans;
doublereal result[1];
/* Fortran I/O blocks */
static cilist io___32 = { 0, 0, 0, 0, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9995, 0 };
/* -- LAPACK test routine (version 3.2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DDRVRF3 tests the LAPACK RFP routines: */
/* DTFSM */
/* Arguments */
/* ========= */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* A (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,NMAX). */
/* ARF (workspace) DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2). */
/* B1 (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
/* B2 (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
/* D_WORK_DLANGE (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* D_WORK_DGEQRF (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* TAU (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* ===================================================================== */
/* .. */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nval;
b2_dim1 = *lda;
b2_offset = 1 + b2_dim1;
b2 -= b2_offset;
b1_dim1 = *lda;
b1_offset = 1 + b1_dim1;
b1 -= b1_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--arf;
--d_work_dlange__;
--d_work_dgeqrf__;
--tau;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
nrun = 0;
nfail = 0;
info = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Precision");
i__1 = *nn;
for (iim = 1; iim <= i__1; ++iim) {
m = nval[iim];
i__2 = *nn;
for (iin = 1; iin <= i__2; ++iin) {
n = nval[iin];
for (iform = 1; iform <= 2; ++iform) {
*(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[
iside - 1];
for (itrans = 1; itrans <= 2; ++itrans) {
*(unsigned char *)trans = *(unsigned char *)&
transs[itrans - 1];
for (idiag = 1; idiag <= 2; ++idiag) {
*(unsigned char *)diag = *(unsigned char *)&
diags[idiag - 1];
for (ialpha = 1; ialpha <= 3; ++ialpha) {
if (ialpha == 1) {
alpha = 0.;
} else if (ialpha == 1) {
alpha = 1.;
} else {
alpha = dlarnd_(&c__2, iseed);
}
/* All the parameters are set: */
/* CFORM, SIDE, UPLO, TRANS, DIAG, M, N, */
/* and ALPHA */
/* READY TO TEST! */
++nrun;
if (iside == 1) {
/* The case ISIDE.EQ.1 is when SIDE.EQ.'L' */
/* -> A is M-by-M ( B is M-by-N ) */
na = m;
} else {
/* The case ISIDE.EQ.2 is when SIDE.EQ.'R' */
/* -> A is N-by-N ( B is M-by-N ) */
na = n;
}
/* Generate A our NA--by--NA triangular */
/* matrix. */
/* Our test is based on forward error so we */
/* do want A to be well conditionned! To get */
/* a well-conditionned triangular matrix, we */
/* take the R factor of the QR/LQ factorization */
/* of a random matrix. */
i__3 = na;
for (j = 1; j <= i__3; ++j) {
i__4 = na;
for (i__ = 1; i__ <= i__4; ++i__) {
a[i__ + j * a_dim1] = dlarnd_(&
c__2, iseed);
}
}
if (iuplo == 1) {
/* The case IUPLO.EQ.1 is when SIDE.EQ.'U' */
/* -> QR factorization. */
s_copy(srnamc_1.srnamt, "DGEQRF", (
ftnlen)32, (ftnlen)6);
dgeqrf_(&na, &na, &a[a_offset], lda, &
tau[1], &d_work_dgeqrf__[1],
lda, &info);
} else {
/* The case IUPLO.EQ.2 is when SIDE.EQ.'L' */
/* -> QL factorization. */
s_copy(srnamc_1.srnamt, "DGELQF", (
ftnlen)32, (ftnlen)6);
dgelqf_(&na, &na, &a[a_offset], lda, &
tau[1], &d_work_dgeqrf__[1],
lda, &info);
}
/* Store a copy of A in RFP format (in ARF). */
s_copy(srnamc_1.srnamt, "DTRTTF", (ftnlen)
32, (ftnlen)6);
dtrttf_(cform, uplo, &na, &a[a_offset],
lda, &arf[1], &info);
/* Generate B1 our M--by--N right-hand side */
/* and store a copy in B2. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = m;
for (i__ = 1; i__ <= i__4; ++i__) {
b1[i__ + j * b1_dim1] = dlarnd_(&
c__2, iseed);
b2[i__ + j * b2_dim1] = b1[i__ +
j * b1_dim1];
}
}
/* Solve op( A ) X = B or X op( A ) = B */
/* with DTRSM */
s_copy(srnamc_1.srnamt, "DTRSM", (ftnlen)
32, (ftnlen)5);
dtrsm_(side, uplo, trans, diag, &m, &n, &
alpha, &a[a_offset], lda, &b1[
b1_offset], lda);
/* Solve op( A ) X = B or X op( A ) = B */
/* with DTFSM */
s_copy(srnamc_1.srnamt, "DTFSM", (ftnlen)
32, (ftnlen)5);
dtfsm_(cform, side, uplo, trans, diag, &m,
&n, &alpha, &arf[1], &b2[
b2_offset], lda);
/* Check that the result agrees. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = m;
for (i__ = 1; i__ <= i__4; ++i__) {
b1[i__ + j * b1_dim1] = b2[i__ +
j * b2_dim1] - b1[i__ + j
* b1_dim1];
}
}
result[0] = dlange_("I", &m, &n, &b1[
b1_offset], lda, &d_work_dlange__[
1]);
/* Computing MAX */
i__3 = max(m,n);
result[0] = result[0] / sqrt(eps) / max(
i__3,1);
if (result[0] >= *thresh) {
if (nfail == 0) {
io___32.ciunit = *nout;
s_wsle(&io___32);
e_wsle();
io___33.ciunit = *nout;
s_wsfe(&io___33);
e_wsfe();
}
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, "DTFSM", (ftnlen)5);
do_fio(&c__1, cform, (ftnlen)1);
do_fio(&c__1, side, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&m, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[0], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L100: */
}
/* L110: */
}
/* L120: */
}
/* L130: */
}
/* L140: */
}
/* L150: */
}
/* L160: */
}
/* L170: */
}
/* Print a summary of the results. */
if (nfail == 0) {
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "DTFSM", (ftnlen)5);
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, "DTFSM", (ftnlen)5);
do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
}
return 0;
/* End of DDRVRF3 */
} /* ddrvrf3_ */
/* Subroutine */ int dpot03_(char *uplo, integer *n, doublereal *a, integer *
lda, doublereal *ainv, integer *ldainv, doublereal *work, integer *
ldwork, doublereal *rwork, doublereal *rcond, doublereal *resid)
{
/* System generated locals */
integer a_dim1, a_offset, ainv_dim1, ainv_offset, work_dim1, work_offset,
i__1, i__2;
/* Local variables */
integer i__, j;
doublereal eps;
extern logical lsame_(char *, char *);
doublereal anorm;
extern /* Subroutine */ int dsymm_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
doublereal ainvnm;
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
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 */
/* ======= */
/* DPOT03 computes the residual for a symmetric matrix times its */
/* inverse: */
/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric 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) DOUBLE PRECISION array, dimension (LDA,N) */
/* The original symmetric matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* AINV (input/output) DOUBLE PRECISION array, dimension (LDAINV,N) */
/* On entry, the inverse of the matrix A, stored as a symmetric */
/* matrix in the same format as A. */
/* In this version, AINV is expanded into a full matrix and */
/* multiplied by A, so the opposing triangle of AINV will be */
/* changed; i.e., if the upper triangular part of AINV is */
/* stored, the lower triangular part will be used as work space. */
/* LDAINV (input) INTEGER */
/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N) */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RCOND (output) DOUBLE PRECISION */
/* The reciprocal of the condition number of A, computed as */
/* ( 1/norm(A) ) / norm(AINV). */
/* RESID (output) DOUBLE PRECISION */
/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * 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;
ainv_dim1 = *ldainv;
ainv_offset = 1 + ainv_dim1;
ainv -= ainv_offset;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1;
work -= work_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*rcond = 1.;
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
eps = dlamch_("Epsilon");
anorm = dlansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
ainvnm = dlansy_("1", uplo, n, &ainv[ainv_offset], ldainv, &rwork[1]);
if (anorm <= 0. || ainvnm <= 0.) {
*rcond = 0.;
*resid = 1. / eps;
return 0;
}
*rcond = 1. / anorm / ainvnm;
/* Expand AINV into a full matrix and call DSYMM to multiply */
/* AINV on the left by 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__) {
ainv[j + i__ * ainv_dim1] = ainv[i__ + j * ainv_dim1];
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
ainv[j + i__ * ainv_dim1] = ainv[i__ + j * ainv_dim1];
/* L30: */
}
/* L40: */
}
}
dsymm_("Left", uplo, n, n, &c_b11, &a[a_offset], lda, &ainv[ainv_offset],
ldainv, &c_b12, &work[work_offset], ldwork);
/* Add the identity matrix to WORK . */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__ + i__ * work_dim1] += 1.;
/* L50: */
}
/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
*resid = dlange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
*resid = *resid * *rcond / eps / (doublereal) (*n);
return 0;
/* End of DPOT03 */
} /* dpot03_ */
/* Subroutine */ int dgges_(char *jobvsl, char *jobvsr, char *sort, L_fp
selctg, integer *n, doublereal *a, integer *lda, doublereal *b,
integer *ldb, integer *sdim, doublereal *alphar, doublereal *alphai,
doublereal *beta, doublereal *vsl, integer *ldvsl, doublereal *vsr,
integer *ldvsr, doublereal *work, integer *lwork, logical *bwork,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
vsr_dim1, vsr_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
integer i__, ip;
doublereal dif[2];
integer ihi, ilo;
doublereal eps, anrm, bnrm;
integer idum[1], ierr, itau, iwrk;
doublereal pvsl, pvsr;
integer ileft, icols;
logical cursl, ilvsl, ilvsr;
integer irows;
logical lst2sl;
logical ilascl, ilbscl;
doublereal safmin;
doublereal safmax;
doublereal bignum;
integer ijobvl, iright;
integer ijobvr;
doublereal anrmto, bnrmto;
logical lastsl;
integer minwrk, maxwrk;
doublereal smlnum;
logical wantst, lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B), */
/* the generalized eigenvalues, the generalized real Schur form (S,T), */
/* optionally, the left and/or right matrices of Schur vectors (VSL and */
/* VSR). This gives the generalized Schur factorization */
/* (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T ) */
/* Optionally, it also orders the eigenvalues so that a selected cluster */
/* of eigenvalues appears in the leading diagonal blocks of the upper */
/* quasi-triangular matrix S and the upper triangular matrix T.The */
/* leading columns of VSL and VSR then form an orthonormal basis for the */
/* corresponding left and right eigenspaces (deflating subspaces). */
/* (If only the generalized eigenvalues are needed, use the driver */
/* DGGEV instead, which is faster.) */
/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */
/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */
/* usually represented as the pair (alpha,beta), as there is a */
/* reasonable interpretation for beta=0 or both being zero. */
/* A pair of matrices (S,T) is in generalized real Schur form if T is */
/* upper triangular with non-negative diagonal and S is block upper */
/* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond */
/* to real generalized eigenvalues, while 2-by-2 blocks of S will be */
/* "standardized" by making the corresponding elements of T have the */
/* form: */
/* [ a 0 ] */
/* [ 0 b ] */
/* and the pair of corresponding 2-by-2 blocks in S and T will have a */
/* complex conjugate pair of generalized eigenvalues. */
/* Arguments */
/* ========= */
/* JOBVSL (input) CHARACTER*1 */
/* = 'N': do not compute the left Schur vectors; */
/* = 'V': compute the left Schur vectors. */
/* JOBVSR (input) CHARACTER*1 */
/* = 'N': do not compute the right Schur vectors; */
/* = 'V': compute the right Schur vectors. */
/* SORT (input) CHARACTER*1 */
/* Specifies whether or not to order the eigenvalues on the */
/* diagonal of the generalized Schur form. */
/* = 'N': Eigenvalues are not ordered; */
/* = 'S': Eigenvalues are ordered (see SELCTG); */
/* SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments */
/* SELCTG must be declared EXTERNAL in the calling subroutine. */
/* If SORT = 'N', SELCTG is not referenced. */
/* If SORT = 'S', SELCTG is used to select eigenvalues to sort */
/* to the top left of the Schur form. */
/* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if */
/* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either */
/* one of a complex conjugate pair of eigenvalues is selected, */
/* then both complex eigenvalues are selected. */
/* Note that in the ill-conditioned case, a selected complex */
/* eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j), */
/* BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2 */
/* in this case. */
/* N (input) INTEGER */
/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
/* On entry, the first of the pair of matrices. */
/* On exit, A has been overwritten by its generalized Schur */
/* form S. */
/* LDA (input) INTEGER */
/* The leading dimension of A. LDA >= max(1,N). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */
/* On entry, the second of the pair of matrices. */
/* On exit, B has been overwritten by its generalized Schur */
/* form T. */
/* LDB (input) INTEGER */
/* The leading dimension of B. LDB >= max(1,N). */
/* SDIM (output) INTEGER */
/* If SORT = 'N', SDIM = 0. */
/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
/* for which SELCTG is true. (Complex conjugate pairs for which */
/* SELCTG is true for either eigenvalue count as 2.) */
/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
/* BETA (output) DOUBLE PRECISION array, dimension (N) */
/* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i, */
/* form (S,T) that would result if the 2-by-2 diagonal blocks of */
/* the real Schur form of (A,B) were further reduced to */
/* triangular form using 2-by-2 complex unitary transformations. */
/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */
/* positive, then the j-th and (j+1)-st eigenvalues are a */
/* complex conjugate pair, with ALPHAI(j+1) negative. */
/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */
/* may easily over- or underflow, and BETA(j) may even be zero. */
/* Thus, the user should avoid naively computing the ratio. */
/* However, ALPHAR and ALPHAI will be always less than and */
/* usually comparable with norm(A) in magnitude, and BETA always */
/* less than and usually comparable with norm(B). */
/* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N) */
/* If JOBVSL = 'V', VSL will contain the left Schur vectors. */
/* Not referenced if JOBVSL = 'N'. */
/* LDVSL (input) INTEGER */
/* The leading dimension of the matrix VSL. LDVSL >=1, and */
/* if JOBVSL = 'V', LDVSL >= N. */
/* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N) */
/* If JOBVSR = 'V', VSR will contain the right Schur vectors. */
/* Not referenced if JOBVSR = 'N'. */
/* LDVSR (input) INTEGER */
/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
/* if JOBVSR = 'V', LDVSR >= N. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If N = 0, LWORK >= 1, else LWORK >= 8*N+16. */
/* For good performance , LWORK must generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* BWORK (workspace) LOGICAL array, dimension (N) */
/* Not referenced if SORT = 'N'. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* The QZ iteration failed. (A,B) are not in Schur */
/* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */
/* > N: =N+1: other than QZ iteration failed in DHGEQZ. */
/* =N+2: after reordering, roundoff changed values of */
/* some complex eigenvalues so that leading */
/* eigenvalues in the Generalized Schur form no */
/* longer satisfy SELCTG=.TRUE. This could also */
/* be caused due to scaling. */
/* =N+3: reordering failed in DTGSEN. */
/* ===================================================================== */
/* Decode the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alphar;
--alphai;
--beta;
vsl_dim1 = *ldvsl;
vsl_offset = 1 + vsl_dim1;
vsl -= vsl_offset;
vsr_dim1 = *ldvsr;
vsr_offset = 1 + vsr_dim1;
vsr -= vsr_offset;
--work;
--bwork;
/* Function Body */
if (lsame_(jobvsl, "N")) {
ijobvl = 1;
ilvsl = FALSE_;
} else if (lsame_(jobvsl, "V")) {
ijobvl = 2;
ilvsl = TRUE_;
} else {
ijobvl = -1;
ilvsl = FALSE_;
}
if (lsame_(jobvsr, "N")) {
ijobvr = 1;
ilvsr = FALSE_;
} else if (lsame_(jobvsr, "V")) {
ijobvr = 2;
ilvsr = TRUE_;
} else {
ijobvr = -1;
ilvsr = FALSE_;
}
wantst = lsame_(sort, "S");
/* Test the input arguments */
*info = 0;
lquery = *lwork == -1;
if (ijobvl <= 0) {
*info = -1;
} else if (ijobvr <= 0) {
*info = -2;
} else if (! wantst && ! lsame_(sort, "N")) {
*info = -3;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
*info = -15;
} else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
*info = -17;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV.) */
if (*info == 0) {
if (*n > 0) {
/* Computing MAX */
i__1 = *n << 3, i__2 = *n * 6 + 16;
minwrk = max(i__1,i__2);
maxwrk = minwrk - *n + *n * ilaenv_(&c__1, "DGEQRF", " ", n, &
c__1, n, &c__0);
/* Computing MAX */
i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DORMQR",
" ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
if (ilvsl) {
/* Computing MAX */
i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DOR"
"GQR", " ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
}
} else {
minwrk = 1;
maxwrk = 1;
}
work[1] = (doublereal) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -19;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGGES ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*sdim = 0;
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
safmin = dlamch_("S");
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
smlnum = sqrt(safmin) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]);
ilascl = FALSE_;
if (anrm > 0. && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
ierr);
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]);
ilbscl = FALSE_;
if (bnrm > 0. && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
ierr);
}
/* Permute the matrix to make it more nearly triangular */
/* (Workspace: need 6*N + 2*N space for storing balancing factors) */
ileft = 1;
iright = *n + 1;
iwrk = iright + *n;
dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
ileft], &work[iright], &work[iwrk], &ierr);
/* Reduce B to triangular form (QR decomposition of B) */
/* (Workspace: need N, prefer N*NB) */
irows = ihi + 1 - ilo;
icols = *n + 1 - ilo;
itau = iwrk;
iwrk = itau + irows;
i__1 = *lwork + 1 - iwrk;
dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
iwrk], &i__1, &ierr);
/* Apply the orthogonal transformation to matrix A */
/* (Workspace: need N, prefer N*NB) */
i__1 = *lwork + 1 - iwrk;
dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, &
ierr);
/* Initialize VSL */
/* (Workspace: need N, prefer N*NB) */
if (ilvsl) {
dlaset_("Full", n, n, &c_b38, &c_b39, &vsl[vsl_offset], ldvsl);
if (irows > 1) {
i__1 = irows - 1;
i__2 = irows - 1;
dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[
ilo + 1 + ilo * vsl_dim1], ldvsl);
}
i__1 = *lwork + 1 - iwrk;
dorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
work[itau], &work[iwrk], &i__1, &ierr);
}
/* Initialize VSR */
if (ilvsr) {
dlaset_("Full", n, n, &c_b38, &c_b39, &vsr[vsr_offset], ldvsr);
}
/* Reduce to generalized Hessenberg form */
/* (Workspace: none needed) */
dgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr);
/* Perform QZ algorithm, computing Schur vectors if desired */
/* (Workspace: need N) */
iwrk = itau;
i__1 = *lwork + 1 - iwrk;
dhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset]
, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &ierr);
if (ierr != 0) {
if (ierr > 0 && ierr <= *n) {
*info = ierr;
} else if (ierr > *n && ierr <= *n << 1) {
*info = ierr - *n;
} else {
*info = *n + 1;
}
goto L50;
}
/* Sort eigenvalues ALPHA/BETA if desired */
/* (Workspace: need 4*N+16 ) */
*sdim = 0;
if (wantst) {
/* Undo scaling on eigenvalues before SELCTGing */
if (ilascl) {
dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1],
n, &ierr);
dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1],
n, &ierr);
}
if (ilbscl) {
dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n,
&ierr);
}
/* Select eigenvalues */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
bwork[i__] = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]);
}
i__1 = *lwork - iwrk + 1;
dtgsen_(&c__0, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[
b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[
vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, sdim, &pvsl, &
pvsr, dif, &work[iwrk], &i__1, idum, &c__1, &ierr);
if (ierr == 1) {
*info = *n + 3;
}
}
/* Apply back-permutation to VSL and VSR */
/* (Workspace: none needed) */
if (ilvsl) {
dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[
vsl_offset], ldvsl, &ierr);
}
if (ilvsr) {
dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[
vsr_offset], ldvsr, &ierr);
}
/* Check if unscaling would cause over/underflow, if so, rescale */
/* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of */
/* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) */
if (ilascl) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (alphai[i__] != 0.) {
if (alphar[i__] / safmax > anrmto / anrm || safmin / alphar[
i__] > anrm / anrmto) {
work[1] = (d__1 = a[i__ + i__ * a_dim1] / alphar[i__],
abs(d__1));
beta[i__] *= work[1];
alphar[i__] *= work[1];
alphai[i__] *= work[1];
} else if (alphai[i__] / safmax > anrmto / anrm || safmin /
alphai[i__] > anrm / anrmto) {
work[1] = (d__1 = a[i__ + (i__ + 1) * a_dim1] / alphai[
i__], abs(d__1));
beta[i__] *= work[1];
alphar[i__] *= work[1];
alphai[i__] *= work[1];
}
}
}
}
if (ilbscl) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (alphai[i__] != 0.) {
if (beta[i__] / safmax > bnrmto / bnrm || safmin / beta[i__]
> bnrm / bnrmto) {
work[1] = (d__1 = b[i__ + i__ * b_dim1] / beta[i__], abs(
d__1));
beta[i__] *= work[1];
alphar[i__] *= work[1];
alphai[i__] *= work[1];
}
}
}
}
/* Undo scaling */
if (ilascl) {
dlascl_("H", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, &
ierr);
dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
ierr);
dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
ierr);
}
if (ilbscl) {
dlascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
ierr);
dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
ierr);
}
if (wantst) {
/* Check if reordering is correct */
lastsl = TRUE_;
lst2sl = TRUE_;
*sdim = 0;
ip = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
cursl = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]);
if (alphai[i__] == 0.) {
if (cursl) {
++(*sdim);
}
ip = 0;
if (cursl && ! lastsl) {
*info = *n + 2;
}
} else {
if (ip == 1) {
/* Last eigenvalue of conjugate pair */
cursl = cursl || lastsl;
lastsl = cursl;
if (cursl) {
*sdim += 2;
}
ip = -1;
if (cursl && ! lst2sl) {
*info = *n + 2;
}
} else {
/* First eigenvalue of conjugate pair */
ip = 1;
}
}
lst2sl = lastsl;
lastsl = cursl;
}
}
L50:
work[1] = (doublereal) maxwrk;
return 0;
/* End of DGGES */
} /* dgges_ */
/* Subroutine */ int dget52_(logical *left, integer *n, doublereal *a,
integer *lda, doublereal *b, integer *ldb, doublereal *e, integer *
lde, doublereal *alphar, doublereal *alphai, doublereal *beta,
doublereal *work, doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, e_dim1, e_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
/* Local variables */
integer j;
doublereal ulp;
integer jvec;
doublereal temp1, acoef, scale, abmax, salfi, sbeta;
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
doublereal salfr, anorm, bnorm, enorm;
char trans[1];
doublereal bcoefi;
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
doublereal bcoefr, alfmax, safmin;
char normab[1];
doublereal safmax, betmax, enrmer;
logical ilcplx;
doublereal errnrm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGET52 does an eigenvector check for the generalized eigenvalue */
/* problem. */
/* The basic test for right eigenvectors is: */
/* | b(j) A E(j) - a(j) B E(j) | */
/* RESULT(1) = max ------------------------------- */
/* j n ulp max( |b(j) A|, |a(j) B| ) */
/* using the 1-norm. Here, a(j)/b(j) = w is the j-th generalized */
/* eigenvalue of A - w B, or, equivalently, b(j)/a(j) = m is the j-th */
/* generalized eigenvalue of m A - B. */
/* For real eigenvalues, the test is straightforward. For complex */
/* eigenvalues, E(j) and a(j) are complex, represented by */
/* Er(j) + i*Ei(j) and ar(j) + i*ai(j), resp., so the test for that */
/* eigenvector becomes */
/* max( |Wr|, |Wi| ) */
/* -------------------------------------------- */
/* n ulp max( |b(j) A|, (|ar(j)|+|ai(j)|) |B| ) */
/* where */
/* Wr = b(j) A Er(j) - ar(j) B Er(j) + ai(j) B Ei(j) */
/* Wi = b(j) A Ei(j) - ai(j) B Er(j) - ar(j) B Ei(j) */
/* T T _ */
/* For left eigenvectors, A , B , a, and b are used. */
/* DGET52 also tests the normalization of E. Each eigenvector is */
/* supposed to be normalized so that the maximum "absolute value" */
/* of its elements is 1, where in this case, "absolute value" */
/* of a complex value x is |Re(x)| + |Im(x)| ; let us call this */
/* maximum "absolute value" norm of a vector v M(v). */
/* if a(j)=b(j)=0, then the eigenvector is set to be the jth coordinate */
/* vector. The normalization test is: */
/* RESULT(2) = max | M(v(j)) - 1 | / ( n ulp ) */
/* eigenvectors v(j) */
/* Arguments */
/* ========= */
/* LEFT (input) LOGICAL */
/* =.TRUE.: The eigenvectors in the columns of E are assumed */
/* to be *left* eigenvectors. */
/* =.FALSE.: The eigenvectors in the columns of E are assumed */
/* to be *right* eigenvectors. */
/* N (input) INTEGER */
/* The size of the matrices. If it is zero, DGET52 does */
/* nothing. It must be at least zero. */
/* A (input) DOUBLE PRECISION array, dimension (LDA, N) */
/* The matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of A. It must be at least 1 */
/* and at least N. */
/* B (input) DOUBLE PRECISION array, dimension (LDB, N) */
/* The matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of B. It must be at least 1 */
/* and at least N. */
/* E (input) DOUBLE PRECISION array, dimension (LDE, N) */
/* The matrix of eigenvectors. It must be O( 1 ). Complex */
/* eigenvalues and eigenvectors always come in pairs, the */
/* eigenvalue and its conjugate being stored in adjacent */
/* elements of ALPHAR, ALPHAI, and BETA. Thus, if a(j)/b(j) */
/* and a(j+1)/b(j+1) are a complex conjugate pair of */
/* generalized eigenvalues, then E(,j) contains the real part */
/* of the eigenvector and E(,j+1) contains the imaginary part. */
/* Note that whether E(,j) is a real eigenvector or part of a */
/* complex one is specified by whether ALPHAI(j) is zero or not. */
/* LDE (input) INTEGER */
/* The leading dimension of E. It must be at least 1 and at */
/* least N. */
/* ALPHAR (input) DOUBLE PRECISION array, dimension (N) */
/* The real parts of the values a(j) as described above, which, */
/* along with b(j), define the generalized eigenvalues. */
/* Complex eigenvalues always come in complex conjugate pairs */
/* a(j)/b(j) and a(j+1)/b(j+1), which are stored in adjacent */
/* elements in ALPHAR, ALPHAI, and BETA. Thus, if the j-th */
/* and (j+1)-st eigenvalues form a pair, ALPHAR(j+1)/BETA(j+1) */
/* is assumed to be equal to ALPHAR(j)/BETA(j). */
/* ALPHAI (input) DOUBLE PRECISION array, dimension (N) */
/* The imaginary parts of the values a(j) as described above, */
/* which, along with b(j), define the generalized eigenvalues. */
/* If ALPHAI(j)=0, then the eigenvalue is real, otherwise it */
/* is part of a complex conjugate pair. Complex eigenvalues */
/* always come in complex conjugate pairs a(j)/b(j) and */
/* a(j+1)/b(j+1), which are stored in adjacent elements in */
/* ALPHAR, ALPHAI, and BETA. Thus, if the j-th and (j+1)-st */
/* eigenvalues form a pair, ALPHAI(j+1)/BETA(j+1) is assumed to */
/* be equal to -ALPHAI(j)/BETA(j). Also, nonzero values in */
/* ALPHAI are assumed to always come in adjacent pairs. */
/* BETA (input) DOUBLE PRECISION array, dimension (N) */
/* The values b(j) as described above, which, along with a(j), */
/* define the generalized eigenvalues. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N**2+N) */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* The values computed by the test described above. If A E or */
/* B E is likely to overflow, then RESULT(1:2) is set to */
/* 10 / ulp. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
e_dim1 = *lde;
e_offset = 1 + e_dim1;
e -= e_offset;
--alphar;
--alphai;
--beta;
--work;
--result;
/* Function Body */
result[1] = 0.;
result[2] = 0.;
if (*n <= 0) {
return 0;
}
safmin = dlamch_("Safe minimum");
safmax = 1. / safmin;
ulp = dlamch_("Epsilon") * dlamch_("Base");
if (*left) {
*(unsigned char *)trans = 'T';
*(unsigned char *)normab = 'I';
} else {
*(unsigned char *)trans = 'N';
*(unsigned char *)normab = 'O';
}
/* Norm of A, B, and E: */
/* Computing MAX */
d__1 = dlange_(normab, n, n, &a[a_offset], lda, &work[1]);
anorm = max(d__1,safmin);
/* Computing MAX */
d__1 = dlange_(normab, n, n, &b[b_offset], ldb, &work[1]);
bnorm = max(d__1,safmin);
/* Computing MAX */
d__1 = dlange_("O", n, n, &e[e_offset], lde, &work[1]);
enorm = max(d__1,ulp);
alfmax = safmax / max(1.,bnorm);
betmax = safmax / max(1.,anorm);
/* Compute error matrix. */
/* Column i = ( b(i) A - a(i) B ) E(i) / max( |a(i) B| |b(i) A| ) */
ilcplx = FALSE_;
i__1 = *n;
for (jvec = 1; jvec <= i__1; ++jvec) {
if (ilcplx) {
/* 2nd Eigenvalue/-vector of pair -- do nothing */
ilcplx = FALSE_;
} else {
salfr = alphar[jvec];
salfi = alphai[jvec];
sbeta = beta[jvec];
if (salfi == 0.) {
/* Real eigenvalue and -vector */
/* Computing MAX */
d__1 = abs(salfr), d__2 = abs(sbeta);
abmax = max(d__1,d__2);
if (abs(salfr) > alfmax || abs(sbeta) > betmax || abmax < 1.)
{
scale = 1. / max(abmax,safmin);
salfr = scale * salfr;
sbeta = scale * sbeta;
}
/* Computing MAX */
d__1 = abs(salfr) * bnorm, d__2 = abs(sbeta) * anorm, d__1 =
max(d__1,d__2);
scale = 1. / max(d__1,safmin);
acoef = scale * sbeta;
bcoefr = scale * salfr;
dgemv_(trans, n, n, &acoef, &a[a_offset], lda, &e[jvec *
e_dim1 + 1], &c__1, &c_b12, &work[*n * (jvec - 1) + 1]
, &c__1);
d__1 = -bcoefr;
dgemv_(trans, n, n, &d__1, &b[b_offset], lda, &e[jvec *
e_dim1 + 1], &c__1, &c_b15, &work[*n * (jvec - 1) + 1]
, &c__1);
} else {
/* Complex conjugate pair */
ilcplx = TRUE_;
if (jvec == *n) {
result[1] = 10. / ulp;
return 0;
}
/* Computing MAX */
d__1 = abs(salfr) + abs(salfi), d__2 = abs(sbeta);
abmax = max(d__1,d__2);
if (abs(salfr) + abs(salfi) > alfmax || abs(sbeta) > betmax ||
abmax < 1.) {
scale = 1. / max(abmax,safmin);
salfr = scale * salfr;
salfi = scale * salfi;
sbeta = scale * sbeta;
}
/* Computing MAX */
d__1 = (abs(salfr) + abs(salfi)) * bnorm, d__2 = abs(sbeta) *
anorm, d__1 = max(d__1,d__2);
scale = 1. / max(d__1,safmin);
acoef = scale * sbeta;
bcoefr = scale * salfr;
bcoefi = scale * salfi;
if (*left) {
bcoefi = -bcoefi;
}
dgemv_(trans, n, n, &acoef, &a[a_offset], lda, &e[jvec *
e_dim1 + 1], &c__1, &c_b12, &work[*n * (jvec - 1) + 1]
, &c__1);
d__1 = -bcoefr;
dgemv_(trans, n, n, &d__1, &b[b_offset], lda, &e[jvec *
e_dim1 + 1], &c__1, &c_b15, &work[*n * (jvec - 1) + 1]
, &c__1);
dgemv_(trans, n, n, &bcoefi, &b[b_offset], lda, &e[(jvec + 1)
* e_dim1 + 1], &c__1, &c_b15, &work[*n * (jvec - 1) +
1], &c__1);
dgemv_(trans, n, n, &acoef, &a[a_offset], lda, &e[(jvec + 1) *
e_dim1 + 1], &c__1, &c_b12, &work[*n * jvec + 1], &
c__1);
d__1 = -bcoefi;
dgemv_(trans, n, n, &d__1, &b[b_offset], lda, &e[jvec *
e_dim1 + 1], &c__1, &c_b15, &work[*n * jvec + 1], &
c__1);
d__1 = -bcoefr;
dgemv_(trans, n, n, &d__1, &b[b_offset], lda, &e[(jvec + 1) *
e_dim1 + 1], &c__1, &c_b15, &work[*n * jvec + 1], &
c__1);
}
}
/* L10: */
}
/* Computing 2nd power */
i__1 = *n;
errnrm = dlange_("One", n, n, &work[1], n, &work[i__1 * i__1 + 1]) / enorm;
/* Compute RESULT(1) */
result[1] = errnrm / ulp;
/* Normalization of E: */
enrmer = 0.;
ilcplx = FALSE_;
i__1 = *n;
for (jvec = 1; jvec <= i__1; ++jvec) {
if (ilcplx) {
ilcplx = FALSE_;
} else {
temp1 = 0.;
if (alphai[jvec] == 0.) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
d__2 = temp1, d__3 = (d__1 = e[j + jvec * e_dim1], abs(
d__1));
temp1 = max(d__2,d__3);
/* L20: */
}
/* Computing MAX */
d__1 = enrmer, d__2 = temp1 - 1.;
enrmer = max(d__1,d__2);
} else {
ilcplx = TRUE_;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
d__3 = temp1, d__4 = (d__1 = e[j + jvec * e_dim1], abs(
d__1)) + (d__2 = e[j + (jvec + 1) * e_dim1], abs(
d__2));
temp1 = max(d__3,d__4);
/* L30: */
}
/* Computing MAX */
d__1 = enrmer, d__2 = temp1 - 1.;
enrmer = max(d__1,d__2);
}
}
/* L40: */
}
/* Compute RESULT(2) : the normalization error in E. */
result[2] = enrmer / ((doublereal) (*n) * ulp);
return 0;
/* End of DGET52 */
} /* dget52_ */
/* Subroutine */ int ddrvge_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
doublereal *a, doublereal *afac, doublereal *asav, doublereal *b,
doublereal *bsav, doublereal *x, doublereal *xact, doublereal *s,
doublereal *work, doublereal *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char transs[1*3] = "N" "T" "C";
static char facts[1*3] = "F" "N" "E";
static char equeds[1*4] = "N" "R" "C" "B";
/* Format strings */
static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
", test(\002,i2,\002) =\002,g12.5)";
static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
"1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i2,\002"
", test(\002,i1,\002)=\002,g12.5)";
static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
"1,\002', N=\002,i5,\002, type \002,i2,\002, test(\002,i1,\002)"
"=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
doublereal d__1;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
extern /* Subroutine */ int debchvxx_(doublereal *, char *);
integer i__, k, n;
doublereal *errbnds_c__, *errbnds_n__;
integer k1, nb, in, kl, ku, nt, n_err_bnds__;
extern doublereal dla_rpvgrw__(integer *, integer *, doublereal *,
integer *, doublereal *, integer *);
integer lda;
char fact[1];
integer ioff, mode;
doublereal amax;
char path[3];
integer imat, info;
doublereal *berr;
char dist[1];
doublereal rpvgrw_svxx__;
char type__[1];
integer nrun;
extern /* Subroutine */ int dget01_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
doublereal *), dget02_(char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *);
integer ifact;
extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
integer nfail, iseed[4], nfact;
extern doublereal dget06_(doublereal *, doublereal *);
extern /* Subroutine */ int dget07_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, logical *,
doublereal *, doublereal *);
extern logical lsame_(char *, char *);
char equed[1];
integer nbmin;
doublereal rcond, roldc;
integer nimat;
doublereal roldi;
extern /* Subroutine */ int dgesv_(integer *, integer *, doublereal *,
integer *, integer *, doublereal *, integer *, integer *);
doublereal anorm;
integer itran;
logical equil;
doublereal roldo;
char trans[1];
integer izero, nerrs, lwork;
logical zerot;
char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), aladhd_(integer *,
char *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *), dlaqge_(integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, char *);
logical prefac;
doublereal colcnd, rcondc;
logical nofact;
integer iequed;
extern /* Subroutine */ int dgeequ_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *);
doublereal rcondi;
extern /* Subroutine */ int dgetrf_(integer *, integer *, doublereal *,
integer *, integer *, integer *), dgetri_(integer *, doublereal *,
integer *, integer *, doublereal *, integer *, integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *), alasvm_(char *, integer *,
integer *, integer *, integer *);
doublereal cndnum, anormi, rcondo, ainvnm;
extern doublereal dlantr_(char *, char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlarhs_(char *, char *, char *, char *,
integer *, integer *, integer *, integer *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
integer *, integer *);
logical trfcon;
doublereal anormo, rowcnd;
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
dgesvx_(char *, char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, char *, doublereal
*, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *
, integer *), dlatms_(integer *, integer *
, char *, integer *, char *, doublereal *, integer *, doublereal *
, doublereal *, integer *, integer *, char *, doublereal *,
integer *, doublereal *, integer *),
xlaenv_(integer *, integer *), derrvx_(char *, integer *);
doublereal result[7], rpvgrw;
extern /* Subroutine */ int dgesvxx_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
char *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___63 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___64 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___66 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___67 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___68 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___74 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___75 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___76 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___77 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___78 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___79 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___80 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___81 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DDRVGE tests the driver routines DGESV, -SVX, and -SVXX. */
/* Note that this file is used only when the XBLAS are available, */
/* otherwise ddrvge.f defines this subroutine. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* S (workspace) DOUBLE PRECISION array, dimension (2*NMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*NRHS+NMAX) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
derrvx_(path, nout);
}
infoc_1.infot = 0;
/* Set the block size and minimum block size for testing. */
nb = 1;
nbmin = 2;
xlaenv_(&c__1, &nb);
xlaenv_(&c__2, &nbmin);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 11;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L80;
}
/* Skip types 5, 6, or 7 if the matrix size is too small. */
zerot = imat >= 5 && imat <= 7;
if (zerot && n < imat - 4) {
goto L80;
}
/* Set up parameters with DLATB4 and generate a test matrix */
/* with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cndnum, dist);
rcondc = 1. / cndnum;
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cndnum, &
anorm, &kl, &ku, "No packing", &a[1], &lda, &work[1], &
info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, " ", &n, &n, &c_n1, &
c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L80;
}
/* For types 5-7, zero one or more columns of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 5) {
izero = 1;
} else if (imat == 6) {
izero = n;
} else {
izero = n / 2 + 1;
}
ioff = (izero - 1) * lda;
if (imat < 7) {
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
} else {
i__3 = n - izero + 1;
dlaset_("Full", &n, &i__3, &c_b20, &c_b20, &a[ioff + 1], &
lda);
}
} else {
izero = 0;
}
/* Save a copy of the matrix A in ASAV. */
dlacpy_("Full", &n, &n, &a[1], &lda, &asav[1], &lda);
for (iequed = 1; iequed <= 4; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[iequed -
1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__3 = nfact;
for (ifact = 1; ifact <= i__3; ++ifact) {
*(unsigned char *)fact = *(unsigned char *)&facts[ifact -
1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L60;
}
rcondo = 0.;
rcondi = 0.;
} else if (! nofact) {
/* Compute the condition number for comparison with */
/* the value returned by DGESVX (FACT = 'N' reuses */
/* the condition number from the previous iteration */
/* with FACT = 'F'). */
dlacpy_("Full", &n, &n, &asav[1], &lda, &afac[1], &
lda);
if (equil || iequed > 1) {
/* Compute row and column scale factors to */
/* equilibrate the matrix A. */
dgeequ_(&n, &n, &afac[1], &lda, &s[1], &s[n + 1],
&rowcnd, &colcnd, &amax, &info);
if (info == 0 && n > 0) {
if (lsame_(equed, "R"))
{
rowcnd = 0.;
colcnd = 1.;
} else if (lsame_(equed, "C")) {
rowcnd = 1.;
colcnd = 0.;
} else if (lsame_(equed, "B")) {
rowcnd = 0.;
colcnd = 0.;
}
/* Equilibrate the matrix. */
dlaqge_(&n, &n, &afac[1], &lda, &s[1], &s[n +
1], &rowcnd, &colcnd, &amax, equed);
}
}
/* Save the condition number of the non-equilibrated */
/* system for use in DGET04. */
if (equil) {
roldo = rcondo;
roldi = rcondi;
}
/* Compute the 1-norm and infinity-norm of A. */
anormo = dlange_("1", &n, &n, &afac[1], &lda, &rwork[
1]);
anormi = dlange_("I", &n, &n, &afac[1], &lda, &rwork[
1]);
/* Factor the matrix A. */
dgetrf_(&n, &n, &afac[1], &lda, &iwork[1], &info);
/* Form the inverse of A. */
dlacpy_("Full", &n, &n, &afac[1], &lda, &a[1], &lda);
lwork = *nmax * max(3,*nrhs);
dgetri_(&n, &a[1], &lda, &iwork[1], &work[1], &lwork,
&info);
/* Compute the 1-norm condition number of A. */
ainvnm = dlange_("1", &n, &n, &a[1], &lda, &rwork[1]);
if (anormo <= 0. || ainvnm <= 0.) {
rcondo = 1.;
} else {
rcondo = 1. / anormo / ainvnm;
}
/* Compute the infinity-norm condition number of A. */
ainvnm = dlange_("I", &n, &n, &a[1], &lda, &rwork[1]);
if (anormi <= 0. || ainvnm <= 0.) {
rcondi = 1.;
} else {
rcondi = 1. / anormi / ainvnm;
}
}
for (itran = 1; itran <= 3; ++itran) {
for (i__ = 1; i__ <= 7; ++i__) {
result[i__ - 1] = 0.;
}
/* Do for each value of TRANS. */
*(unsigned char *)trans = *(unsigned char *)&transs[
itran - 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Restore the matrix A. */
dlacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
6);
dlarhs_(path, xtype, "Full", trans, &n, &n, &kl, &ku,
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
*(unsigned char *)xtype = 'C';
dlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
if (nofact && itran == 1) {
/* --- Test DGESV --- */
/* Compute the LU factorization of the matrix and */
/* solve the system. */
dlacpy_("Full", &n, &n, &a[1], &lda, &afac[1], &
lda);
dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "DGESV ", (ftnlen)32, (
ftnlen)6);
dgesv_(&n, nrhs, &afac[1], &lda, &iwork[1], &x[1],
&lda, &info);
/* Check error code from DGESV . */
if (info != izero) {
alaerh_(path, "DGESV ", &info, &izero, " ", &
n, &n, &c_n1, &c_n1, nrhs, &imat, &
nfail, &nerrs, nout);
goto L50;
}
/* Reconstruct matrix from factors and compute */
/* residual. */
dget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
iwork[1], &rwork[1], result);
nt = 1;
if (izero == 0) {
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[
1], &lda);
dget02_("No transpose", &n, &n, nrhs, &a[1], &
lda, &x[1], &lda, &work[1], &lda, &
rwork[1], &result[1]);
/* Check solution from generated exact solution. */
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not */
/* pass the threshold. */
i__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___55.ciunit = *nout;
s_wsfe(&io___55);
do_fio(&c__1, "DGESV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L30: */
}
nrun += nt;
}
/* --- Test DGESVX --- */
if (! prefac) {
dlaset_("Full", &n, &n, &c_b20, &c_b20, &afac[1],
&lda);
}
dlaset_("Full", &n, nrhs, &c_b20, &c_b20, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT = 'F' and */
/* EQUED = 'R', 'C', or 'B'. */
dlaqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
rowcnd, &colcnd, &amax, equed);
}
/* Solve the system and compute the condition number */
/* and error bounds using DGESVX. */
s_copy(srnamc_1.srnamt, "DGESVX", (ftnlen)32, (ftnlen)
6);
dgesvx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
&lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
1], &lda, &x[1], &lda, &rcond, &rwork[1], &
rwork[*nrhs + 1], &work[1], &iwork[n + 1], &
info);
/* Check the error code from DGESVX. */
if (info == n + 1) {
goto L50;
}
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "DGESVX", &info, &izero, ch__1, &n,
&n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
nerrs, nout);
goto L50;
}
/* Compare WORK(1) from DGESVX with the computed */
/* reciprocal pivot growth factor RPVGRW */
if (info != 0) {
rpvgrw = dlantr_("M", "U", "N", &info, &info, &
afac[1], &lda, &work[1]);
if (rpvgrw == 0.) {
rpvgrw = 1.;
} else {
rpvgrw = dlange_("M", &n, &info, &a[1], &lda,
&work[1]) / rpvgrw;
}
} else {
rpvgrw = dlantr_("M", "U", "N", &n, &n, &afac[1],
&lda, &work[1]);
if (rpvgrw == 0.) {
rpvgrw = 1.;
} else {
rpvgrw = dlange_("M", &n, &n, &a[1], &lda, &
work[1]) / rpvgrw;
}
}
result[6] = (d__1 = rpvgrw - work[1], abs(d__1)) /
max(work[1],rpvgrw) / dlamch_("E");
if (! prefac) {
/* Reconstruct matrix from factors and compute */
/* residual. */
dget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
iwork[1], &rwork[(*nrhs << 1) + 1],
result);
k1 = 1;
} else {
k1 = 2;
}
if (info == 0) {
trfcon = FALSE_;
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
dget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
, &lda, &work[1], &lda, &rwork[(*nrhs <<
1) + 1], &result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
if (itran == 1) {
roldc = roldo;
} else {
roldc = roldi;
}
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
/* Check the error bounds from iterative */
/* refinement. */
dget07_(trans, &n, nrhs, &asav[1], &lda, &b[1], &
lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &c_true, &rwork[*nrhs + 1], &result[3]
);
} else {
trfcon = TRUE_;
}
/* Compare RCOND from DGESVX with the computed value */
/* in RCONDC. */
result[5] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
if (! trfcon) {
for (k = k1; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___61.ciunit = *nout;
s_wsfe(&io___61);
do_fio(&c__1, "DGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___62.ciunit = *nout;
s_wsfe(&io___62);
do_fio(&c__1, "DGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(doublereal));
e_wsfe();
}
++nfail;
}
/* L40: */
}
nrun = nrun + 7 - k1;
} else {
if (result[0] >= *thresh && ! prefac) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___63.ciunit = *nout;
s_wsfe(&io___63);
do_fio(&c__1, "DGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___64.ciunit = *nout;
s_wsfe(&io___64);
do_fio(&c__1, "DGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
++nfail;
++nrun;
}
if (result[5] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___65.ciunit = *nout;
s_wsfe(&io___65);
do_fio(&c__1, "DGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__6, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[5], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___66.ciunit = *nout;
s_wsfe(&io___66);
do_fio(&c__1, "DGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__6, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[5], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
++nfail;
++nrun;
}
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___67.ciunit = *nout;
s_wsfe(&io___67);
do_fio(&c__1, "DGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___68.ciunit = *nout;
s_wsfe(&io___68);
do_fio(&c__1, "DGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
++nfail;
++nrun;
}
}
/* --- Test DGESVXX --- */
/* Restore the matrices A and B. */
dlacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &b[1], &lda);
if (! prefac) {
dlaset_("Full", &n, &n, &c_b20, &c_b20, &afac[1],
&lda);
}
dlaset_("Full", &n, nrhs, &c_b20, &c_b20, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT = 'F' and */
/* EQUED = 'R', 'C', or 'B'. */
dlaqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
rowcnd, &colcnd, &amax, equed);
}
/* Solve the system and compute the condition number */
/* and error bounds using DGESVXX. */
s_copy(srnamc_1.srnamt, "DGESVXX", (ftnlen)32, (
ftnlen)7);
n_err_bnds__ = 3;
dalloc3();
dgesvxx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
&lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
1], &lda, &x[1], &lda, &rcond, &rpvgrw_svxx__,
berr, &n_err_bnds__, errbnds_n__,
errbnds_c__, &c__0, &c_b20, &work[1], &iwork[
n + 1], &info);
free3();
/* Check the error code from DGESVXX. */
if (info == n + 1) {
goto L50;
}
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "DGESVXX", &info, &izero, ch__1, &n,
&n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
nerrs, nout);
goto L50;
}
/* Compare rpvgrw_svxx from DGESVXX with the computed */
/* reciprocal pivot growth factor RPVGRW */
if (info > 0 && info < n + 1) {
rpvgrw = dla_rpvgrw__(&n, &info, &a[1], &lda, &
afac[1], &lda);
} else {
rpvgrw = dla_rpvgrw__(&n, &n, &a[1], &lda, &afac[
1], &lda);
}
result[6] = (d__1 = rpvgrw - rpvgrw_svxx__, abs(d__1))
/ max(rpvgrw_svxx__,rpvgrw) / dlamch_("E");
if (! prefac) {
/* Reconstruct matrix from factors and compute */
/* residual. */
dget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
iwork[1], &rwork[(*nrhs << 1) + 1],
result);
k1 = 1;
} else {
k1 = 2;
}
if (info == 0) {
trfcon = FALSE_;
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
dget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
, &lda, &work[1], &lda, &rwork[(*nrhs <<
1) + 1], &result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
if (itran == 1) {
roldc = roldo;
} else {
roldc = roldi;
}
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
} else {
trfcon = TRUE_;
}
/* Compare RCOND from DGESVXX with the computed value */
/* in RCONDC. */
result[5] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
if (! trfcon) {
for (k = k1; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___74.ciunit = *nout;
s_wsfe(&io___74);
do_fio(&c__1, "DGESVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___75.ciunit = *nout;
s_wsfe(&io___75);
do_fio(&c__1, "DGESVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(doublereal));
e_wsfe();
}
++nfail;
}
/* L45: */
}
nrun = nrun + 7 - k1;
} else {
if (result[0] >= *thresh && ! prefac) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___76.ciunit = *nout;
s_wsfe(&io___76);
do_fio(&c__1, "DGESVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___77.ciunit = *nout;
s_wsfe(&io___77);
do_fio(&c__1, "DGESVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
++nfail;
++nrun;
}
if (result[5] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___78.ciunit = *nout;
s_wsfe(&io___78);
do_fio(&c__1, "DGESVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__6, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[5], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___79.ciunit = *nout;
s_wsfe(&io___79);
do_fio(&c__1, "DGESVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__6, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[5], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
++nfail;
++nrun;
}
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___80.ciunit = *nout;
s_wsfe(&io___80);
do_fio(&c__1, "DGESVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___81.ciunit = *nout;
s_wsfe(&io___81);
do_fio(&c__1, "DGESVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
++nfail;
++nrun;
}
}
L50:
;
}
L60:
;
}
/* L70: */
}
L80:
;
}
/* L90: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
/* Test Error Bounds from DGESVXX */
debchvxx_(thresh, path);
return 0;
/* End of DDRVGE */
} /* ddrvge_ */
/* Subroutine */ int dggevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, doublereal *a, integer *lda, doublereal *b,
integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
beta, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr,
integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale,
doublereal *abnrm, doublereal *bbnrm, doublereal *rconde, doublereal *
rcondv, doublereal *work, integer *lwork, integer *iwork, logical *
bwork, integer *info)
{
/* -- LAPACK driver 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
=======
DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)
the generalized eigenvalues, and optionally, the left and/or right
generalized eigenvectors.
Optionally also, it computes a balancing transformation to improve
the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
the eigenvalues (RCONDE), and reciprocal condition numbers for the
right eigenvectors (RCONDV).
A generalized eigenvalue for a pair of matrices (A,B) is a scalar
lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
singular. It is usually represented as the pair (alpha,beta), as
there is a reasonable interpretation for beta=0, and even for both
being zero.
The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
of (A,B) satisfies
A * v(j) = lambda(j) * B * v(j) .
The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
of (A,B) satisfies
u(j)**H * A = lambda(j) * u(j)**H * B.
where u(j)**H is the conjugate-transpose of u(j).
Arguments
=========
BALANC (input) CHARACTER*1
Specifies the balance option to be performed.
= 'N': do not diagonally scale or permute;
= 'P': permute only;
= 'S': scale only;
= 'B': both permute and scale.
Computed reciprocal condition numbers will be for the
matrices after permuting and/or balancing. Permuting does
not change condition numbers (in exact arithmetic), but
balancing does.
JOBVL (input) CHARACTER*1
= 'N': do not compute the left generalized eigenvectors;
= 'V': compute the left generalized eigenvectors.
JOBVR (input) CHARACTER*1
= 'N': do not compute the right generalized eigenvectors;
= 'V': compute the right generalized eigenvectors.
SENSE (input) CHARACTER*1
Determines which reciprocal condition numbers are computed.
= 'N': none are computed;
= 'E': computed for eigenvalues only;
= 'V': computed for eigenvectors only;
= 'B': computed for eigenvalues and eigenvectors.
N (input) INTEGER
The order of the matrices A, B, VL, and VR. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
On entry, the matrix A in the pair (A,B).
On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'
or both, then A contains the first part of the real Schur
form of the "balanced" versions of the input A and B.
LDA (input) INTEGER
The leading dimension of A. LDA >= max(1,N).
B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
On entry, the matrix B in the pair (A,B).
On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'
or both, then B contains the second part of the real Schur
form of the "balanced" versions of the input A and B.
LDB (input) INTEGER
The leading dimension of B. LDB >= max(1,N).
ALPHAR (output) DOUBLE PRECISION array, dimension (N)
ALPHAI (output) DOUBLE PRECISION array, dimension (N)
BETA (output) DOUBLE PRECISION array, dimension (N)
On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
be the generalized eigenvalues. If ALPHAI(j) is zero, then
the j-th eigenvalue is real; if positive, then the j-th and
(j+1)-st eigenvalues are a complex conjugate pair, with
ALPHAI(j+1) negative.
Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
may easily over- or underflow, and BETA(j) may even be zero.
Thus, the user should avoid naively computing the ratio
ALPHA/BETA. However, ALPHAR and ALPHAI will be always less
than and usually comparable with norm(A) in magnitude, and
BETA always less than and usually comparable with norm(B).
VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
If JOBVL = 'V', the left eigenvectors u(j) are stored one
after another in the columns of VL, in the same order as
their eigenvalues. If the j-th eigenvalue is real, then
u(j) = VL(:,j), the j-th column of VL. If the j-th and
(j+1)-th eigenvalues form a complex conjugate pair, then
u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
Each eigenvector will be scaled so the largest component have
abs(real part) + abs(imag. part) = 1.
Not referenced if JOBVL = 'N'.
LDVL (input) INTEGER
The leading dimension of the matrix VL. LDVL >= 1, and
if JOBVL = 'V', LDVL >= N.
VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
If JOBVR = 'V', the right eigenvectors v(j) are stored one
after another in the columns of VR, in the same order as
their eigenvalues. If the j-th eigenvalue is real, then
v(j) = VR(:,j), the j-th column of VR. If the j-th and
(j+1)-th eigenvalues form a complex conjugate pair, then
v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
Each eigenvector will be scaled so the largest component have
abs(real part) + abs(imag. part) = 1.
Not referenced if JOBVR = 'N'.
LDVR (input) INTEGER
The leading dimension of the matrix VR. LDVR >= 1, and
if JOBVR = 'V', LDVR >= N.
ILO,IHI (output) INTEGER
ILO and IHI are integer values such that on exit
A(i,j) = 0 and B(i,j) = 0 if i > j and
j = 1,...,ILO-1 or i = IHI+1,...,N.
If BALANC = 'N' or 'S', ILO = 1 and IHI = N.
LSCALE (output) DOUBLE PRECISION array, dimension (N)
Details of the permutations and scaling factors applied
to the left side of A and B. If PL(j) is the index of the
row interchanged with row j, and DL(j) is the scaling
factor applied to row j, then
LSCALE(j) = PL(j) for j = 1,...,ILO-1
= DL(j) for j = ILO,...,IHI
= PL(j) for j = IHI+1,...,N.
The order in which the interchanges are made is N to IHI+1,
then 1 to ILO-1.
RSCALE (output) DOUBLE PRECISION array, dimension (N)
Details of the permutations and scaling factors applied
to the right side of A and B. If PR(j) is the index of the
column interchanged with column j, and DR(j) is the scaling
factor applied to column j, then
RSCALE(j) = PR(j) for j = 1,...,ILO-1
= DR(j) for j = ILO,...,IHI
= PR(j) for j = IHI+1,...,N
The order in which the interchanges are made is N to IHI+1,
then 1 to ILO-1.
ABNRM (output) DOUBLE PRECISION
The one-norm of the balanced matrix A.
BBNRM (output) DOUBLE PRECISION
The one-norm of the balanced matrix B.
RCONDE (output) DOUBLE PRECISION array, dimension (N)
If SENSE = 'E' or 'B', the reciprocal condition numbers of
the selected eigenvalues, stored in consecutive elements of
the array. For a complex conjugate pair of eigenvalues two
consecutive elements of RCONDE are set to the same value.
Thus RCONDE(j), RCONDV(j), and the j-th columns of VL and VR
all correspond to the same eigenpair (but not in general the
j-th eigenpair, unless all eigenpairs are selected).
If SENSE = 'V', RCONDE is not referenced.
RCONDV (output) DOUBLE PRECISION array, dimension (N)
If SENSE = 'V' or 'B', the estimated reciprocal condition
numbers of the selected eigenvectors, stored in consecutive
elements of the array. For a complex eigenvector two
consecutive elements of RCONDV are set to the same value. If
the eigenvalues cannot be reordered to compute RCONDV(j),
RCONDV(j) is set to 0; this can only occur when the true
value would be very small anyway.
If SENSE = 'E', RCONDV is not referenced.
WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,6*N).
If SENSE = 'E', LWORK >= 12*N.
If SENSE = 'V' or 'B', LWORK >= 2*N*N+12*N+16.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
IWORK (workspace) INTEGER array, dimension (N+6)
If SENSE = 'E', IWORK is not referenced.
BWORK (workspace) LOGICAL array, dimension (N)
If SENSE = 'N', BWORK is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
= 1,...,N:
The QZ iteration failed. No eigenvectors have been
calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
should be correct for j=INFO+1,...,N.
> N: =N+1: other than QZ iteration failed in DHGEQZ.
=N+2: error return from DTGEVC.
Further Details
===============
Balancing a matrix pair (A,B) includes, first, permuting rows and
columns to isolate eigenvalues, second, applying diagonal similarity
transformation to the rows and columns to make the rows and columns
as close in norm as possible. The computed reciprocal condition
numbers correspond to the balanced matrix. Permuting rows and columns
will not change the condition numbers (in exact arithmetic) but
diagonal scaling will. For further explanation of balancing, see
section 4.11.1.2 of LAPACK Users' Guide.
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(ABNRM, BBNRM) / RCONDE(I)
An approximate error bound for the angle between the i-th computed
eigenvector VL(i) or VR(i) is given by
EPS * norm(ABNRM, BBNRM) / DIF(i).
For further explanation of the reciprocal condition numbers RCONDE
and RCONDV, see section 4.11 of LAPACK User's Guide.
=====================================================================
Decode the input arguments
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c__0 = 0;
static doublereal c_b47 = 0.;
static doublereal c_b48 = 1.;
/* 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, d__3, d__4;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static logical pair;
static doublereal anrm, bnrm;
static integer ierr, itau;
static doublereal temp;
static logical ilvl, ilvr;
static integer iwrk, iwrk1, i__, j, m;
extern logical lsame_(char *, char *);
static integer icols, irows;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
static integer jc;
extern /* Subroutine */ int dggbak_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, integer *), dggbal_(char *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
static integer in;
extern doublereal dlamch_(char *);
static integer mm;
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
static integer jr;
extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal
*, doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
static logical ilascl, ilbscl;
extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *);
static logical ldumma[1];
static char chtemp[1];
static doublereal bignum;
extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *), dlaset_(char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
static integer ijobvl;
extern /* Subroutine */ int dtgevc_(char *, char *, logical *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *,
doublereal *, integer *), dtgsna_(char *, char *,
logical *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer ijobvr;
static logical wantsb;
extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *);
static doublereal anrmto;
static logical wantse;
static doublereal bnrmto;
extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
static integer minwrk, maxwrk;
static logical wantsn;
static doublereal smlnum;
static logical lquery, wantsv;
static doublereal eps;
static logical ilv;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define vl_ref(a_1,a_2) vl[(a_2)*vl_dim1 + a_1]
#define vr_ref(a_1,a_2) vr[(a_2)*vr_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alphar;
--alphai;
--beta;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
--lscale;
--rscale;
--rconde;
--rcondv;
--work;
--iwork;
--bwork;
/* Function Body */
if (lsame_(jobvl, "N")) {
ijobvl = 1;
ilvl = FALSE_;
} else if (lsame_(jobvl, "V")) {
ijobvl = 2;
ilvl = TRUE_;
} else {
ijobvl = -1;
ilvl = FALSE_;
}
if (lsame_(jobvr, "N")) {
ijobvr = 1;
ilvr = FALSE_;
} else if (lsame_(jobvr, "V")) {
ijobvr = 2;
ilvr = TRUE_;
} else {
ijobvr = -1;
ilvr = FALSE_;
}
ilv = ilvl || ilvr;
wantsn = lsame_(sense, "N");
wantse = lsame_(sense, "E");
wantsv = lsame_(sense, "V");
wantsb = lsame_(sense, "B");
/* Test the input arguments */
*info = 0;
lquery = *lwork == -1;
if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
|| lsame_(balanc, "B"))) {
*info = -1;
} else if (ijobvl <= 0) {
*info = -2;
} else if (ijobvr <= 0) {
*info = -3;
} else if (! (wantsn || wantse || wantsb || wantsv)) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldvl < 1 || ilvl && *ldvl < *n) {
*info = -14;
} else if (*ldvr < 1 || ilvr && *ldvr < *n) {
*info = -16;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV. The workspace is
computed assuming ILO = 1 and IHI = N, the worst case.) */
minwrk = 1;
if (*info == 0 && (*lwork >= 1 || lquery)) {
maxwrk = *n * 5 + *n * ilaenv_(&c__1, "DGEQRF", " ", n, &c__1, n, &
c__0, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = 1, i__2 = *n * 6;
minwrk = max(i__1,i__2);
if (wantse) {
/* Computing MAX */
i__1 = 1, i__2 = *n * 12;
minwrk = max(i__1,i__2);
} else if (wantsv || wantsb) {
minwrk = (*n << 1) * *n + *n * 12 + 16;
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) * *n + *n * 12 + 16;
maxwrk = max(i__1,i__2);
}
work[1] = (doublereal) maxwrk;
}
if (*lwork < minwrk && ! lquery) {
*info = -26;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGGEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]);
ilascl = FALSE_;
if (anrm > 0. && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
ierr);
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]);
ilbscl = FALSE_;
if (bnrm > 0. && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
ierr);
}
/* Permute and/or balance the matrix pair (A,B)
(Workspace: need 6*N) */
dggbal_(balanc, n, &a[a_offset], lda, &b[b_offset], ldb, ilo, ihi, &
lscale[1], &rscale[1], &work[1], &ierr);
/* Compute ABNRM and BBNRM */
*abnrm = dlange_("1", n, n, &a[a_offset], lda, &work[1]);
if (ilascl) {
work[1] = *abnrm;
dlascl_("G", &c__0, &c__0, &anrmto, &anrm, &c__1, &c__1, &work[1], &
c__1, &ierr);
*abnrm = work[1];
}
*bbnrm = dlange_("1", n, n, &b[b_offset], ldb, &work[1]);
if (ilbscl) {
work[1] = *bbnrm;
dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, &c__1, &c__1, &work[1], &
c__1, &ierr);
*bbnrm = work[1];
}
/* Reduce B to triangular form (QR decomposition of B)
(Workspace: need N, prefer N*NB ) */
irows = *ihi + 1 - *ilo;
if (ilv || ! wantsn) {
icols = *n + 1 - *ilo;
} else {
icols = irows;
}
itau = 1;
iwrk = itau + irows;
i__1 = *lwork + 1 - iwrk;
dgeqrf_(&irows, &icols, &b_ref(*ilo, *ilo), ldb, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Apply the orthogonal transformation to A
(Workspace: need N, prefer N*NB) */
i__1 = *lwork + 1 - iwrk;
dormqr_("L", "T", &irows, &icols, &irows, &b_ref(*ilo, *ilo), ldb, &work[
itau], &a_ref(*ilo, *ilo), lda, &work[iwrk], &i__1, &ierr);
/* Initialize VL and/or VR
(Workspace: need N, prefer N*NB) */
if (ilvl) {
dlaset_("Full", n, n, &c_b47, &c_b48, &vl[vl_offset], ldvl)
;
i__1 = irows - 1;
i__2 = irows - 1;
dlacpy_("L", &i__1, &i__2, &b_ref(*ilo + 1, *ilo), ldb, &vl_ref(*ilo
+ 1, *ilo), ldvl);
i__1 = *lwork + 1 - iwrk;
dorgqr_(&irows, &irows, &irows, &vl_ref(*ilo, *ilo), ldvl, &work[itau]
, &work[iwrk], &i__1, &ierr);
}
if (ilvr) {
dlaset_("Full", n, n, &c_b47, &c_b48, &vr[vr_offset], ldvr)
;
}
/* Reduce to generalized Hessenberg form
(Workspace: none needed) */
if (ilv || ! wantsn) {
/* Eigenvectors requested -- work on whole matrix. */
dgghrd_(jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
} else {
dgghrd_("N", "N", &irows, &c__1, &irows, &a_ref(*ilo, *ilo), lda, &
b_ref(*ilo, *ilo), ldb, &vl[vl_offset], ldvl, &vr[vr_offset],
ldvr, &ierr);
}
/* Perform QZ algorithm (Compute eigenvalues, and optionally, the
Schur forms and Schur vectors)
(Workspace: need N) */
if (ilv || ! wantsn) {
*(unsigned char *)chtemp = 'S';
} else {
*(unsigned char *)chtemp = 'E';
}
dhgeqz_(chtemp, jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset]
, ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], ldvl, &
vr[vr_offset], ldvr, &work[1], lwork, &ierr);
if (ierr != 0) {
if (ierr > 0 && ierr <= *n) {
*info = ierr;
} else if (ierr > *n && ierr <= *n << 1) {
*info = ierr - *n;
} else {
*info = *n + 1;
}
goto L130;
}
/* Compute Eigenvectors and estimate condition numbers if desired
(Workspace: DTGEVC: need 6*N
DTGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B',
need N otherwise ) */
if (ilv || ! wantsn) {
if (ilv) {
if (ilvl) {
if (ilvr) {
*(unsigned char *)chtemp = 'B';
} else {
*(unsigned char *)chtemp = 'L';
}
} else {
*(unsigned char *)chtemp = 'R';
}
dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset],
ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &
work[1], &ierr);
if (ierr != 0) {
*info = *n + 2;
goto L130;
}
}
if (! wantsn) {
/* compute eigenvectors (DTGEVC) and estimate condition
numbers (DTGSNA). Note that the definition of the condition
number is not invariant under transformation (u,v) to
(Q*u, Z*v), where (u,v) are eigenvectors of the generalized
Schur form (S,T), Q and Z are orthogonal matrices. In order
to avoid using extra 2*N*N workspace, we have to recalculate
eigenvectors and estimate one condition numbers at a time. */
pair = FALSE_;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (pair) {
pair = FALSE_;
goto L20;
}
mm = 1;
if (i__ < *n) {
if (a_ref(i__ + 1, i__) != 0.) {
pair = TRUE_;
mm = 2;
}
}
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
bwork[j] = FALSE_;
/* L10: */
}
if (mm == 1) {
bwork[i__] = TRUE_;
} else if (mm == 2) {
bwork[i__] = TRUE_;
bwork[i__ + 1] = TRUE_;
}
iwrk = mm * *n + 1;
iwrk1 = iwrk + mm * *n;
/* Compute a pair of left and right eigenvectors.
(compute workspace: need up to 4*N + 6*N) */
if (wantse || wantsb) {
dtgevc_("B", "S", &bwork[1], n, &a[a_offset], lda, &b[
b_offset], ldb, &work[1], n, &work[iwrk], n, &mm,
&m, &work[iwrk1], &ierr);
if (ierr != 0) {
*info = *n + 2;
goto L130;
}
}
i__2 = *lwork - iwrk1 + 1;
dtgsna_(sense, "S", &bwork[1], n, &a[a_offset], lda, &b[
b_offset], ldb, &work[1], n, &work[iwrk], n, &rconde[
i__], &rcondv[i__], &mm, &m, &work[iwrk1], &i__2, &
iwork[1], &ierr);
L20:
;
}
}
}
/* Undo balancing on VL and VR and normalization
(Workspace: none needed) */
if (ilvl) {
dggbak_(balanc, "L", n, ilo, ihi, &lscale[1], &rscale[1], n, &vl[
vl_offset], ldvl, &ierr);
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
if (alphai[jc] < 0.) {
goto L70;
}
temp = 0.;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = vl_ref(jr, jc), abs(d__1));
temp = max(d__2,d__3);
/* L30: */
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__3 = temp, d__4 = (d__1 = vl_ref(jr, jc), abs(d__1)) + (
d__2 = vl_ref(jr, jc + 1), abs(d__2));
temp = max(d__3,d__4);
/* L40: */
}
}
if (temp < smlnum) {
goto L70;
}
temp = 1. / temp;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vl_ref(jr, jc) = vl_ref(jr, jc) * temp;
/* L50: */
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vl_ref(jr, jc) = vl_ref(jr, jc) * temp;
vl_ref(jr, jc + 1) = vl_ref(jr, jc + 1) * temp;
/* L60: */
}
}
L70:
;
}
}
if (ilvr) {
dggbak_(balanc, "R", n, ilo, ihi, &lscale[1], &rscale[1], n, &vr[
vr_offset], ldvr, &ierr);
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
if (alphai[jc] < 0.) {
goto L120;
}
temp = 0.;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = vr_ref(jr, jc), abs(d__1));
temp = max(d__2,d__3);
/* L80: */
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__3 = temp, d__4 = (d__1 = vr_ref(jr, jc), abs(d__1)) + (
d__2 = vr_ref(jr, jc + 1), abs(d__2));
temp = max(d__3,d__4);
/* L90: */
}
}
if (temp < smlnum) {
goto L120;
}
temp = 1. / temp;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vr_ref(jr, jc) = vr_ref(jr, jc) * temp;
/* L100: */
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vr_ref(jr, jc) = vr_ref(jr, jc) * temp;
vr_ref(jr, jc + 1) = vr_ref(jr, jc + 1) * temp;
/* L110: */
}
}
L120:
;
}
}
/* Undo scaling if necessary */
if (ilascl) {
dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
ierr);
dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
ierr);
}
if (ilbscl) {
dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
ierr);
}
L130:
work[1] = (doublereal) maxwrk;
return 0;
/* End of DGGEVX */
} /* dggevx_ */
/* Subroutine */ int dgels_(char *trans, integer *m, integer *n, integer *
nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb,
doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
integer i__, j, nb, mn;
doublereal anrm, bnrm;
integer brow;
logical tpsd;
integer iascl, ibscl;
extern logical lsame_(char *, char *);
integer wsize;
doublereal rwork[1];
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *),
dlascl_(char *, integer *, integer *, doublereal *, doublereal *,
integer *, integer *, doublereal *, integer *, integer *),
dgeqrf_(integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
integer scllen;
doublereal bignum;
extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *),
dormqr_(char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *);
doublereal smlnum;
logical lquery;
extern /* Subroutine */ int dtrtrs_(char *, char *, char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *);
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGELS solves overdetermined or underdetermined real linear systems */
/* involving an M-by-N matrix A, or its transpose, using a QR or LQ */
/* factorization of A. It is assumed that A has full rank. */
/* The following options are provided: */
/* 1. If TRANS = 'N' and m >= n: find the least squares solution of */
/* an overdetermined system, i.e., solve the least squares problem */
/* minimize || B - A*X ||. */
/* 2. If TRANS = 'N' and m < n: find the minimum norm solution of */
/* an underdetermined system A * X = B. */
/* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of */
/* an undetermined system A**T * X = B. */
/* 4. If TRANS = 'T' and m < n: find the least squares solution of */
/* an overdetermined system, i.e., solve the least squares problem */
/* minimize || B - A**T * X ||. */
/* Several right hand side vectors b and solution vectors x can be */
/* handled in a single call; they are stored as the columns of the */
/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
/* matrix X. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* = 'N': the linear system involves A; */
/* = 'T': the linear system involves A**T. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of */
/* columns of the matrices B and X. NRHS >=0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, */
/* if M >= N, A is overwritten by details of its QR */
/* factorization as returned by DGEQRF; */
/* if M < N, A is overwritten by details of its LQ */
/* factorization as returned by DGELQF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the matrix B of right hand side vectors, stored */
/* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS */
/* if TRANS = 'T'. */
/* On exit, if INFO = 0, B is overwritten by the solution */
/* vectors, stored columnwise: */
/* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least */
/* squares solution vectors; the residual sum of squares for the */
/* solution in each column is given by the sum of squares of */
/* elements N+1 to M in that column; */
/* if TRANS = 'N' and m < n, rows 1 to N of B contain the */
/* minimum norm solution vectors; */
/* if TRANS = 'T' and m >= n, rows 1 to M of B contain the */
/* minimum norm solution vectors; */
/* if TRANS = 'T' and m < n, rows 1 to M of B contain the */
/* least squares solution vectors; the residual sum of squares */
/* for the solution in each column is given by the sum of */
/* squares of elements M+1 to N in that column. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,M,N). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* LWORK >= max( 1, MN + max( MN, NRHS ) ). */
/* For optimal performance, */
/* LWORK >= max( 1, MN + max( MN, NRHS )*NB ). */
/* where MN = min(M,N) and NB is the optimum block size. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the i-th diagonal element of the */
/* triangular factor of A is zero, so that A does not have */
/* full rank; the least squares solution could not be */
/* computed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
*info = 0;
mn = min(*m,*n);
lquery = *lwork == -1;
if (! (lsame_(trans, "N") || lsame_(trans, "T"))) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -6;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = max(1,*m);
if (*ldb < max(i__1,*n)) {
*info = -8;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = mn + max(mn,*nrhs);
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -10;
}
}
}
/* Figure out optimal block size */
if (*info == 0 || *info == -10) {
tpsd = TRUE_;
if (lsame_(trans, "N")) {
tpsd = FALSE_;
}
if (*m >= *n) {
nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1);
if (tpsd) {
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LN", m, nrhs, n, &
c_n1);
nb = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LT", m, nrhs, n, &
c_n1);
nb = max(i__1,i__2);
}
} else {
nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1);
if (tpsd) {
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LT", n, nrhs, m, &
c_n1);
nb = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LN", n, nrhs, m, &
c_n1);
nb = max(i__1,i__2);
}
}
/* Computing MAX */
i__1 = 1, i__2 = mn + max(mn,*nrhs) * nb;
wsize = max(i__1,i__2);
work[1] = (doublereal) wsize;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGELS ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
/* Computing MIN */
i__1 = min(*m,*n);
if (min(i__1,*nrhs) == 0) {
i__1 = max(*m,*n);
dlaset_("Full", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb);
return 0;
}
/* Get machine parameters */
smlnum = dlamch_("S") / dlamch_("P");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Scale A, B if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", m, n, &a[a_offset], lda, rwork);
iascl = 0;
if (anrm > 0. && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
info);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
info);
iascl = 2;
} else if (anrm == 0.) {
/* Matrix all zero. Return zero solution. */
i__1 = max(*m,*n);
dlaset_("F", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb);
goto L50;
}
brow = *m;
if (tpsd) {
brow = *n;
}
bnrm = dlange_("M", &brow, nrhs, &b[b_offset], ldb, rwork);
ibscl = 0;
if (bnrm > 0. && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset],
ldb, info);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM */
dlascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset],
ldb, info);
ibscl = 2;
}
if (*m >= *n) {
/* compute QR factorization of A */
i__1 = *lwork - mn;
dgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
;
/* workspace at least N, optimally N*NB */
if (! tpsd) {
/* Least-Squares Problem min || A * X - B || */
/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
i__1 = *lwork - mn;
dormqr_("Left", "Transpose", m, nrhs, n, &a[a_offset], lda, &work[
1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
/* workspace at least NRHS, optimally NRHS*NB */
/* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */
dtrtrs_("Upper", "No transpose", "Non-unit", n, nrhs, &a[a_offset]
, lda, &b[b_offset], ldb, info);
if (*info > 0) {
return 0;
}
scllen = *n;
} else {
/* Overdetermined system of equations A' * X = B */
/* B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) */
dtrtrs_("Upper", "Transpose", "Non-unit", n, nrhs, &a[a_offset],
lda, &b[b_offset], ldb, info);
if (*info > 0) {
return 0;
}
/* B(N+1:M,1:NRHS) = ZERO */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = *n + 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = 0.;
/* L10: */
}
/* L20: */
}
/* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */
i__1 = *lwork - mn;
dormqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, &
work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
/* workspace at least NRHS, optimally NRHS*NB */
scllen = *m;
}
} else {
/* Compute LQ factorization of A */
i__1 = *lwork - mn;
dgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
;
/* workspace at least M, optimally M*NB. */
if (! tpsd) {
/* underdetermined system of equations A * X = B */
/* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */
dtrtrs_("Lower", "No transpose", "Non-unit", m, nrhs, &a[a_offset]
, lda, &b[b_offset], ldb, info);
if (*info > 0) {
return 0;
}
/* B(M+1:N,1:NRHS) = 0 */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = *m + 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = 0.;
/* L30: */
}
/* L40: */
}
/* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */
i__1 = *lwork - mn;
dormlq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &work[
1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
/* workspace at least NRHS, optimally NRHS*NB */
scllen = *n;
} else {
/* overdetermined system min || A' * X - B || */
/* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */
i__1 = *lwork - mn;
dormlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, &
work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
/* workspace at least NRHS, optimally NRHS*NB */
/* B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) */
dtrtrs_("Lower", "Transpose", "Non-unit", m, nrhs, &a[a_offset],
lda, &b[b_offset], ldb, info);
if (*info > 0) {
return 0;
}
scllen = *m;
}
}
/* Undo scaling */
if (iascl == 1) {
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset]
, ldb, info);
} else if (iascl == 2) {
dlascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset]
, ldb, info);
}
if (ibscl == 1) {
dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset]
, ldb, info);
} else if (ibscl == 2) {
dlascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset]
, ldb, info);
}
L50:
work[1] = (doublereal) wsize;
return 0;
/* End of DGELS */
} /* dgels_ */
/* Subroutine */ int dchkpb_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
doublereal *afac, doublereal *ainv, doublereal *b, doublereal *x,
doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
"=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test \002,i2"
",\002, ratio= \002,g12.5)";
static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
"=\002,i5,\002, NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i"
"2,\002) = \002,g12.5)";
static char fmt_9997[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
"=\002,i5,\002,\002,10x,\002 type \002,i2,\002, test(\002,i2,\002"
") = \002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer ldab, ioff, mode, koff, imat, info;
static char path[3], dist[1];
static integer irhs, nrhs;
static char uplo[1], type__[1];
static integer nrun, i__;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer k, n;
extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
static integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
extern /* Subroutine */ int dpbt01_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *), dpbt02_(char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *),
dpbt05_(char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *);
static integer kdval[4];
static doublereal rcond;
static integer nimat;
static doublereal anorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static integer iuplo, izero, i1, i2, nerrs;
static logical zerot;
static char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *);
static integer kd, nb, in, kl;
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer iw, ku;
extern doublereal dlansb_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dpbcon_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
static doublereal rcondc;
static char packit[1];
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *), dpbrfs_(char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *), dpbtrf_(char *,
integer *, integer *, doublereal *, integer *, integer *),
alasum_(char *, integer *, integer *, integer *, integer *);
static doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *);
static doublereal ainvnm;
extern /* Subroutine */ int derrpo_(char *, integer *), dpbtrs_(
char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *), xlaenv_(integer *,
integer *);
static doublereal result[7];
static integer lda, ikd, inb, nkd;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
December 7, 1999
Purpose
=======
DCHKPB tests DPBTRF, -TRS, -RFS, and -CON.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix dimension N.
NNB (input) INTEGER
The number of values of NB contained in the vector NBVAL.
NBVAL (input) INTEGER array, dimension (NBVAL)
The values of the blocksize NB.
NNS (input) INTEGER
The number of values of NRHS contained in the vector NSVAL.
NSVAL (input) INTEGER array, dimension (NNS)
The values of the number of right hand sides NRHS.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
NMAX (input) INTEGER
The maximum value permitted for N, used in dimensioning the
work arrays.
A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
where NSMAX is the largest entry in NSVAL.
X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
WORK (workspace) DOUBLE PRECISION array, dimension
(NMAX*max(3,NSMAX))
RWORK (workspace) DOUBLE PRECISION array, dimension
(max(NMAX,2*NSMAX))
IWORK (workspace) INTEGER array, dimension (NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PB", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
derrpo_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
kdval[0] = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
/* Set limits on the number of loop iterations.
Computing MAX */
i__2 = 1, i__3 = min(n,4);
nkd = max(i__2,i__3);
nimat = 8;
if (n == 0) {
nimat = 1;
}
kdval[1] = n + (n + 1) / 4;
kdval[2] = (n * 3 - 1) / 4;
kdval[3] = (n + 1) / 4;
i__2 = nkd;
for (ikd = 1; ikd <= i__2; ++ikd) {
/* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order
makes it easier to skip redundant values for small values
of N. */
kd = kdval[ikd - 1];
ldab = kd + 1;
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
koff = 1;
if (iuplo == 1) {
*(unsigned char *)uplo = 'U';
/* Computing MAX */
i__3 = 1, i__4 = kd + 2 - n;
koff = max(i__3,i__4);
*(unsigned char *)packit = 'Q';
} else {
*(unsigned char *)uplo = 'L';
*(unsigned char *)packit = 'B';
}
i__3 = nimat;
for (imat = 1; imat <= i__3; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L60;
}
/* Skip types 2, 3, or 4 if the matrix size is too small. */
zerot = imat >= 2 && imat <= 4;
if (zerot && n < imat - 1) {
goto L60;
}
if (! zerot || ! dotype[1]) {
/* Set up parameters with DLATB4 and generate a test
matrix with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
&mode, &cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)6, (ftnlen)
6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
&cndnum, &anorm, &kd, &kd, packit, &a[koff],
&ldab, &work[1], &info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &
n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
nout);
goto L60;
}
} else if (izero > 0) {
/* Use the same matrix for types 3 and 4 as for type
2 by copying back the zeroed out column, */
iw = (lda << 1) + 1;
if (iuplo == 1) {
ioff = (izero - 1) * ldab + kd + 1;
i__4 = izero - i1;
dcopy_(&i__4, &work[iw], &c__1, &a[ioff - izero +
i1], &c__1);
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dcopy_(&i__4, &work[iw], &c__1, &a[ioff], &i__5);
} else {
ioff = (i1 - 1) * ldab + 1;
i__4 = izero - i1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dcopy_(&i__4, &work[iw], &c__1, &a[ioff + izero -
i1], &i__5);
ioff = (izero - 1) * ldab + 1;
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
dcopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
}
}
/* For types 2-4, zero one row and column of the matrix
to test that INFO is returned correctly. */
izero = 0;
if (zerot) {
if (imat == 2) {
izero = 1;
} else if (imat == 3) {
izero = n;
} else {
izero = n / 2 + 1;
}
/* Save the zeroed out row and column in WORK(*,3) */
iw = lda << 1;
/* Computing MIN */
i__5 = (kd << 1) + 1;
i__4 = min(i__5,n);
for (i__ = 1; i__ <= i__4; ++i__) {
work[iw + i__] = 0.;
/* L20: */
}
++iw;
/* Computing MAX */
i__4 = izero - kd;
i1 = max(i__4,1);
/* Computing MIN */
i__4 = izero + kd;
i2 = min(i__4,n);
if (iuplo == 1) {
ioff = (izero - 1) * ldab + kd + 1;
i__4 = izero - i1;
dswap_(&i__4, &a[ioff - izero + i1], &c__1, &work[
iw], &c__1);
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dswap_(&i__4, &a[ioff], &i__5, &work[iw], &c__1);
} else {
ioff = (i1 - 1) * ldab + 1;
i__4 = izero - i1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dswap_(&i__4, &a[ioff + izero - i1], &i__5, &work[
iw], &c__1);
ioff = (izero - 1) * ldab + 1;
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
dswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
}
}
/* Do for each value of NB in NBVAL */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the L*L' or U'*U factorization of the band
matrix. */
i__5 = kd + 1;
dlacpy_("Full", &i__5, &n, &a[1], &ldab, &afac[1], &
ldab);
s_copy(srnamc_1.srnamt, "DPBTRF", (ftnlen)6, (ftnlen)
6);
dpbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
/* Check error code from DPBTRF. */
if (info != izero) {
alaerh_(path, "DPBTRF", &info, &izero, uplo, &n, &
n, &kd, &kd, &nb, &imat, &nfail, &nerrs,
nout);
goto L50;
}
/* Skip the tests if INFO is not 0. */
if (info != 0) {
goto L50;
}
/* + TEST 1
Reconstruct matrix from factors and compute
residual. */
i__5 = kd + 1;
dlacpy_("Full", &i__5, &n, &afac[1], &ldab, &ainv[1],
&ldab);
dpbt01_(uplo, &n, &kd, &a[1], &ldab, &ainv[1], &ldab,
&rwork[1], result);
/* Print the test ratio if it is .GE. THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* Only do other tests if this is the first blocksize. */
if (inb > 1) {
goto L50;
}
/* Form the inverse of A so we can get a good estimate
of RCONDC = 1/(norm(A) * norm(inv(A))). */
dlaset_("Full", &n, &n, &c_b50, &c_b51, &ainv[1], &
lda);
s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)6, (ftnlen)
6);
dpbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &ainv[1],
&lda, &info);
/* Compute RCONDC = 1/(norm(A) * norm(inv(A))). */
anorm = dlansb_("1", uplo, &n, &kd, &a[1], &ldab, &
rwork[1]);
ainvnm = dlange_("1", &n, &n, &ainv[1], &lda, &rwork[
1]);
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
i__5 = *nns;
for (irhs = 1; irhs <= i__5; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 2
Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)6, (
ftnlen)6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
&nrhs, &a[1], &ldab, &xact[1], &lda, &b[1]
, &lda, iseed, &info);
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)6, (
ftnlen)6);
dpbtrs_(uplo, &n, &kd, &nrhs, &afac[1], &ldab, &x[
1], &lda, &info);
/* Check error code from DPBTRS. */
if (info != 0) {
alaerh_(path, "DPBTRS", &info, &c__0, uplo, &
n, &n, &kd, &kd, &nrhs, &imat, &nfail,
&nerrs, nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
&lda);
dpbt02_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &x[1],
&lda, &work[1], &lda, &rwork[1], &result[
1]);
/* + TEST 3
Check solution from generated exact solution. */
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* + TESTS 4, 5, and 6
Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "DPBRFS", (ftnlen)6, (
ftnlen)6);
dpbrfs_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &afac[
1], &ldab, &b[1], &lda, &x[1], &lda, &
rwork[1], &rwork[nrhs + 1], &work[1], &
iwork[1], &info);
/* Check error code from DPBRFS. */
if (info != 0) {
alaerh_(path, "DPBRFS", &info, &c__0, uplo, &
n, &n, &kd, &kd, &nrhs, &imat, &nfail,
&nerrs, nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
dpbt05_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &b[1],
&lda, &x[1], &lda, &xact[1], &lda, &
rwork[1], &rwork[nrhs + 1], &result[4]);
/* Print information about the tests that did not
pass the threshold. */
for (k = 2; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L30: */
}
nrun += 5;
/* L40: */
}
/* + TEST 7
Get an estimate of RCOND = 1/CNDNUM. */
s_copy(srnamc_1.srnamt, "DPBCON", (ftnlen)6, (ftnlen)
6);
dpbcon_(uplo, &n, &kd, &afac[1], &ldab, &anorm, &
rcond, &work[1], &iwork[1], &info);
/* Check error code from DPBCON. */
if (info != 0) {
alaerh_(path, "DPBCON", &info, &c__0, uplo, &n, &
n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
nout);
}
result[6] = dget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___48.ciunit = *nout;
s_wsfe(&io___48);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L50:
;
}
L60:
;
}
/* L70: */
}
/* L80: */
}
/* L90: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKPB */
} /* dchkpb_ */
/* Subroutine */ int dgelsx_(integer *m, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
jpvt, doublereal *rcond, integer *rank, doublereal *work, integer *
info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
This routine is deprecated and has been replaced by routine DGELSY.
DGELSX computes the minimum-norm solution to a real linear least
squares problem:
minimize || A * X - B ||
using a complete orthogonal factorization of A. A is an M-by-N
matrix which may be rank-deficient.
Several right hand side vectors b and solution vectors x can be
handled in a single call; they are stored as the columns of the
M-by-NRHS right hand side matrix B and the N-by-NRHS solution
matrix X.
The routine first computes a QR factorization with column pivoting:
A * P = Q * [ R11 R12 ]
[ 0 R22 ]
with R11 defined as the largest leading submatrix whose estimated
condition number is less than 1/RCOND. The order of R11, RANK,
is the effective rank of A.
Then, R22 is considered to be negligible, and R12 is annihilated
by orthogonal transformations from the right, arriving at the
complete orthogonal factorization:
A * P = Q * [ T11 0 ] * Z
[ 0 0 ]
The minimum-norm solution is then
X = P * Z' [ inv(T11)*Q1'*B ]
[ 0 ]
where Q1 consists of the first RANK columns of Q.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of
columns of matrices B and X. NRHS >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, A has been overwritten by details of its
complete orthogonal factorization.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
On entry, the M-by-NRHS right hand side matrix B.
On exit, the N-by-NRHS solution matrix X.
If m >= n and RANK = n, the residual sum-of-squares for
the solution in the i-th column is given by the sum of
squares of elements N+1:M in that column.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,M,N).
JPVT (input/output) INTEGER array, dimension (N)
On entry, if JPVT(i) .ne. 0, the i-th column of A is an
initial column, otherwise it is a free column. Before
the QR factorization of A, all initial columns are
permuted to the leading positions; only the remaining
free columns are moved as a result of column pivoting
during the factorization.
On exit, if JPVT(i) = k, then the i-th column of A*P
was the k-th column of A.
RCOND (input) DOUBLE PRECISION
RCOND is used to determine the effective rank of A, which
is defined as the order of the largest leading triangular
submatrix R11 in the QR factorization with pivoting of A,
whose estimated condition number < 1/RCOND.
RANK (output) INTEGER
The effective rank of A, i.e., the order of the submatrix
R11. This is the same as the order of the submatrix T11
in the complete orthogonal factorization of A.
WORK (workspace) DOUBLE PRECISION array, dimension
(max( min(M,N)+3*N, 2*min(M,N)+NRHS )),
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__0 = 0;
static doublereal c_b13 = 0.;
static integer c__2 = 2;
static integer c__1 = 1;
static doublereal c_b36 = 1.;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
static doublereal anrm, bnrm, smin, smax;
static integer i__, j, k, iascl, ibscl, ismin, ismax;
static doublereal c1, c2;
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *), dlaic1_(
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *);
static doublereal s1, s2, t1, t2;
extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), dlabad_(
doublereal *, doublereal *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
static integer mn;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dgeqpf_(integer *, integer *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
integer *), dlaset_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *), xerbla_(char *,
integer *);
static doublereal bignum;
extern /* Subroutine */ int dlatzm_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *);
static doublereal sminpr, smaxpr, smlnum;
extern /* Subroutine */ int dtzrqf_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *);
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--jpvt;
--work;
/* Function Body */
mn = min(*m,*n);
ismin = mn + 1;
ismax = (mn << 1) + 1;
/* Test the input arguments. */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = max(1,*m);
if (*ldb < max(i__1,*n)) {
*info = -7;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGELSX", &i__1);
return 0;
}
/* Quick return if possible
Computing MIN */
i__1 = min(*m,*n);
if (min(i__1,*nrhs) == 0) {
*rank = 0;
return 0;
}
/* Get machine parameters */
smlnum = dlamch_("S") / dlamch_("P");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Scale A, B if max elements outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]);
iascl = 0;
if (anrm > 0. && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
info);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
info);
iascl = 2;
} else if (anrm == 0.) {
/* Matrix all zero. Return zero solution. */
i__1 = max(*m,*n);
dlaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb);
*rank = 0;
goto L100;
}
bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
ibscl = 0;
if (bnrm > 0. && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
info);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM */
dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
info);
ibscl = 2;
}
/* Compute QR factorization with column pivoting of A:
A * P = Q * R */
dgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], info);
/* workspace 3*N. Details of Householder rotations stored
in WORK(1:MN).
Determine RANK using incremental condition estimation */
work[ismin] = 1.;
work[ismax] = 1.;
smax = (d__1 = a_ref(1, 1), abs(d__1));
smin = smax;
if ((d__1 = a_ref(1, 1), abs(d__1)) == 0.) {
*rank = 0;
i__1 = max(*m,*n);
dlaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb);
goto L100;
} else {
*rank = 1;
}
L10:
if (*rank < mn) {
i__ = *rank + 1;
dlaic1_(&c__2, rank, &work[ismin], &smin, &a_ref(1, i__), &a_ref(i__,
i__), &sminpr, &s1, &c1);
dlaic1_(&c__1, rank, &work[ismax], &smax, &a_ref(1, i__), &a_ref(i__,
i__), &smaxpr, &s2, &c2);
if (smaxpr * *rcond <= sminpr) {
i__1 = *rank;
for (i__ = 1; i__ <= i__1; ++i__) {
work[ismin + i__ - 1] = s1 * work[ismin + i__ - 1];
work[ismax + i__ - 1] = s2 * work[ismax + i__ - 1];
/* L20: */
}
work[ismin + *rank] = c1;
work[ismax + *rank] = c2;
smin = sminpr;
smax = smaxpr;
++(*rank);
goto L10;
}
}
/* Logically partition R = [ R11 R12 ]
[ 0 R22 ]
where R11 = R(1:RANK,1:RANK)
[R11,R12] = [ T11, 0 ] * Y */
if (*rank < *n) {
dtzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info);
}
/* Details of Householder rotations stored in WORK(MN+1:2*MN)
B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
dorm2r_("Left", "Transpose", m, nrhs, &mn, &a[a_offset], lda, &work[1], &
b[b_offset], ldb, &work[(mn << 1) + 1], info);
/* workspace NRHS
B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */
dtrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b36, &
a[a_offset], lda, &b[b_offset], ldb);
i__1 = *n;
for (i__ = *rank + 1; i__ <= i__1; ++i__) {
i__2 = *nrhs;
for (j = 1; j <= i__2; ++j) {
b_ref(i__, j) = 0.;
/* L30: */
}
/* L40: */
}
/* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */
if (*rank < *n) {
i__1 = *rank;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n - *rank + 1;
dlatzm_("Left", &i__2, nrhs, &a_ref(i__, *rank + 1), lda, &work[
mn + i__], &b_ref(i__, 1), &b_ref(*rank + 1, 1), ldb, &
work[(mn << 1) + 1]);
/* L50: */
}
}
/* workspace NRHS
B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[(mn << 1) + i__] = 1.;
/* L60: */
}
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[(mn << 1) + i__] == 1.) {
if (jpvt[i__] != i__) {
k = i__;
t1 = b_ref(k, j);
t2 = b_ref(jpvt[k], j);
L70:
b_ref(jpvt[k], j) = t1;
work[(mn << 1) + k] = 0.;
t1 = t2;
k = jpvt[k];
t2 = b_ref(jpvt[k], j);
if (jpvt[k] != i__) {
goto L70;
}
b_ref(i__, j) = t1;
work[(mn << 1) + k] = 0.;
}
}
/* L80: */
}
/* L90: */
}
/* Undo scaling */
if (iascl == 1) {
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
info);
dlascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset],
lda, info);
} else if (iascl == 2) {
dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
info);
dlascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset],
lda, info);
}
if (ibscl == 1) {
dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
info);
} else if (ibscl == 2) {
dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
info);
}
L100:
return 0;
/* End of DGELSX */
} /* dgelsx_ */
/* Subroutine */ int dchkgl_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of DGGBAL .. \002)";
static char fmt_9998[] = "(1x,\002value of largest test error "
" = \002,d12.3)";
static char fmt_9997[] = "(1x,\002example number where info is not zero "
" = \002,i4)";
static char fmt_9996[] = "(1x,\002example number where ILO or IHI wrong "
" = \002,i4)";
static char fmt_9995[] = "(1x,\002example number having largest error "
" = \002,i4)";
static char fmt_9994[] = "(1x,\002number of examples where info is not 0"
" = \002,i4)";
static char fmt_9993[] = "(1x,\002total number of examples tested "
" = \002,i4)";
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2, d__3;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void), s_wsfe(cilist *), e_wsfe(void), do_fio(integer *,
char *, ftnlen);
/* Local variables */
static integer info, lmax[5];
static doublereal rmax, vmax, work[120], a[400] /* was [20][20] */, b[
400] /* was [20][20] */;
static integer i__, j, n, ihiin, ninfo, iloin;
static doublereal anorm, bnorm;
extern /* Subroutine */ int dggbal_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
static doublereal lscale[20], rscale[20], lsclin[20], rsclin[20], ain[400]
/* was [20][20] */, bin[400] /* was [20][20] */;
static integer ihi, ilo;
static doublereal eps;
static integer knt;
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___9 = { 0, 0, 0, 0, 0 };
static cilist io___12 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 0, 0, 0, 0 };
static cilist io___21 = { 0, 0, 0, 0, 0 };
static cilist io___23 = { 0, 0, 0, 0, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9993, 0 };
#define a_ref(a_1,a_2) a[(a_2)*20 + a_1 - 21]
#define b_ref(a_1,a_2) b[(a_2)*20 + a_1 - 21]
#define ain_ref(a_1,a_2) ain[(a_2)*20 + a_1 - 21]
#define bin_ref(a_1,a_2) bin[(a_2)*20 + a_1 - 21]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DCHKGL tests DGGBAL, a routine for balancing a matrix pair (A, B).
Arguments
=========
NIN (input) INTEGER
The logical unit number for input. NIN > 0.
NOUT (input) INTEGER
The logical unit number for output. NOUT > 0.
===================================================================== */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("Precision");
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L90;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___9.ciunit = *nin;
s_rsle(&io___9);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&a_ref(i__, j), (ftnlen)sizeof(
doublereal));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___12.ciunit = *nin;
s_rsle(&io___12);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&b_ref(i__, j), (ftnlen)sizeof(
doublereal));
}
e_rsle();
/* L30: */
}
io___14.ciunit = *nin;
s_rsle(&io___14);
do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&ain_ref(i__, j), (ftnlen)sizeof(
doublereal));
}
e_rsle();
/* L40: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___19.ciunit = *nin;
s_rsle(&io___19);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&bin_ref(i__, j), (ftnlen)sizeof(
doublereal));
}
e_rsle();
/* L50: */
}
io___21.ciunit = *nin;
s_rsle(&io___21);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&lsclin[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
io___23.ciunit = *nin;
s_rsle(&io___23);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&rsclin[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
anorm = dlange_("M", &n, &n, a, &c__20, work);
bnorm = dlange_("M", &n, &n, b, &c__20, work);
++knt;
dggbal_("B", &n, a, &c__20, b, &c__20, &ilo, &ihi, lscale, rscale, work, &
info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
if (ilo != iloin || ihi != ihiin) {
++ninfo;
lmax[1] = knt;
}
vmax = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = a_ref(i__, j) - ain_ref(i__, j), abs(
d__1));
vmax = max(d__2,d__3);
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = b_ref(i__, j) - bin_ref(i__, j), abs(
d__1));
vmax = max(d__2,d__3);
/* L60: */
}
/* L70: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = lscale[i__ - 1] - lsclin[i__ - 1], abs(
d__1));
vmax = max(d__2,d__3);
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = rscale[i__ - 1] - rsclin[i__ - 1], abs(
d__1));
vmax = max(d__2,d__3);
/* L80: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[2] = knt;
rmax = vmax;
}
goto L10;
L90:
io___34.ciunit = *nout;
s_wsfe(&io___34);
e_wsfe();
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of DCHKGL */
} /* dchkgl_ */
int dtrsen_(char *job, char *compq, int *select, int
*n, double *t, int *ldt, double *q, int *ldq,
double *wr, double *wi, int *m, double *s, double
*sep, double *work, int *lwork, int *iwork, int *
liwork, int *info)
{
/* System generated locals */
int q_dim1, q_offset, t_dim1, t_offset, i__1, i__2;
double d__1, d__2;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int k, n1, n2, kk, nn, ks;
double est;
int kase;
int pair;
int ierr;
int swap;
double scale;
extern int lsame_(char *, char *);
int isave[3], lwmin;
int wantq, wants;
double rnorm;
extern int dlacn2_(int *, double *, double *,
int *, double *, int *, int *);
extern double dlange_(char *, int *, int *, double *,
int *, double *);
extern int dlacpy_(char *, int *, int *,
double *, int *, double *, int *),
xerbla_(char *, int *);
int wantbh;
extern int dtrexc_(char *, int *, double *,
int *, double *, int *, int *, int *,
double *, int *);
int liwmin;
int wantsp, lquery;
extern int dtrsyl_(char *, char *, int *, int *,
int *, double *, int *, double *, int *,
double *, int *, double *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DTRSEN reorders the float Schur factorization of a float matrix */
/* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in */
/* the leading diagonal blocks of the upper quasi-triangular matrix T, */
/* and the leading columns of Q form an orthonormal basis of the */
/* corresponding right invariant subspace. */
/* Optionally the routine computes the reciprocal condition numbers of */
/* the cluster of eigenvalues and/or the invariant subspace. */
/* T must be in Schur canonical form (as returned by DHSEQR), that is, */
/* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */
/* 2-by-2 diagonal block has its diagonal elemnts equal and its */
/* off-diagonal elements of opposite sign. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies whether condition numbers are required for the */
/* cluster of eigenvalues (S) or the invariant subspace (SEP): */
/* = 'N': none; */
/* = 'E': for eigenvalues only (S); */
/* = 'V': for invariant subspace only (SEP); */
/* = 'B': for both eigenvalues and invariant subspace (S and */
/* SEP). */
/* COMPQ (input) CHARACTER*1 */
/* = 'V': update the matrix Q of Schur vectors; */
/* = 'N': do not update Q. */
/* SELECT (input) LOGICAL array, dimension (N) */
/* SELECT specifies the eigenvalues in the selected cluster. To */
/* select a float eigenvalue w(j), SELECT(j) must be set to */
/* .TRUE.. To select a complex conjugate pair of eigenvalues */
/* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */
/* either SELECT(j) or SELECT(j+1) or both must be set to */
/* .TRUE.; a complex conjugate pair of eigenvalues must be */
/* either both included in the cluster or both excluded. */
/* N (input) INTEGER */
/* The order of the matrix T. N >= 0. */
/* T (input/output) DOUBLE PRECISION array, dimension (LDT,N) */
/* On entry, the upper quasi-triangular matrix T, in Schur */
/* canonical form. */
/* On exit, T is overwritten by the reordered matrix T, again in */
/* Schur canonical form, with the selected eigenvalues in the */
/* leading diagonal blocks. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= MAX(1,N). */
/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
/* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */
/* On exit, if COMPQ = 'V', Q has been postmultiplied by the */
/* orthogonal transformation matrix which reorders T; the */
/* leading M columns of Q form an orthonormal basis for the */
/* specified invariant subspace. */
/* If COMPQ = 'N', Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. */
/* LDQ >= 1; and if COMPQ = 'V', LDQ >= N. */
/* WR (output) DOUBLE PRECISION array, dimension (N) */
/* WI (output) DOUBLE PRECISION array, dimension (N) */
/* The float and imaginary parts, respectively, of the reordered */
/* eigenvalues of T. The eigenvalues are stored in the same */
/* order as on the diagonal of T, with WR(i) = T(i,i) and, if */
/* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and */
/* WI(i+1) = -WI(i). Note that if a complex eigenvalue is */
/* sufficiently ill-conditioned, then its value may differ */
/* significantly from its value before reordering. */
/* M (output) INTEGER */
/* The dimension of the specified invariant subspace. */
/* 0 < = M <= N. */
/* S (output) DOUBLE PRECISION */
/* If JOB = 'E' or 'B', S is a lower bound on the reciprocal */
/* condition number for the selected cluster of eigenvalues. */
/* S cannot underestimate the true reciprocal condition number */
/* by more than a factor of sqrt(N). If M = 0 or N, S = 1. */
/* If JOB = 'N' or 'V', S is not referenced. */
/* SEP (output) DOUBLE PRECISION */
/* If JOB = 'V' or 'B', SEP is the estimated reciprocal */
/* condition number of the specified invariant subspace. If */
/* M = 0 or N, SEP = norm(T). */
/* If JOB = 'N' or 'E', SEP is not referenced. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If JOB = 'N', LWORK >= MAX(1,N); */
/* if JOB = 'E', LWORK >= MAX(1,M*(N-M)); */
/* if JOB = 'V' or 'B', LWORK >= MAX(1,2*M*(N-M)). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. */
/* If JOB = 'N' or 'E', LIWORK >= 1; */
/* if JOB = 'V' or 'B', LIWORK >= MAX(1,M*(N-M)). */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal size of the IWORK array, */
/* returns this value as the first entry of the IWORK array, and */
/* no error message related to LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* = 1: reordering of T failed because some eigenvalues are too */
/* close to separate (the problem is very ill-conditioned); */
/* T may have been partially reordered, and WR and WI */
/* contain the eigenvalues in the same order as in T; S and */
/* SEP (if requested) are set to zero. */
/* Further Details */
/* =============== */
/* DTRSEN first collects the selected eigenvalues by computing an */
/* orthogonal transformation Z to move them to the top left corner of T. */
/* In other words, the selected eigenvalues are the eigenvalues of T11 */
/* in: */
/* Z'*T*Z = ( T11 T12 ) n1 */
/* ( 0 T22 ) n2 */
/* n1 n2 */
/* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns */
/* of Z span the specified invariant subspace of T. */
/* If T has been obtained from the float Schur factorization of a matrix */
/* A = Q*T*Q', then the reordered float Schur factorization of A is given */
/* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span */
/* the corresponding invariant subspace of A. */
/* The reciprocal condition number of the average of the eigenvalues of */
/* T11 may be returned in S. S lies between 0 (very badly conditioned) */
/* and 1 (very well conditioned). It is computed as follows. First we */
/* compute R so that */
/* P = ( I R ) n1 */
/* ( 0 0 ) n2 */
/* n1 n2 */
/* is the projector on the invariant subspace associated with T11. */
/* R is the solution of the Sylvester equation: */
/* T11*R - R*T22 = T12. */
/* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote */
/* the two-norm of M. Then S is computed as the lower bound */
/* (1 + F-norm(R)**2)**(-1/2) */
/* on the reciprocal of 2-norm(P), the true reciprocal condition number. */
/* S cannot underestimate 1 / 2-norm(P) by more than a factor of */
/* sqrt(N). */
/* An approximate error bound for the computed average of the */
/* eigenvalues of T11 is */
/* EPS * norm(T) / S */
/* where EPS is the machine precision. */
/* The reciprocal condition number of the right invariant subspace */
/* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. */
/* SEP is defined as the separation of T11 and T22: */
/* sep( T11, T22 ) = sigma-MIN( C ) */
/* where sigma-MIN(C) is the smallest singular value of the */
/* n1*n2-by-n1*n2 matrix */
/* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) */
/* I(m) is an m by m identity matrix, and kprod denotes the Kronecker */
/* product. We estimate sigma-MIN(C) by the reciprocal of an estimate of */
/* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) */
/* cannot differ from sigma-MIN(C) by more than a factor of sqrt(n1*n2). */
/* When SEP is small, small changes in T can cause large changes in */
/* the invariant subspace. An approximate bound on the maximum angular */
/* error in the computed right invariant subspace is */
/* EPS * norm(T) / SEP */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
--select;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--wr;
--wi;
--work;
--iwork;
/* Function Body */
wantbh = lsame_(job, "B");
wants = lsame_(job, "E") || wantbh;
wantsp = lsame_(job, "V") || wantbh;
wantq = lsame_(compq, "V");
*info = 0;
lquery = *lwork == -1;
if (! lsame_(job, "N") && ! wants && ! wantsp) {
*info = -1;
} else if (! lsame_(compq, "N") && ! wantq) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < MAX(1,*n)) {
*info = -6;
} else if (*ldq < 1 || wantq && *ldq < *n) {
*info = -8;
} else {
/* Set M to the dimension of the specified invariant subspace, */
/* and test LWORK and LIWORK. */
*m = 0;
pair = FALSE;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (pair) {
pair = FALSE;
} else {
if (k < *n) {
if (t[k + 1 + k * t_dim1] == 0.) {
if (select[k]) {
++(*m);
}
} else {
pair = TRUE;
if (select[k] || select[k + 1]) {
*m += 2;
}
}
} else {
if (select[*n]) {
++(*m);
}
}
}
/* L10: */
}
n1 = *m;
n2 = *n - *m;
nn = n1 * n2;
if (wantsp) {
/* Computing MAX */
i__1 = 1, i__2 = nn << 1;
lwmin = MAX(i__1,i__2);
liwmin = MAX(1,nn);
} else if (lsame_(job, "N")) {
lwmin = MAX(1,*n);
liwmin = 1;
} else if (lsame_(job, "E")) {
lwmin = MAX(1,nn);
liwmin = 1;
}
if (*lwork < lwmin && ! lquery) {
*info = -15;
} else if (*liwork < liwmin && ! lquery) {
*info = -17;
}
}
if (*info == 0) {
work[1] = (double) lwmin;
iwork[1] = liwmin;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTRSEN", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible. */
if (*m == *n || *m == 0) {
if (wants) {
*s = 1.;
}
if (wantsp) {
*sep = dlange_("1", n, n, &t[t_offset], ldt, &work[1]);
}
goto L40;
}
/* Collect the selected blocks at the top-left corner of T. */
ks = 0;
pair = FALSE;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (pair) {
pair = FALSE;
} else {
swap = select[k];
if (k < *n) {
if (t[k + 1 + k * t_dim1] != 0.) {
pair = TRUE;
swap = swap || select[k + 1];
}
}
if (swap) {
++ks;
/* Swap the K-th block to position KS. */
ierr = 0;
kk = k;
if (k != ks) {
dtrexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
kk, &ks, &work[1], &ierr);
}
if (ierr == 1 || ierr == 2) {
/* Blocks too close to swap: exit. */
*info = 1;
if (wants) {
*s = 0.;
}
if (wantsp) {
*sep = 0.;
}
goto L40;
}
if (pair) {
++ks;
}
}
}
/* L20: */
}
if (wants) {
/* Solve Sylvester equation for R: */
/* T11*R - R*T22 = scale*T12 */
dlacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1);
dtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1
+ 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr);
/* Estimate the reciprocal of the condition number of the cluster */
/* of eigenvalues. */
rnorm = dlange_("F", &n1, &n2, &work[1], &n1, &work[1]);
if (rnorm == 0.) {
*s = 1.;
} else {
*s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm));
}
}
if (wantsp) {
/* Estimate sep(T11,T22). */
est = 0.;
kase = 0;
L30:
dlacn2_(&nn, &work[nn + 1], &work[1], &iwork[1], &est, &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Solve T11*R - R*T22 = scale*X. */
dtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
ierr);
} else {
/* Solve T11'*R - R*T22' = scale*X. */
dtrsyl_("T", "T", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
ierr);
}
goto L30;
}
*sep = scale / est;
}
L40:
/* Store the output eigenvalues in WR and WI. */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
wr[k] = t[k + k * t_dim1];
wi[k] = 0.;
/* L50: */
}
i__1 = *n - 1;
for (k = 1; k <= i__1; ++k) {
if (t[k + 1 + k * t_dim1] != 0.) {
wi[k] = sqrt((d__1 = t[k + (k + 1) * t_dim1], ABS(d__1))) * sqrt((
d__2 = t[k + 1 + k * t_dim1], ABS(d__2)));
wi[k + 1] = -wi[k];
}
/* L60: */
}
work[1] = (double) lwmin;
iwork[1] = liwmin;
return 0;
/* End of DTRSEN */
} /* dtrsen_ */
/* Subroutine */ int dgegs_(char *jobvsl, char *jobvsr, integer *n,
doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
alphar, doublereal *alphai, doublereal *beta, doublereal *vsl,
integer *ldvsl, doublereal *vsr, integer *ldvsr, doublereal *work,
integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
vsr_dim1, vsr_offset, i__1, i__2;
/* Local variables */
integer nb, nb1, nb2, nb3, ihi, ilo;
doublereal eps, anrm, bnrm;
integer itau, lopt;
extern logical lsame_(char *, char *);
integer ileft, iinfo, icols;
logical ilvsl;
integer iwork;
logical ilvsr;
integer irows;
extern /* Subroutine */ int dggbak_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, integer *), dggbal_(char *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal
*, doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
logical ilascl, ilbscl;
extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *);
doublereal safmin;
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
doublereal bignum;
extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *);
integer ijobvl, iright, ijobvr;
extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *);
doublereal anrmto;
integer lwkmin;
doublereal bnrmto;
extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
doublereal smlnum;
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine DGGES. */
/* DGEGS computes the eigenvalues, real Schur form, and, optionally, */
/* left and or/right Schur vectors of a real matrix pair (A,B). */
/* Given two square matrices A and B, the generalized real Schur */
/* factorization has the form */
/* A = Q*S*Z**T, B = Q*T*Z**T */
/* where Q and Z are orthogonal matrices, T is upper triangular, and S */
/* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal */
/* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs */
/* of eigenvalues of (A,B). The columns of Q are the left Schur vectors */
/* and the columns of Z are the right Schur vectors. */
/* If only the eigenvalues of (A,B) are needed, the driver routine */
/* DGEGV should be used instead. See DGEGV for a description of the */
/* eigenvalues of the generalized nonsymmetric eigenvalue problem */
/* (GNEP). */
/* Arguments */
/* ========= */
/* JOBVSL (input) CHARACTER*1 */
/* = 'N': do not compute the left Schur vectors; */
/* = 'V': compute the left Schur vectors (returned in VSL). */
/* JOBVSR (input) CHARACTER*1 */
/* = 'N': do not compute the right Schur vectors; */
/* = 'V': compute the right Schur vectors (returned in VSR). */
/* N (input) INTEGER */
/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
/* On entry, the matrix A. */
/* On exit, the upper quasi-triangular matrix S from the */
/* generalized real Schur factorization. */
/* LDA (input) INTEGER */
/* The leading dimension of A. LDA >= max(1,N). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */
/* On entry, the matrix B. */
/* On exit, the upper triangular matrix T from the generalized */
/* real Schur factorization. */
/* LDB (input) INTEGER */
/* The leading dimension of B. LDB >= max(1,N). */
/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
/* The real parts of each scalar alpha defining an eigenvalue */
/* of GNEP. */
/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
/* The imaginary parts of each scalar alpha defining an */
/* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */
/* eigenvalue is real; if positive, then the j-th and (j+1)-st */
/* eigenvalues are a complex conjugate pair, with */
/* ALPHAI(j+1) = -ALPHAI(j). */
/* BETA (output) DOUBLE PRECISION array, dimension (N) */
/* The scalars beta that define the eigenvalues of GNEP. */
/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */
/* beta = BETA(j) represent the j-th eigenvalue of the matrix */
/* pair (A,B), in one of the forms lambda = alpha/beta or */
/* mu = beta/alpha. Since either lambda or mu may overflow, */
/* they should not, in general, be computed. */
/* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N) */
/* If JOBVSL = 'V', the matrix of left Schur vectors Q. */
/* Not referenced if JOBVSL = 'N'. */
/* LDVSL (input) INTEGER */
/* The leading dimension of the matrix VSL. LDVSL >=1, and */
/* if JOBVSL = 'V', LDVSL >= N. */
/* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N) */
/* If JOBVSR = 'V', the matrix of right Schur vectors Z. */
/* Not referenced if JOBVSR = 'N'. */
/* LDVSR (input) INTEGER */
/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
/* if JOBVSR = 'V', LDVSR >= N. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,4*N). */
/* For good performance, LWORK must generally be larger. */
/* To compute the optimal value of LWORK, call ILAENV to get */
/* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute: */
/* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR */
/* The optimal LWORK is 2*N + N*(NB+1). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* = 1,...,N: */
/* The QZ iteration failed. (A,B) are not in Schur */
/* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */
/* be correct for j=INFO+1,...,N. */
/* > N: errors that usually indicate LAPACK problems: */
/* =N+1: error return from DGGBAL */
/* =N+2: error return from DGEQRF */
/* =N+3: error return from DORMQR */
/* =N+4: error return from DORGQR */
/* =N+5: error return from DGGHRD */
/* =N+6: error return from DHGEQZ (other than failed */
/* iteration) */
/* =N+7: error return from DGGBAK (computing VSL) */
/* =N+8: error return from DGGBAK (computing VSR) */
/* =N+9: error return from DLASCL (various places) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alphar;
--alphai;
--beta;
vsl_dim1 = *ldvsl;
vsl_offset = 1 + vsl_dim1;
vsl -= vsl_offset;
vsr_dim1 = *ldvsr;
vsr_offset = 1 + vsr_dim1;
vsr -= vsr_offset;
--work;
/* Function Body */
if (lsame_(jobvsl, "N")) {
ijobvl = 1;
ilvsl = FALSE_;
} else if (lsame_(jobvsl, "V")) {
ijobvl = 2;
ilvsl = TRUE_;
} else {
ijobvl = -1;
ilvsl = FALSE_;
}
if (lsame_(jobvsr, "N")) {
ijobvr = 1;
ilvsr = FALSE_;
} else if (lsame_(jobvsr, "V")) {
ijobvr = 2;
ilvsr = TRUE_;
} else {
ijobvr = -1;
ilvsr = FALSE_;
}
/* Test the input arguments */
/* Computing MAX */
i__1 = *n << 2;
lwkmin = max(i__1,1);
lwkopt = lwkmin;
work[1] = (doublereal) lwkopt;
lquery = *lwork == -1;
*info = 0;
if (ijobvl <= 0) {
*info = -1;
} else if (ijobvr <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
} else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
*info = -12;
} else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
*info = -14;
} else if (*lwork < lwkmin && ! lquery) {
*info = -16;
}
if (*info == 0) {
nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, n, &c_n1, &c_n1);
nb2 = ilaenv_(&c__1, "DORMQR", " ", n, n, n, &c_n1);
nb3 = ilaenv_(&c__1, "DORGQR", " ", n, n, n, &c_n1);
/* Computing MAX */
i__1 = max(nb1,nb2);
nb = max(i__1,nb3);
lopt = (*n << 1) + *n * (nb + 1);
work[1] = (doublereal) lopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEGS ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("E") * dlamch_("B");
safmin = dlamch_("S");
smlnum = *n * safmin / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]);
ilascl = FALSE_;
if (anrm > 0. && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
dlascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &a[a_offset], lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]);
ilbscl = FALSE_;
if (bnrm > 0. && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
dlascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
/* Permute the matrix to make it more nearly triangular */
/* Workspace layout: (2*N words -- "work..." not actually used) */
/* left_permutation, right_permutation, work... */
ileft = 1;
iright = *n + 1;
iwork = iright + *n;
dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
ileft], &work[iright], &work[iwork], &iinfo);
if (iinfo != 0) {
*info = *n + 1;
goto L10;
}
/* Reduce B to triangular form, and initialize VSL and/or VSR */
/* Workspace layout: ("work..." must have at least N words) */
/* left_permutation, right_permutation, tau, work... */
irows = ihi + 1 - ilo;
icols = *n + 1 - ilo;
itau = iwork;
iwork = itau + irows;
i__1 = *lwork + 1 - iwork;
dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 2;
goto L10;
}
i__1 = *lwork + 1 - iwork;
dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, &
iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 3;
goto L10;
}
if (ilvsl) {
dlaset_("Full", n, n, &c_b36, &c_b37, &vsl[vsl_offset], ldvsl);
i__1 = irows - 1;
i__2 = irows - 1;
dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ilo
+ 1 + ilo * vsl_dim1], ldvsl);
i__1 = *lwork + 1 - iwork;
dorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
work[itau], &work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 4;
goto L10;
}
}
if (ilvsr) {
dlaset_("Full", n, n, &c_b36, &c_b37, &vsr[vsr_offset], ldvsr);
}
/* Reduce to generalized Hessenberg form */
dgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &iinfo);
if (iinfo != 0) {
*info = *n + 5;
goto L10;
}
/* Perform QZ algorithm, computing Schur vectors if desired */
/* Workspace layout: ("work..." must have at least 1 word) */
/* left_permutation, right_permutation, work... */
iwork = itau;
i__1 = *lwork + 1 - iwork;
dhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset]
, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
if (iinfo > 0 && iinfo <= *n) {
*info = iinfo;
} else if (iinfo > *n && iinfo <= *n << 1) {
*info = iinfo - *n;
} else {
*info = *n + 6;
}
goto L10;
}
/* Apply permutation to VSL and VSR */
if (ilvsl) {
dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[
vsl_offset], ldvsl, &iinfo);
if (iinfo != 0) {
*info = *n + 7;
goto L10;
}
}
if (ilvsr) {
dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[
vsr_offset], ldvsr, &iinfo);
if (iinfo != 0) {
*info = *n + 8;
goto L10;
}
}
/* Undo scaling */
if (ilascl) {
dlascl_("H", &c_n1, &c_n1, &anrmto, &anrm, n, n, &a[a_offset], lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
dlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
dlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
if (ilbscl) {
dlascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
dlascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
L10:
work[1] = (doublereal) lwkopt;
return 0;
/* End of DGEGS */
} /* dgegs_ */
doublereal dqrt14_(char *trans, integer *m, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *x, integer *ldx, doublereal *
work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, x_dim1, x_offset, i__1, i__2, i__3;
doublereal ret_val, d__1, d__2, d__3;
/* Local variables */
integer i__, j;
doublereal err;
integer info;
doublereal anrm;
logical tpsd;
doublereal xnrm;
extern logical lsame_(char *, char *);
doublereal rwork[1];
extern /* Subroutine */ int dgelq2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *), dgeqr2_(
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlacpy_(char *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *);
integer ldwork;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DQRT14 checks whether X is in the row space of A or A'. It does so */
/* by scaling both X and A such that their norms are in the range */
/* [sqrt(eps), 1/sqrt(eps)], then computing a QR factorization of [A,X] */
/* (if TRANS = 'T') or an LQ factorization of [A',X]' (if TRANS = 'N'), */
/* and returning the norm of the trailing triangle, scaled by */
/* MAX(M,N,NRHS)*eps. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* = 'N': No transpose, check for X in the row space of A */
/* = 'T': Transpose, check for X in the row space of A'. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of X. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The M-by-N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* If TRANS = 'N', the N-by-NRHS matrix X. */
/* IF TRANS = 'T', the M-by-NRHS matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. */
/* WORK (workspace) DOUBLE PRECISION array dimension (LWORK) */
/* LWORK (input) INTEGER */
/* length of workspace array required */
/* If TRANS = 'N', LWORK >= (M+NRHS)*(N+2); */
/* if TRANS = 'T', LWORK >= (N+NRHS)*(M+2). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--work;
/* Function Body */
ret_val = 0.;
if (lsame_(trans, "N")) {
ldwork = *m + *nrhs;
tpsd = FALSE_;
if (*lwork < (*m + *nrhs) * (*n + 2)) {
xerbla_("DQRT14", &c__10);
return ret_val;
} else if (*n <= 0 || *nrhs <= 0) {
return ret_val;
}
} else if (lsame_(trans, "T")) {
ldwork = *m;
tpsd = TRUE_;
if (*lwork < (*n + *nrhs) * (*m + 2)) {
xerbla_("DQRT14", &c__10);
return ret_val;
} else if (*m <= 0 || *nrhs <= 0) {
return ret_val;
}
} else {
xerbla_("DQRT14", &c__1);
return ret_val;
}
/* Copy and scale A */
dlacpy_("All", m, n, &a[a_offset], lda, &work[1], &ldwork);
anrm = dlange_("M", m, n, &work[1], &ldwork, rwork);
if (anrm != 0.) {
dlascl_("G", &c__0, &c__0, &anrm, &c_b15, m, n, &work[1], &ldwork, &
info);
}
/* Copy X or X' into the right place and scale it */
if (tpsd) {
/* Copy X into columns n+1:n+nrhs of work */
dlacpy_("All", m, nrhs, &x[x_offset], ldx, &work[*n * ldwork + 1], &
ldwork);
xnrm = dlange_("M", m, nrhs, &work[*n * ldwork + 1], &ldwork, rwork);
if (xnrm != 0.) {
dlascl_("G", &c__0, &c__0, &xnrm, &c_b15, m, nrhs, &work[*n *
ldwork + 1], &ldwork, &info);
}
i__1 = *n + *nrhs;
anrm = dlange_("One-norm", m, &i__1, &work[1], &ldwork, rwork);
/* Compute QR factorization of X */
i__1 = *n + *nrhs;
/* Computing MIN */
i__2 = *m, i__3 = *n + *nrhs;
dgeqr2_(m, &i__1, &work[1], &ldwork, &work[ldwork * (*n + *nrhs) + 1],
&work[ldwork * (*n + *nrhs) + min(i__2, i__3)+ 1], &info);
/* Compute largest entry in upper triangle of */
/* work(n+1:m,n+1:n+nrhs) */
err = 0.;
i__1 = *n + *nrhs;
for (j = *n + 1; j <= i__1; ++j) {
i__2 = min(*m,j);
for (i__ = *n + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = err, d__3 = (d__1 = work[i__ + (j - 1) * *m], abs(d__1)
);
err = max(d__2,d__3);
/* L10: */
}
/* L20: */
}
} else {
/* Copy X' into rows m+1:m+nrhs of work */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *nrhs;
for (j = 1; j <= i__2; ++j) {
work[*m + j + (i__ - 1) * ldwork] = x[i__ + j * x_dim1];
/* L30: */
}
/* L40: */
}
xnrm = dlange_("M", nrhs, n, &work[*m + 1], &ldwork, rwork)
;
if (xnrm != 0.) {
dlascl_("G", &c__0, &c__0, &xnrm, &c_b15, nrhs, n, &work[*m + 1],
&ldwork, &info);
}
/* Compute LQ factorization of work */
dgelq2_(&ldwork, n, &work[1], &ldwork, &work[ldwork * *n + 1], &work[
ldwork * (*n + 1) + 1], &info);
/* Compute largest entry in lower triangle in */
/* work(m+1:m+nrhs,m+1:n) */
err = 0.;
i__1 = *n;
for (j = *m + 1; j <= i__1; ++j) {
i__2 = ldwork;
for (i__ = j; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = err, d__3 = (d__1 = work[i__ + (j - 1) * ldwork], abs(
d__1));
err = max(d__2,d__3);
/* L50: */
}
/* L60: */
}
}
/* Computing MAX */
i__1 = max(*m,*n);
ret_val = err / ((doublereal) max(i__1,*nrhs) * dlamch_("Epsilon"));
return ret_val;
/* End of DQRT14 */
} /* dqrt14_ */
/* Subroutine */ int dlqt03_(integer *m, integer *n, integer *k, doublereal *
af, doublereal *c__, doublereal *cc, doublereal *q, integer *lda,
doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
doublereal *result)
{
/* Initialized data */
static integer iseed[4] = { 1988,1989,1990,1991 };
/* System generated locals */
integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
q_offset, i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer j, mc, nc;
doublereal eps;
char side[1];
integer info;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
integer iside;
extern logical lsame_(char *, char *);
doublereal resid, cnorm;
char trans[1];
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), dlarnv_(integer *, integer *,
integer *, doublereal *), dorglq_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), dormlq_(char *, char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *);
integer itrans;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLQT03 tests DORMLQ, which computes Q*C, Q'*C, C*Q or C*Q'. */
/* DLQT03 compares the results of a call to DORMLQ with the results of */
/* forming Q explicitly by a call to DORGLQ and then performing matrix */
/* multiplication by a call to DGEMM. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows or columns of the matrix C; C is n-by-m if */
/* Q is applied from the left, or m-by-n if Q is applied from */
/* the right. M >= 0. */
/* N (input) INTEGER */
/* The order of the orthogonal matrix Q. N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* orthogonal matrix Q. N >= K >= 0. */
/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* Details of the LQ factorization of an m-by-n matrix, as */
/* returned by DGELQF. See SGELQF for further details. */
/* C (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
/* CC (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
/* Q (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays AF, C, CC, and Q. */
/* TAU (input) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the LQ factorization in AF. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of WORK. LWORK must be at least M, and should be */
/* M*NB, where NB is the blocksize for this environment. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
/* The test ratios compare two techniques for multiplying a */
/* random matrix C by an n-by-n orthogonal matrix Q. */
/* RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS ) */
/* RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS ) */
/* RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS ) */
/* RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
cc_dim1 = *lda;
cc_offset = 1 + cc_dim1;
cc -= cc_offset;
c_dim1 = *lda;
c_offset = 1 + c_dim1;
c__ -= c_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
eps = dlamch_("Epsilon");
/* Copy the first k rows of the factorization to the array Q */
dlaset_("Full", n, n, &c_b4, &c_b4, &q[q_offset], lda);
i__1 = *n - 1;
dlacpy_("Upper", k, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 << 1)
+ 1], lda);
/* Generate the n-by-n matrix Q */
s_copy(srnamc_1.srnamt, "DORGLQ", (ftnlen)6, (ftnlen)6);
dorglq_(n, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
for (iside = 1; iside <= 2; ++iside) {
if (iside == 1) {
*(unsigned char *)side = 'L';
mc = *n;
nc = *m;
} else {
*(unsigned char *)side = 'R';
mc = *m;
nc = *n;
}
/* Generate MC by NC matrix C */
i__1 = nc;
for (j = 1; j <= i__1; ++j) {
dlarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
/* L10: */
}
cnorm = dlange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
if (cnorm == 0.) {
cnorm = 1.;
}
for (itrans = 1; itrans <= 2; ++itrans) {
if (itrans == 1) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'T';
}
/* Copy C */
dlacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
lda);
/* Apply Q or Q' to C */
s_copy(srnamc_1.srnamt, "DORMLQ", (ftnlen)6, (ftnlen)6);
dormlq_(side, trans, &mc, &nc, k, &af[af_offset], lda, &tau[1], &
cc[cc_offset], lda, &work[1], lwork, &info);
/* Form explicit product and subtract */
if (lsame_(side, "L")) {
dgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[
q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[
cc_offset], lda);
} else {
dgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[
c_offset], lda, &q[q_offset], lda, &c_b22, &cc[
cc_offset], lda);
}
/* Compute error in the difference */
resid = dlange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
result[(iside - 1 << 1) + itrans] = resid / ((doublereal) max(1,*
n) * cnorm * eps);
/* L20: */
}
/* L30: */
}
return 0;
/* End of DLQT03 */
} /* dlqt03_ */
/* Subroutine */ int dqrt15_(integer *scale, integer *rksel, integer *m,
integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b,
integer *ldb, doublereal *s, integer *rank, doublereal *norma,
doublereal *normb, integer *iseed, doublereal *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
static integer info;
static doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer j;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dlarf_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *), dgemm_(char *, char *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
extern doublereal dasum_(integer *, doublereal *, integer *);
static doublereal dummy[1];
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
static integer mn;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
extern doublereal dlarnd_(integer *, integer *);
extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
integer *), dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
static doublereal bignum;
extern /* Subroutine */ int dlaror_(char *, char *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *), dlarnv_(integer *, integer *, integer *,
doublereal *);
static doublereal smlnum, eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DQRT15 generates a matrix with full or deficient rank and of various
norms.
Arguments
=========
SCALE (input) INTEGER
SCALE = 1: normally scaled matrix
SCALE = 2: matrix scaled up
SCALE = 3: matrix scaled down
RKSEL (input) INTEGER
RKSEL = 1: full rank matrix
RKSEL = 2: rank-deficient matrix
M (input) INTEGER
The number of rows of the matrix A.
N (input) INTEGER
The number of columns of A.
NRHS (input) INTEGER
The number of columns of B.
A (output) DOUBLE PRECISION array, dimension (LDA,N)
The M-by-N matrix A.
LDA (input) INTEGER
The leading dimension of the array A.
B (output) DOUBLE PRECISION array, dimension (LDB, NRHS)
A matrix that is in the range space of matrix A.
LDB (input) INTEGER
The leading dimension of the array B.
S (output) DOUBLE PRECISION array, dimension MIN(M,N)
Singular values of A.
RANK (output) INTEGER
number of nonzero singular values of A.
NORMA (output) DOUBLE PRECISION
one-norm of A.
NORMB (output) DOUBLE PRECISION
one-norm of B.
ISEED (input/output) integer array, dimension (4)
seed for random number generator.
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
LWORK (input) INTEGER
length of work space required.
LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--s;
--iseed;
--work;
/* Function Body */
mn = min(*m,*n);
/* Computing MAX */
i__1 = *m + mn, i__2 = mn * *nrhs, i__1 = max(i__1,i__2), i__2 = (*n << 1)
+ *m;
if (*lwork < max(i__1,i__2)) {
xerbla_("DQRT15", &c__16);
return 0;
}
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
eps = dlamch_("Epsilon");
smlnum = smlnum / eps / eps;
bignum = 1. / smlnum;
/* Determine rank and (unscaled) singular values */
if (*rksel == 1) {
*rank = mn;
} else if (*rksel == 2) {
*rank = mn * 3 / 4;
i__1 = mn;
for (j = *rank + 1; j <= i__1; ++j) {
s[j] = 0.;
/* L10: */
}
} else {
xerbla_("DQRT15", &c__2);
}
if (*rank > 0) {
/* Nontrivial case */
s[1] = 1.;
i__1 = *rank;
for (j = 2; j <= i__1; ++j) {
L20:
temp = dlarnd_(&c__1, &iseed[1]);
if (temp > .1) {
s[j] = abs(temp);
} else {
goto L20;
}
/* L30: */
}
dlaord_("Decreasing", rank, &s[1], &c__1);
/* Generate 'rank' columns of a random orthogonal matrix in A */
dlarnv_(&c__2, &iseed[1], m, &work[1]);
d__1 = 1. / dnrm2_(m, &work[1], &c__1);
dscal_(m, &d__1, &work[1], &c__1);
dlaset_("Full", m, rank, &c_b18, &c_b19, &a[a_offset], lda)
;
dlarf_("Left", m, rank, &work[1], &c__1, &c_b22, &a[a_offset], lda, &
work[*m + 1]);
/* workspace used: m+mn
Generate consistent rhs in the range space of A */
i__1 = *rank * *nrhs;
dlarnv_(&c__2, &iseed[1], &i__1, &work[1]);
dgemm_("No transpose", "No transpose", m, nrhs, rank, &c_b19, &a[
a_offset], lda, &work[1], rank, &c_b18, &b[b_offset], ldb);
/* work space used: <= mn *nrhs
generate (unscaled) matrix A */
i__1 = *rank;
for (j = 1; j <= i__1; ++j) {
dscal_(m, &s[j], &a_ref(1, j), &c__1);
/* L40: */
}
if (*rank < *n) {
i__1 = *n - *rank;
dlaset_("Full", m, &i__1, &c_b18, &c_b18, &a_ref(1, *rank + 1),
lda);
}
dlaror_("Right", "No initialization", m, n, &a[a_offset], lda, &iseed[
1], &work[1], &info);
} else {
/* work space used 2*n+m
Generate null matrix and rhs */
i__1 = mn;
for (j = 1; j <= i__1; ++j) {
s[j] = 0.;
/* L50: */
}
dlaset_("Full", m, n, &c_b18, &c_b18, &a[a_offset], lda);
dlaset_("Full", m, nrhs, &c_b18, &c_b18, &b[b_offset], ldb)
;
}
/* Scale the matrix */
if (*scale != 1) {
*norma = dlange_("Max", m, n, &a[a_offset], lda, dummy);
if (*norma != 0.) {
if (*scale == 2) {
/* matrix scaled up */
dlascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
a_offset], lda, &info);
dlascl_("General", &c__0, &c__0, norma, &bignum, &mn, &c__1, &
s[1], &mn, &info);
dlascl_("General", &c__0, &c__0, norma, &bignum, m, nrhs, &b[
b_offset], ldb, &info);
} else if (*scale == 3) {
/* matrix scaled down */
dlascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
a_offset], lda, &info);
dlascl_("General", &c__0, &c__0, norma, &smlnum, &mn, &c__1, &
s[1], &mn, &info);
dlascl_("General", &c__0, &c__0, norma, &smlnum, m, nrhs, &b[
b_offset], ldb, &info);
} else {
xerbla_("DQRT15", &c__1);
return 0;
}
}
}
*norma = dasum_(&mn, &s[1], &c__1);
*normb = dlange_("One-norm", m, nrhs, &b[b_offset], ldb, dummy)
;
return 0;
/* End of DQRT15 */
} /* dqrt15_ */
/* Subroutine */ int dlatme_(integer *n, char *dist, integer *iseed,
doublereal *d__, integer *mode, doublereal *cond, doublereal *dmax__,
char *ei, char *rsign, char *upper, char *sim, doublereal *ds,
integer *modes, doublereal *conds, integer *kl, integer *ku,
doublereal *anorm, doublereal *a, integer *lda, doublereal *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2, d__3;
/* Local variables */
integer i__, j, ic, jc, ir, jr, jcr;
doublereal tau;
logical bads;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
integer isim;
doublereal temp;
logical badei;
doublereal alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
integer iinfo;
doublereal tempa[1];
integer icols;
logical useei;
integer idist;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer irows;
extern /* Subroutine */ int dlatm1_(integer *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *, integer *);
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dlarge_(integer *, doublereal *, integer *,
integer *, doublereal *, integer *), dlarfg_(integer *,
doublereal *, doublereal *, integer *, doublereal *);
extern doublereal dlaran_(integer *);
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), dlarnv_(integer *, integer *,
integer *, doublereal *);
integer irsign, iupper;
doublereal xnorms;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLATME generates random non-symmetric square matrices with */
/* specified eigenvalues for testing LAPACK programs. */
/* DLATME operates by applying the following sequence of */
/* operations: */
/* 1. Set the diagonal to D, where D may be input or */
/* computed according to MODE, COND, DMAX, and RSIGN */
/* as described below. */
/* 2. If complex conjugate pairs are desired (MODE=0 and EI(1)='R', */
/* or MODE=5), certain pairs of adjacent elements of D are */
/* interpreted as the real and complex parts of a complex */
/* conjugate pair; A thus becomes block diagonal, with 1x1 */
/* and 2x2 blocks. */
/* 3. If UPPER='T', the upper triangle of A is set to random values */
/* out of distribution DIST. */
/* 4. If SIM='T', A is multiplied on the left by a random matrix */
/* X, whose singular values are specified by DS, MODES, and */
/* CONDS, and on the right by X inverse. */
/* 5. If KL < N-1, the lower bandwidth is reduced to KL using */
/* Householder transformations. If KU < N-1, the upper */
/* bandwidth is reduced to KU. */
/* 6. If ANORM is not negative, the matrix is scaled to have */
/* maximum-element-norm ANORM. */
/* (Note: since the matrix cannot be reduced beyond Hessenberg form, */
/* no packing options are available.) */
/* Arguments */
/* ========= */
/* N - INTEGER */
/* The number of columns (or rows) of A. Not modified. */
/* DIST - CHARACTER*1 */
/* On entry, DIST specifies the type of distribution to be used */
/* to generate the random eigen-/singular values, and for the */
/* upper triangle (see UPPER). */
/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
/* Not modified. */
/* ISEED - INTEGER array, dimension ( 4 ) */
/* On entry ISEED specifies the seed of the random number */
/* generator. They should lie between 0 and 4095 inclusive, */
/* and ISEED(4) should be odd. The random number generator */
/* uses a linear congruential sequence limited to small */
/* integers, and so should produce machine independent */
/* random numbers. The values of ISEED are changed on */
/* exit, and can be used in the next call to DLATME */
/* to continue the same random number sequence. */
/* Changed on exit. */
/* D - DOUBLE PRECISION array, dimension ( N ) */
/* This array is used to specify the eigenvalues of A. If */
/* MODE=0, then D is assumed to contain the eigenvalues (but */
/* see the description of EI), otherwise they will be */
/* computed according to MODE, COND, DMAX, and RSIGN and */
/* placed in D. */
/* Modified if MODE is nonzero. */
/* MODE - INTEGER */
/* On entry this describes how the eigenvalues are to */
/* be specified: */
/* MODE = 0 means use D (with EI) as input */
/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
/* MODE = 5 sets D to random numbers in the range */
/* ( 1/COND , 1 ) such that their logarithms */
/* are uniformly distributed. Each odd-even pair */
/* of elements will be either used as two real */
/* eigenvalues or as the real and imaginary part */
/* of a complex conjugate pair of eigenvalues; */
/* the choice of which is done is random, with */
/* 50-50 probability, for each pair. */
/* MODE = 6 set D to random numbers from same distribution */
/* as the rest of the matrix. */
/* MODE < 0 has the same meaning as ABS(MODE), except that */
/* the order of the elements of D is reversed. */
/* Thus if MODE is between 1 and 4, D has entries ranging */
/* from 1 to 1/COND, if between -1 and -4, D has entries */
/* ranging from 1/COND to 1, */
/* Not modified. */
/* COND - DOUBLE PRECISION */
/* On entry, this is used as described under MODE above. */
/* If used, it must be >= 1. Not modified. */
/* DMAX - DOUBLE PRECISION */
/* If MODE is neither -6, 0 nor 6, the contents of D, as */
/* computed according to MODE and COND, will be scaled by */
/* DMAX / max(abs(D(i))). Note that DMAX need not be */
/* positive: if DMAX is negative (or zero), D will be */
/* scaled by a negative number (or zero). */
/* Not modified. */
/* EI - CHARACTER*1 array, dimension ( N ) */
/* If MODE is 0, and EI(1) is not ' ' (space character), */
/* this array specifies which elements of D (on input) are */
/* real eigenvalues and which are the real and imaginary parts */
/* of a complex conjugate pair of eigenvalues. The elements */
/* of EI may then only have the values 'R' and 'I'. If */
/* EI(j)='R' and EI(j+1)='I', then the j-th eigenvalue is */
/* CMPLX( D(j) , D(j+1) ), and the (j+1)-th is the complex */
/* conjugate thereof. If EI(j)=EI(j+1)='R', then the j-th */
/* eigenvalue is D(j) (i.e., real). EI(1) may not be 'I', */
/* nor may two adjacent elements of EI both have the value 'I'. */
/* If MODE is not 0, then EI is ignored. If MODE is 0 and */
/* EI(1)=' ', then the eigenvalues will all be real. */
/* Not modified. */
/* RSIGN - CHARACTER*1 */
/* If MODE is not 0, 6, or -6, and RSIGN='T', then the */
/* elements of D, as computed according to MODE and COND, will */
/* be multiplied by a random sign (+1 or -1). If RSIGN='F', */
/* they will not be. RSIGN may only have the values 'T' or */
/* 'F'. */
/* Not modified. */
/* UPPER - CHARACTER*1 */
/* If UPPER='T', then the elements of A above the diagonal */
/* (and above the 2x2 diagonal blocks, if A has complex */
/* eigenvalues) will be set to random numbers out of DIST. */
/* If UPPER='F', they will not. UPPER may only have the */
/* values 'T' or 'F'. */
/* Not modified. */
/* SIM - CHARACTER*1 */
/* If SIM='T', then A will be operated on by a "similarity */
/* transform", i.e., multiplied on the left by a matrix X and */
/* on the right by X inverse. X = U S V, where U and V are */
/* random unitary matrices and S is a (diagonal) matrix of */
/* singular values specified by DS, MODES, and CONDS. If */
/* SIM='F', then A will not be transformed. */
/* Not modified. */
/* DS - DOUBLE PRECISION array, dimension ( N ) */
/* This array is used to specify the singular values of X, */
/* in the same way that D specifies the eigenvalues of A. */
/* If MODE=0, the DS contains the singular values, which */
/* may not be zero. */
/* Modified if MODE is nonzero. */
/* MODES - INTEGER */
/* CONDS - DOUBLE PRECISION */
/* Same as MODE and COND, but for specifying the diagonal */
/* of S. MODES=-6 and +6 are not allowed (since they would */
/* result in randomly ill-conditioned eigenvalues.) */
/* KL - INTEGER */
/* This specifies the lower bandwidth of the matrix. KL=1 */
/* specifies upper Hessenberg form. If KL is at least N-1, */
/* then A will have full lower bandwidth. KL must be at */
/* least 1. */
/* Not modified. */
/* KU - INTEGER */
/* This specifies the upper bandwidth of the matrix. KU=1 */
/* specifies lower Hessenberg form. If KU is at least N-1, */
/* then A will have full upper bandwidth; if KU and KL */
/* are both at least N-1, then A will be dense. Only one of */
/* KU and KL may be less than N-1. KU must be at least 1. */
/* Not modified. */
/* ANORM - DOUBLE PRECISION */
/* If ANORM is not negative, then A will be scaled by a non- */
/* negative real number to make the maximum-element-norm of A */
/* to be ANORM. */
/* Not modified. */
/* A - DOUBLE PRECISION array, dimension ( LDA, N ) */
/* On exit A is the desired test matrix. */
/* Modified. */
/* LDA - INTEGER */
/* LDA specifies the first dimension of A as declared in the */
/* calling program. LDA must be at least N. */
/* Not modified. */
/* WORK - DOUBLE PRECISION array, dimension ( 3*N ) */
/* Workspace. */
/* Modified. */
/* INFO - INTEGER */
/* Error code. On exit, INFO will be set to one of the */
/* following values: */
/* 0 => normal return */
/* -1 => N negative */
/* -2 => DIST illegal string */
/* -5 => MODE not in range -6 to 6 */
/* -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
/* -8 => EI(1) is not ' ' or 'R', EI(j) is not 'R' or 'I', or */
/* two adjacent elements of EI are 'I'. */
/* -9 => RSIGN is not 'T' or 'F' */
/* -10 => UPPER is not 'T' or 'F' */
/* -11 => SIM is not 'T' or 'F' */
/* -12 => MODES=0 and DS has a zero singular value. */
/* -13 => MODES is not in the range -5 to 5. */
/* -14 => MODES is nonzero and CONDS is less than 1. */
/* -15 => KL is less than 1. */
/* -16 => KU is less than 1, or KL and KU are both less than */
/* N-1. */
/* -19 => LDA is less than N. */
/* 1 => Error return from DLATM1 (computing D) */
/* 2 => Cannot scale to DMAX (max. eigenvalue is 0) */
/* 3 => Error return from DLATM1 (computing DS) */
/* 4 => Error return from DLARGE */
/* 5 => Zero singular value from DLATM1. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* 1) Decode and Test the input parameters. */
/* Initialize flags & seed. */
/* Parameter adjustments */
--iseed;
--d__;
--ei;
--ds;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Decode DIST */
if (lsame_(dist, "U")) {
idist = 1;
} else if (lsame_(dist, "S")) {
idist = 2;
} else if (lsame_(dist, "N")) {
idist = 3;
} else {
idist = -1;
}
/* Check EI */
useei = TRUE_;
badei = FALSE_;
if (lsame_(ei + 1, " ") || *mode != 0) {
useei = FALSE_;
} else {
if (lsame_(ei + 1, "R")) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
if (lsame_(ei + j, "I")) {
if (lsame_(ei + (j - 1), "I")) {
badei = TRUE_;
}
} else {
if (! lsame_(ei + j, "R")) {
badei = TRUE_;
}
}
/* L10: */
}
} else {
badei = TRUE_;
}
}
/* Decode RSIGN */
if (lsame_(rsign, "T")) {
irsign = 1;
} else if (lsame_(rsign, "F")) {
irsign = 0;
} else {
irsign = -1;
}
/* Decode UPPER */
if (lsame_(upper, "T")) {
iupper = 1;
} else if (lsame_(upper, "F")) {
iupper = 0;
} else {
iupper = -1;
}
/* Decode SIM */
if (lsame_(sim, "T")) {
isim = 1;
} else if (lsame_(sim, "F")) {
isim = 0;
} else {
isim = -1;
}
/* Check DS, if MODES=0 and ISIM=1 */
bads = FALSE_;
if (*modes == 0 && isim == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (ds[j] == 0.) {
bads = TRUE_;
}
/* L20: */
}
}
/* Set INFO if an error */
if (*n < 0) {
*info = -1;
} else if (idist == -1) {
*info = -2;
} else if (abs(*mode) > 6) {
*info = -5;
} else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) {
*info = -6;
} else if (badei) {
*info = -8;
} else if (irsign == -1) {
*info = -9;
} else if (iupper == -1) {
*info = -10;
} else if (isim == -1) {
*info = -11;
} else if (bads) {
*info = -12;
} else if (isim == 1 && abs(*modes) > 5) {
*info = -13;
} else if (isim == 1 && *modes != 0 && *conds < 1.) {
*info = -14;
} else if (*kl < 1) {
*info = -15;
} else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) {
*info = -16;
} else if (*lda < max(1,*n)) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLATME", &i__1);
return 0;
}
/* Initialize random number generator */
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
/* L30: */
}
if (iseed[4] % 2 != 1) {
++iseed[4];
}
/* 2) Set up diagonal of A */
/* Compute D according to COND and MODE */
dlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], n, &iinfo);
if (iinfo != 0) {
*info = 1;
return 0;
}
if (*mode != 0 && abs(*mode) != 6) {
/* Scale by DMAX */
temp = abs(d__[1]);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1));
temp = max(d__2,d__3);
/* L40: */
}
if (temp > 0.) {
alpha = *dmax__ / temp;
} else if (*dmax__ != 0.) {
*info = 2;
return 0;
} else {
alpha = 0.;
}
dscal_(n, &alpha, &d__[1], &c__1);
}
dlaset_("Full", n, n, &c_b23, &c_b23, &a[a_offset], lda);
i__1 = *lda + 1;
dcopy_(n, &d__[1], &c__1, &a[a_offset], &i__1);
/* Set up complex conjugate pairs */
if (*mode == 0) {
if (useei) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
if (lsame_(ei + j, "I")) {
a[j - 1 + j * a_dim1] = a[j + j * a_dim1];
a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1];
a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1];
}
/* L50: */
}
}
} else if (abs(*mode) == 5) {
i__1 = *n;
for (j = 2; j <= i__1; j += 2) {
if (dlaran_(&iseed[1]) > .5) {
a[j - 1 + j * a_dim1] = a[j + j * a_dim1];
a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1];
a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1];
}
/* L60: */
}
}
/* 3) If UPPER='T', set upper triangle of A to random numbers. */
/* (but don't modify the corners of 2x2 blocks.) */
if (iupper != 0) {
i__1 = *n;
for (jc = 2; jc <= i__1; ++jc) {
if (a[jc - 1 + jc * a_dim1] != 0.) {
jr = jc - 2;
} else {
jr = jc - 1;
}
dlarnv_(&idist, &iseed[1], &jr, &a[jc * a_dim1 + 1]);
/* L70: */
}
}
/* 4) If SIM='T', apply similarity transformation. */
/* -1 */
/* Transform is X A X , where X = U S V, thus */
/* it is U S V A V' (1/S) U' */
if (isim != 0) {
/* Compute S (singular values of the eigenvector matrix) */
/* according to CONDS and MODES */
dlatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo);
if (iinfo != 0) {
*info = 3;
return 0;
}
/* Multiply by V and V' */
dlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
if (iinfo != 0) {
*info = 4;
return 0;
}
/* Multiply by S and (1/S) */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dscal_(n, &ds[j], &a[j + a_dim1], lda);
if (ds[j] != 0.) {
d__1 = 1. / ds[j];
dscal_(n, &d__1, &a[j * a_dim1 + 1], &c__1);
} else {
*info = 5;
return 0;
}
/* L80: */
}
/* Multiply by U and U' */
dlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
if (iinfo != 0) {
*info = 4;
return 0;
}
}
/* 5) Reduce the bandwidth. */
if (*kl < *n - 1) {
/* Reduce bandwidth -- kill column */
i__1 = *n - 1;
for (jcr = *kl + 1; jcr <= i__1; ++jcr) {
ic = jcr - *kl;
irows = *n + 1 - jcr;
icols = *n + *kl - jcr;
dcopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1);
xnorms = work[1];
dlarfg_(&irows, &xnorms, &work[2], &c__1, &tau);
work[1] = 1.;
dgemv_("T", &irows, &icols, &c_b39, &a[jcr + (ic + 1) * a_dim1],
lda, &work[1], &c__1, &c_b23, &work[irows + 1], &c__1);
d__1 = -tau;
dger_(&irows, &icols, &d__1, &work[1], &c__1, &work[irows + 1], &
c__1, &a[jcr + (ic + 1) * a_dim1], lda);
dgemv_("N", n, &irows, &c_b39, &a[jcr * a_dim1 + 1], lda, &work[1]
, &c__1, &c_b23, &work[irows + 1], &c__1);
d__1 = -tau;
dger_(n, &irows, &d__1, &work[irows + 1], &c__1, &work[1], &c__1,
&a[jcr * a_dim1 + 1], lda);
a[jcr + ic * a_dim1] = xnorms;
i__2 = irows - 1;
dlaset_("Full", &i__2, &c__1, &c_b23, &c_b23, &a[jcr + 1 + ic *
a_dim1], lda);
/* L90: */
}
} else if (*ku < *n - 1) {
/* Reduce upper bandwidth -- kill a row at a time. */
i__1 = *n - 1;
for (jcr = *ku + 1; jcr <= i__1; ++jcr) {
ir = jcr - *ku;
irows = *n + *ku - jcr;
icols = *n + 1 - jcr;
dcopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1);
xnorms = work[1];
dlarfg_(&icols, &xnorms, &work[2], &c__1, &tau);
work[1] = 1.;
dgemv_("N", &irows, &icols, &c_b39, &a[ir + 1 + jcr * a_dim1],
lda, &work[1], &c__1, &c_b23, &work[icols + 1], &c__1);
d__1 = -tau;
dger_(&irows, &icols, &d__1, &work[icols + 1], &c__1, &work[1], &
c__1, &a[ir + 1 + jcr * a_dim1], lda);
dgemv_("C", &icols, n, &c_b39, &a[jcr + a_dim1], lda, &work[1], &
c__1, &c_b23, &work[icols + 1], &c__1);
d__1 = -tau;
dger_(&icols, n, &d__1, &work[1], &c__1, &work[icols + 1], &c__1,
&a[jcr + a_dim1], lda);
a[ir + jcr * a_dim1] = xnorms;
i__2 = icols - 1;
dlaset_("Full", &c__1, &i__2, &c_b23, &c_b23, &a[ir + (jcr + 1) *
a_dim1], lda);
/* L100: */
}
}
/* Scale the matrix to have norm ANORM */
if (*anorm >= 0.) {
temp = dlange_("M", n, n, &a[a_offset], lda, tempa);
if (temp > 0.) {
alpha = *anorm / temp;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dscal_(n, &alpha, &a[j * a_dim1 + 1], &c__1);
/* L110: */
}
}
}
return 0;
/* End of DLATME */
} /* dlatme_ */
doublereal drzt02_(integer *m, integer *n, doublereal *af, integer *lda,
doublereal *tau, doublereal *work, integer *lwork)
{
/* System generated locals */
integer af_dim1, af_offset, i__1, i__2;
doublereal ret_val;
/* Local variables */
integer i__, info;
doublereal rwork[1];
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), dormrz_(char *, char *,
integer *, integer *, integer *, integer *, doublereal *, integer
*, doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DRZT02 returns */
/* || I - Q'*Q || / ( M * eps) */
/* where the matrix Q is defined by the Householder transformations */
/* generated by DTZRZF. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix AF. */
/* N (input) INTEGER */
/* The number of columns of the matrix AF. */
/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The output of DTZRZF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array AF. */
/* TAU (input) DOUBLE PRECISION array, dimension (M) */
/* Details of the Householder transformations as returned by */
/* DTZRZF. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* length of WORK array. LWORK >= N*N+N*NB. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
--tau;
--work;
/* Function Body */
ret_val = 0.;
if (*lwork < *n * *n + *n) {
xerbla_("DRZT02", &c__7);
return ret_val;
}
/* Quick return if possible */
if (*m <= 0 || *n <= 0) {
return ret_val;
}
/* Q := I */
dlaset_("Full", n, n, &c_b5, &c_b6, &work[1], n);
/* Q := P(1) * ... * P(m) * Q */
i__1 = *n - *m;
i__2 = *lwork - *n * *n;
dormrz_("Left", "No transpose", n, n, m, &i__1, &af[af_offset], lda, &tau[
1], &work[1], n, &work[*n * *n + 1], &i__2, &info);
/* Q := P(m) * ... * P(1) * Q */
i__1 = *n - *m;
i__2 = *lwork - *n * *n;
dormrz_("Left", "Transpose", n, n, m, &i__1, &af[af_offset], lda, &tau[1],
&work[1], n, &work[*n * *n + 1], &i__2, &info);
/* Q := Q - I */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[(i__ - 1) * *n + i__] += -1.;
/* L10: */
}
ret_val = dlange_("One-norm", n, n, &work[1], n, rwork) / (
dlamch_("Epsilon") * (doublereal) max(*m,*n));
return ret_val;
/* End of DRZT02 */
} /* drzt02_ */
/* Subroutine */ int dgelsd_(integer *m, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork,
integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
/* Builtin functions */
double log(doublereal);
/* Local variables */
static doublereal anrm, bnrm;
static integer itau, nlvl, iascl, ibscl;
static doublereal sfmin;
static integer minmn, maxmn, itaup, itauq, mnthr, nwork;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
static integer ie, il;
extern /* Subroutine */ int dgebrd_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
extern doublereal dlamch_(char *);
static integer mm;
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *),
dlalsd_(char *, integer *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *), dlascl_(char *,
integer *, integer *, doublereal *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *), dgeqrf_(
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *), dlaset_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static doublereal bignum;
extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *);
static integer wlalsd;
extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
static integer ldwork;
extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
static integer minwrk, maxwrk;
static doublereal smlnum;
static logical lquery;
static integer smlsiz;
static doublereal eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
DGELSD computes the minimum-norm solution to a real linear least
squares problem:
minimize 2-norm(| b - A*x |)
using the singular value decomposition (SVD) of A. A is an M-by-N
matrix which may be rank-deficient.
Several right hand side vectors b and solution vectors x can be
handled in a single call; they are stored as the columns of the
M-by-NRHS right hand side matrix B and the N-by-NRHS solution
matrix X.
The problem is solved in three steps:
(1) Reduce the coefficient matrix A to bidiagonal form with
Householder transformations, reducing the original problem
into a "bidiagonal least squares problem" (BLS)
(2) Solve the BLS using a divide and conquer approach.
(3) Apply back all the Householder tranformations to solve
the original least squares problem.
The effective rank of A is determined by treating as zero those
singular values which are less than RCOND times the largest singular
value.
The divide and conquer algorithm makes very mild assumptions about
floating point arithmetic. It will work on machines with a guard
digit in add/subtract, or on those binary machines without guard
digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
Cray-2. It could conceivably fail on hexadecimal or decimal machines
without guard digits, but we know of none.
Arguments
=========
M (input) INTEGER
The number of rows of A. M >= 0.
N (input) INTEGER
The number of columns of A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, A has been destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
On entry, the M-by-NRHS right hand side matrix B.
On exit, B is overwritten by the N-by-NRHS solution
matrix X. If m >= n and RANK = n, the residual
sum-of-squares for the solution in the i-th column is given
by the sum of squares of elements n+1:m in that column.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,max(M,N)).
S (output) DOUBLE PRECISION array, dimension (min(M,N))
The singular values of A in decreasing order.
The condition number of A in the 2-norm = S(1)/S(min(m,n)).
RCOND (input) DOUBLE PRECISION
RCOND is used to determine the effective rank of A.
Singular values S(i) <= RCOND*S(1) are treated as zero.
If RCOND < 0, machine precision is used instead.
RANK (output) INTEGER
The effective rank of A, i.e., the number of singular values
which are greater than RCOND*S(1).
WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK must be at least 1.
The exact minimum amount of workspace needed depends on M,
N and NRHS. As long as LWORK is at least
12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,
if M is greater than or equal to N or
12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,
if M is less than N, the code will execute correctly.
SMLSIZ is returned by ILAENV and is equal to the maximum
size of the subproblems at the bottom of the computation
tree (usually about 25), and
NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
For good performance, LWORK should generally be larger.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
IWORK (workspace) INTEGER array, dimension (LIWORK)
LIWORK >= 3 * MINMN * NLVL + 11 * MINMN,
where MINMN = MIN( M,N ).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: the algorithm for computing the SVD failed to converge;
if INFO = i, i off-diagonal elements of an intermediate
bidiagonal form did not converge to zero.
Further Details
===============
Based on contributions by
Ming Gu and Ren-Cang Li, Computer Science Division, University of
California at Berkeley, USA
Osni Marques, LBNL/NERSC, USA
=====================================================================
Test the input arguments.
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--s;
--work;
--iwork;
/* Function Body */
*info = 0;
minmn = min(*m,*n);
maxmn = max(*m,*n);
mnthr = ilaenv_(&c__6, "DGELSD", " ", m, n, nrhs, &c_n1, (ftnlen)6, (
ftnlen)1);
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,maxmn)) {
*info = -7;
}
smlsiz = ilaenv_(&c__9, "DGELSD", " ", &c__0, &c__0, &c__0, &c__0, (
ftnlen)6, (ftnlen)1);
/* Compute workspace.
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV.) */
minwrk = 1;
minmn = max(1,minmn);
/* Computing MAX */
i__1 = (integer) (log((doublereal) minmn / (doublereal) (smlsiz + 1)) /
log(2.)) + 1;
nlvl = max(i__1,0);
if (*info == 0) {
maxwrk = 0;
mm = *m;
if (*m >= *n && *m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than columns. */
mm = *n;
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m,
n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "DORMQR", "LT",
m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)2);
maxwrk = max(i__1,i__2);
}
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined.
Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1, "DGEBRD"
, " ", &mm, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, "DORMBR",
"QLT", &mm, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1, "DORMBR",
"PLN", n, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2);
/* Computing 2nd power */
i__1 = smlsiz + 1;
wlalsd = *n * 9 + (*n << 1) * smlsiz + (*n << 3) * nlvl + *n * *
nrhs + i__1 * i__1;
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + wlalsd;
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,i__2),
i__2 = *n * 3 + wlalsd;
minwrk = max(i__1,i__2);
}
if (*n > *m) {
/* Computing 2nd power */
i__1 = smlsiz + 1;
wlalsd = *m * 9 + (*m << 1) * smlsiz + (*m << 3) * nlvl + *m * *
nrhs + i__1 * i__1;
if (*n >= mnthr) {
/* Path 2a - underdetermined, with many more columns
than rows. */
maxwrk = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1,
&c_n1, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) *
ilaenv_(&c__1, "DGEBRD", " ", m, m, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * ilaenv_(&
c__1, "DORMBR", "QLT", m, nrhs, m, &c_n1, (ftnlen)6, (
ftnlen)3);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) *
ilaenv_(&c__1, "DORMBR", "PLN", m, nrhs, m, &c_n1, (
ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2);
if (*nrhs > 1) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
maxwrk = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "DORMLQ",
"LT", n, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)2);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + wlalsd;
maxwrk = max(i__1,i__2);
} else {
/* Path 2 - remaining underdetermined cases. */
maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, "DGEBRD", " ", m,
n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, "DORMBR"
, "QLT", m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR",
"PLN", n, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + wlalsd;
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *m, i__1 = max(i__1,i__2),
i__2 = *m * 3 + wlalsd;
minwrk = max(i__1,i__2);
}
minwrk = min(minwrk,maxwrk);
work[1] = (doublereal) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGELSD", &i__1);
return 0;
} else if (lquery) {
goto L10;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0) {
*rank = 0;
return 0;
}
/* Get machine parameters. */
eps = dlamch_("P");
sfmin = dlamch_("S");
smlnum = sfmin / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Scale A if max entry outside range [SMLNUM,BIGNUM]. */
anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]);
iascl = 0;
if (anrm > 0. && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM. */
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
info);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM. */
dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
info);
iascl = 2;
} else if (anrm == 0.) {
/* Matrix all zero. Return zero solution. */
i__1 = max(*m,*n);
dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b[b_offset], ldb);
dlaset_("F", &minmn, &c__1, &c_b82, &c_b82, &s[1], &c__1);
*rank = 0;
goto L10;
}
/* Scale B if max entry outside range [SMLNUM,BIGNUM]. */
bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
ibscl = 0;
if (bnrm > 0. && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM. */
dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
info);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM. */
dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
info);
ibscl = 2;
}
/* If M < N make sure certain entries of B are zero. */
if (*m < *n) {
i__1 = *n - *m;
dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b_ref(*m + 1, 1), ldb);
}
/* Overdetermined case. */
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined. */
mm = *m;
if (*m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than columns. */
mm = *n;
itau = 1;
nwork = itau + *n;
/* Compute A=Q*R.
(Workspace: need 2*N, prefer N+N*NB) */
i__1 = *lwork - nwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
info);
/* Multiply B by transpose(Q).
(Workspace: need N+NRHS, prefer N+NRHS*NB) */
i__1 = *lwork - nwork + 1;
dormqr_("L", "T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[
b_offset], ldb, &work[nwork], &i__1, info);
/* Zero out below R. */
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
dlaset_("L", &i__1, &i__2, &c_b82, &c_b82, &a_ref(2, 1), lda);
}
}
ie = 1;
itauq = ie + *n;
itaup = itauq + *n;
nwork = itaup + *n;
/* Bidiagonalize R in A.
(Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */
i__1 = *lwork - nwork + 1;
dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of R.
(Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */
i__1 = *lwork - nwork + 1;
dormbr_("Q", "L", "T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq],
&b[b_offset], ldb, &work[nwork], &i__1, info);
/* Solve the bidiagonal least squares problem. */
dlalsd_("U", &smlsiz, n, nrhs, &s[1], &work[ie], &b[b_offset], ldb,
rcond, rank, &work[nwork], &iwork[1], info);
if (*info != 0) {
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of R. */
i__1 = *lwork - nwork + 1;
dormbr_("P", "L", "N", n, nrhs, n, &a[a_offset], lda, &work[itaup], &
b[b_offset], ldb, &work[nwork], &i__1, info);
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = *m, i__2 = (*m << 1) - 4, i__1 = max(i__1,i__2), i__1 = max(
i__1,*nrhs), i__2 = *n - *m * 3;
if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1,i__2)) {
/* Path 2a - underdetermined, with many more columns than rows
and sufficient workspace for an efficient algorithm. */
ldwork = *m;
/* Computing MAX
Computing MAX */
i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 =
max(i__3,*nrhs), i__4 = *n - *m * 3;
i__1 = (*m << 2) + *m * *lda + max(i__3,i__4), i__2 = *m * *lda +
*m + *m * *nrhs;
if (*lwork >= max(i__1,i__2)) {
ldwork = *lda;
}
itau = 1;
nwork = *m + 1;
/* Compute A=L*Q.
(Workspace: need 2*M, prefer M+M*NB) */
i__1 = *lwork - nwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
info);
il = nwork;
/* Copy L to WORK(IL), zeroing out above its diagonal. */
dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork);
i__1 = *m - 1;
i__2 = *m - 1;
dlaset_("U", &i__1, &i__2, &c_b82, &c_b82, &work[il + ldwork], &
ldwork);
ie = il + ldwork * *m;
itauq = ie + *m;
itaup = itauq + *m;
nwork = itaup + *m;
/* Bidiagonalize L in WORK(IL).
(Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */
i__1 = *lwork - nwork + 1;
dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq],
&work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of L.
(Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */
i__1 = *lwork - nwork + 1;
dormbr_("Q", "L", "T", m, nrhs, m, &work[il], &ldwork, &work[
itauq], &b[b_offset], ldb, &work[nwork], &i__1, info);
/* Solve the bidiagonal least squares problem. */
dlalsd_("U", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset],
ldb, rcond, rank, &work[nwork], &iwork[1], info);
if (*info != 0) {
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of L. */
i__1 = *lwork - nwork + 1;
dormbr_("P", "L", "N", m, nrhs, m, &work[il], &ldwork, &work[
itaup], &b[b_offset], ldb, &work[nwork], &i__1, info);
/* Zero out below first M rows of B. */
i__1 = *n - *m;
dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b_ref(*m + 1, 1), ldb);
nwork = itau + *m;
/* Multiply transpose(Q) by B.
(Workspace: need M+NRHS, prefer M+NRHS*NB) */
i__1 = *lwork - nwork + 1;
dormlq_("L", "T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[
b_offset], ldb, &work[nwork], &i__1, info);
} else {
/* Path 2 - remaining underdetermined cases. */
ie = 1;
itauq = ie + *m;
itaup = itauq + *m;
nwork = itaup + *m;
/* Bidiagonalize A.
(Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
i__1 = *lwork - nwork + 1;
dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors.
(Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */
i__1 = *lwork - nwork + 1;
dormbr_("Q", "L", "T", m, nrhs, n, &a[a_offset], lda, &work[itauq]
, &b[b_offset], ldb, &work[nwork], &i__1, info);
/* Solve the bidiagonal least squares problem. */
dlalsd_("L", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset],
ldb, rcond, rank, &work[nwork], &iwork[1], info);
if (*info != 0) {
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of A. */
i__1 = *lwork - nwork + 1;
dormbr_("P", "L", "N", n, nrhs, m, &a[a_offset], lda, &work[itaup]
, &b[b_offset], ldb, &work[nwork], &i__1, info);
}
}
/* Undo scaling. */
if (iascl == 1) {
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
info);
dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
minmn, info);
} else if (iascl == 2) {
dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
info);
dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
minmn, info);
}
if (ibscl == 1) {
dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
info);
} else if (ibscl == 2) {
dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
info);
}
L10:
work[1] = (doublereal) maxwrk;
return 0;
/* End of DGELSD */
} /* dgelsd_ */
/* Subroutine */ int dqlt01_(integer *m, integer *n, doublereal *a,
doublereal *af, doublereal *q, doublereal *l, integer *lda,
doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1, i__2;
/* Local variables */
doublereal eps;
integer info;
doublereal resid, anorm;
integer minmn;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DQLT01 tests DGEQLF, which computes the QL factorization of an m-by-n */
/* matrix A, and partially tests DORGQL which forms the m-by-m */
/* orthogonal matrix Q. */
/* DQLT01 compares L with Q'*A, and checks that Q is orthogonal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The m-by-n matrix A. */
/* AF (output) DOUBLE PRECISION array, dimension (LDA,N) */
/* Details of the QL factorization of A, as returned by DGEQLF. */
/* See DGEQLF for further details. */
/* Q (output) DOUBLE PRECISION array, dimension (LDA,M) */
/* The m-by-m orthogonal matrix Q. */
/* L (workspace) DOUBLE PRECISION array, dimension (LDA,max(M,N)) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and R. */
/* LDA >= max(M,N). */
/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by DGEQLF. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* The test ratios: */
/* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
minmn = min(*m,*n);
eps = dlamch_("Epsilon");
/* Copy the matrix A to the array AF. */
dlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
/* Factorize the matrix A in the array AF. */
s_copy(srnamc_1.srnamt, "DGEQLF", (ftnlen)32, (ftnlen)6);
dgeqlf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy details of Q */
dlaset_("Full", m, m, &c_b6, &c_b6, &q[q_offset], lda);
if (*m >= *n) {
if (*n < *m && *n > 0) {
i__1 = *m - *n;
dlacpy_("Full", &i__1, n, &af[af_offset], lda, &q[(*m - *n + 1) *
q_dim1 + 1], lda);
}
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
dlacpy_("Upper", &i__1, &i__2, &af[*m - *n + 1 + (af_dim1 << 1)],
lda, &q[*m - *n + 1 + (*m - *n + 2) * q_dim1], lda);
}
} else {
if (*m > 1) {
i__1 = *m - 1;
i__2 = *m - 1;
dlacpy_("Upper", &i__1, &i__2, &af[(*n - *m + 2) * af_dim1 + 1],
lda, &q[(q_dim1 << 1) + 1], lda);
}
}
/* Generate the m-by-m matrix Q */
s_copy(srnamc_1.srnamt, "DORGQL", (ftnlen)32, (ftnlen)6);
dorgql_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L */
dlaset_("Full", m, n, &c_b13, &c_b13, &l[l_offset], lda);
if (*m >= *n) {
if (*n > 0) {
dlacpy_("Lower", n, n, &af[*m - *n + 1 + af_dim1], lda, &l[*m - *
n + 1 + l_dim1], lda);
}
} else {
if (*n > *m && *m > 0) {
i__1 = *n - *m;
dlacpy_("Full", m, &i__1, &af[af_offset], lda, &l[l_offset], lda);
}
if (*m > 0) {
dlacpy_("Lower", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &l[(
*n - *m + 1) * l_dim1 + 1], lda);
}
}
/* Compute L - Q'*A */
dgemm_("Transpose", "No transpose", m, n, m, &c_b20, &q[q_offset], lda, &
a[a_offset], lda, &c_b21, &l[l_offset], lda);
/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
anorm = dlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
resid = dlange_("1", m, n, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*m) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q'*Q */
dlaset_("Full", m, m, &c_b13, &c_b21, &l[l_offset], lda);
dsyrk_("Upper", "Transpose", m, m, &c_b20, &q[q_offset], lda, &c_b21, &l[
l_offset], lda);
/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
resid = dlansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*m) / eps;
return 0;
/* End of DQLT01 */
} /* dqlt01_ */
/* Subroutine */ int dgegs_(char *jobvsl, char *jobvsr, integer *n,
doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
alphar, doublereal *alphai, doublereal *beta, doublereal *vsl,
integer *ldvsl, doublereal *vsr, integer *ldvsr, doublereal *work,
integer *lwork, integer *info)
{
/* -- LAPACK driver 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
=======
This routine is deprecated and has been replaced by routine DGGES.
DGEGS computes for a pair of N-by-N real nonsymmetric matrices A, B:
the generalized eigenvalues (alphar +/- alphai*i, beta), the real
Schur form (A, B), and optionally left and/or right Schur vectors
(VSL and VSR).
(If only the generalized eigenvalues are needed, use the driver DGEGV
instead.)
A generalized eigenvalue for a pair of matrices (A,B) is, roughly
speaking, a scalar w or a ratio alpha/beta = w, such that A - w*B
is singular. It is usually represented as the pair (alpha,beta),
as there is a reasonable interpretation for beta=0, and even for
both being zero. A good beginning reference is the book, "Matrix
Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press)
The (generalized) Schur form of a pair of matrices is the result of
multiplying both matrices on the left by one orthogonal matrix and
both on the right by another orthogonal matrix, these two orthogonal
matrices being chosen so as to bring the pair of matrices into
(real) Schur form.
A pair of matrices A, B is in generalized real Schur form if B is
upper triangular with non-negative diagonal and A is block upper
triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
to real generalized eigenvalues, while 2-by-2 blocks of A will be
"standardized" by making the corresponding elements of B have the
form:
[ a 0 ]
[ 0 b ]
and the pair of corresponding 2-by-2 blocks in A and B will
have a complex conjugate pair of generalized eigenvalues.
The left and right Schur vectors are the columns of VSL and VSR,
respectively, where VSL and VSR are the orthogonal matrices
which reduce A and B to Schur form:
Schur form of (A,B) = ( (VSL)**T A (VSR), (VSL)**T B (VSR) )
Arguments
=========
JOBVSL (input) CHARACTER*1
= 'N': do not compute the left Schur vectors;
= 'V': compute the left Schur vectors.
JOBVSR (input) CHARACTER*1
= 'N': do not compute the right Schur vectors;
= 'V': compute the right Schur vectors.
N (input) INTEGER
The order of the matrices A, B, VSL, and VSR. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
On entry, the first of the pair of matrices whose generalized
eigenvalues and (optionally) Schur vectors are to be
computed.
On exit, the generalized Schur form of A.
Note: to avoid overflow, the Frobenius norm of the matrix
A should be less than the overflow threshold.
LDA (input) INTEGER
The leading dimension of A. LDA >= max(1,N).
B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
On entry, the second of the pair of matrices whose
generalized eigenvalues and (optionally) Schur vectors are
to be computed.
On exit, the generalized Schur form of B.
Note: to avoid overflow, the Frobenius norm of the matrix
B should be less than the overflow threshold.
LDB (input) INTEGER
The leading dimension of B. LDB >= max(1,N).
ALPHAR (output) DOUBLE PRECISION array, dimension (N)
ALPHAI (output) DOUBLE PRECISION array, dimension (N)
BETA (output) DOUBLE PRECISION array, dimension (N)
On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i,
j=1,...,N and BETA(j),j=1,...,N are the diagonals of the
complex Schur form (A,B) that would result if the 2-by-2
diagonal blocks of the real Schur form of (A,B) were further
reduced to triangular form using 2-by-2 complex unitary
transformations. If ALPHAI(j) is zero, then the j-th
eigenvalue is real; if positive, then the j-th and (j+1)-st
eigenvalues are a complex conjugate pair, with ALPHAI(j+1)
negative.
Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
may easily over- or underflow, and BETA(j) may even be zero.
Thus, the user should avoid naively computing the ratio
alpha/beta. However, ALPHAR and ALPHAI will be always less
than and usually comparable with norm(A) in magnitude, and
BETA always less than and usually comparable with norm(B).
VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)
If JOBVSL = 'V', VSL will contain the left Schur vectors.
(See "Purpose", above.)
Not referenced if JOBVSL = 'N'.
LDVSL (input) INTEGER
The leading dimension of the matrix VSL. LDVSL >=1, and
if JOBVSL = 'V', LDVSL >= N.
VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)
If JOBVSR = 'V', VSR will contain the right Schur vectors.
(See "Purpose", above.)
Not referenced if JOBVSR = 'N'.
LDVSR (input) INTEGER
The leading dimension of the matrix VSR. LDVSR >= 1, and
if JOBVSR = 'V', LDVSR >= N.
WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,4*N).
For good performance, LWORK must generally be larger.
To compute the optimal value of LWORK, call ILAENV to get
blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute:
NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR
The optimal LWORK is 2*N + N*(NB+1).
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
= 1,...,N:
The QZ iteration failed. (A,B) are not in Schur
form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
be correct for j=INFO+1,...,N.
> N: errors that usually indicate LAPACK problems:
=N+1: error return from DGGBAL
=N+2: error return from DGEQRF
=N+3: error return from DORMQR
=N+4: error return from DORGQR
=N+5: error return from DGGHRD
=N+6: error return from DHGEQZ (other than failed
iteration)
=N+7: error return from DGGBAK (computing VSL)
=N+8: error return from DGGBAK (computing VSR)
=N+9: error return from DLASCL (various places)
=====================================================================
Decode the input arguments
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b36 = 0.;
static doublereal c_b37 = 1.;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
vsr_dim1, vsr_offset, i__1, i__2;
/* Local variables */
static doublereal anrm, bnrm;
static integer itau, lopt;
extern logical lsame_(char *, char *);
static integer ileft, iinfo, icols;
static logical ilvsl;
static integer iwork;
static logical ilvsr;
static integer irows;
extern /* Subroutine */ int dggbak_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, integer *);
static integer nb;
extern /* Subroutine */ int dggbal_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal
*, doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
static logical ilascl, ilbscl;
extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *);
static doublereal safmin;
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static doublereal bignum;
extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *);
static integer ijobvl, iright, ijobvr;
extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *);
static doublereal anrmto;
static integer lwkmin, nb1, nb2, nb3;
static doublereal bnrmto;
extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
static doublereal smlnum;
static integer lwkopt;
static logical lquery;
static integer ihi, ilo;
static doublereal eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define vsl_ref(a_1,a_2) vsl[(a_2)*vsl_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alphar;
--alphai;
--beta;
vsl_dim1 = *ldvsl;
vsl_offset = 1 + vsl_dim1 * 1;
vsl -= vsl_offset;
vsr_dim1 = *ldvsr;
vsr_offset = 1 + vsr_dim1 * 1;
vsr -= vsr_offset;
--work;
/* Function Body */
if (lsame_(jobvsl, "N")) {
ijobvl = 1;
ilvsl = FALSE_;
} else if (lsame_(jobvsl, "V")) {
ijobvl = 2;
ilvsl = TRUE_;
} else {
ijobvl = -1;
ilvsl = FALSE_;
}
if (lsame_(jobvsr, "N")) {
ijobvr = 1;
ilvsr = FALSE_;
} else if (lsame_(jobvsr, "V")) {
ijobvr = 2;
ilvsr = TRUE_;
} else {
ijobvr = -1;
ilvsr = FALSE_;
}
/* Test the input arguments
Computing MAX */
i__1 = *n << 2;
lwkmin = max(i__1,1);
lwkopt = lwkmin;
work[1] = (doublereal) lwkopt;
lquery = *lwork == -1;
*info = 0;
if (ijobvl <= 0) {
*info = -1;
} else if (ijobvr <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
} else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
*info = -12;
} else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
*info = -14;
} else if (*lwork < lwkmin && ! lquery) {
*info = -16;
}
if (*info == 0) {
nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, n, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb2 = ilaenv_(&c__1, "DORMQR", " ", n, n, n, &c_n1, (ftnlen)6, (
ftnlen)1);
nb3 = ilaenv_(&c__1, "DORGQR", " ", n, n, n, &c_n1, (ftnlen)6, (
ftnlen)1);
/* Computing MAX */
i__1 = max(nb1,nb2);
nb = max(i__1,nb3);
lopt = (*n << 1) + *n * (nb + 1);
work[1] = (doublereal) lopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEGS ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("E") * dlamch_("B");
safmin = dlamch_("S");
smlnum = *n * safmin / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]);
ilascl = FALSE_;
if (anrm > 0. && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
dlascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &a[a_offset], lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]);
ilbscl = FALSE_;
if (bnrm > 0. && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
dlascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
/* Permute the matrix to make it more nearly triangular
Workspace layout: (2*N words -- "work..." not actually used)
left_permutation, right_permutation, work... */
ileft = 1;
iright = *n + 1;
iwork = iright + *n;
dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
ileft], &work[iright], &work[iwork], &iinfo);
if (iinfo != 0) {
*info = *n + 1;
goto L10;
}
/* Reduce B to triangular form, and initialize VSL and/or VSR
Workspace layout: ("work..." must have at least N words)
left_permutation, right_permutation, tau, work... */
irows = ihi + 1 - ilo;
icols = *n + 1 - ilo;
itau = iwork;
iwork = itau + irows;
i__1 = *lwork + 1 - iwork;
dgeqrf_(&irows, &icols, &b_ref(ilo, ilo), ldb, &work[itau], &work[iwork],
&i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 2;
goto L10;
}
i__1 = *lwork + 1 - iwork;
dormqr_("L", "T", &irows, &icols, &irows, &b_ref(ilo, ilo), ldb, &work[
itau], &a_ref(ilo, ilo), lda, &work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 3;
goto L10;
}
if (ilvsl) {
dlaset_("Full", n, n, &c_b36, &c_b37, &vsl[vsl_offset], ldvsl);
i__1 = irows - 1;
i__2 = irows - 1;
dlacpy_("L", &i__1, &i__2, &b_ref(ilo + 1, ilo), ldb, &vsl_ref(ilo +
1, ilo), ldvsl);
i__1 = *lwork + 1 - iwork;
dorgqr_(&irows, &irows, &irows, &vsl_ref(ilo, ilo), ldvsl, &work[itau]
, &work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 4;
goto L10;
}
}
if (ilvsr) {
dlaset_("Full", n, n, &c_b36, &c_b37, &vsr[vsr_offset], ldvsr);
}
/* Reduce to generalized Hessenberg form */
dgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &iinfo);
if (iinfo != 0) {
*info = *n + 5;
goto L10;
}
/* Perform QZ algorithm, computing Schur vectors if desired
Workspace layout: ("work..." must have at least 1 word)
left_permutation, right_permutation, work... */
iwork = itau;
i__1 = *lwork + 1 - iwork;
dhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset]
, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
if (iinfo > 0 && iinfo <= *n) {
*info = iinfo;
} else if (iinfo > *n && iinfo <= *n << 1) {
*info = iinfo - *n;
} else {
*info = *n + 6;
}
goto L10;
}
/* Apply permutation to VSL and VSR */
if (ilvsl) {
dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[
vsl_offset], ldvsl, &iinfo);
if (iinfo != 0) {
*info = *n + 7;
goto L10;
}
}
if (ilvsr) {
dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[
vsr_offset], ldvsr, &iinfo);
if (iinfo != 0) {
*info = *n + 8;
goto L10;
}
}
/* Undo scaling */
if (ilascl) {
dlascl_("H", &c_n1, &c_n1, &anrmto, &anrm, n, n, &a[a_offset], lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
dlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
dlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
if (ilbscl) {
dlascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
dlascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
L10:
work[1] = (doublereal) lwkopt;
return 0;
/* End of DGEGS */
} /* dgegs_ */