/* Subroutine */ int dsyequb_(char *uplo, integer *n, doublereal *a, integer *
lda, doublereal *s, doublereal *scond, doublereal *amax, doublereal *
work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal), log(doublereal), pow_di(doublereal *, integer *);
/* Local variables */
doublereal d__;
integer i__, j;
doublereal t, u, c0, c1, c2, si;
logical up;
doublereal avg, std, tol, base;
integer iter;
doublereal smin, smax, scale;
extern logical lsame_(char *, char *);
doublereal sumsq;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal bignum;
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *);
doublereal smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSYEQUB computes row and column scalings intended to equilibrate a */
/* symmetric matrix A and reduce its condition number */
/* (with respect to the two-norm). S contains the scale factors, */
/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
/* choice of S puts the condition number of B within a factor N of the */
/* smallest possible condition number over all possible diagonal */
/* scalings. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The N-by-N symmetric matrix whose scaling */
/* factors are to be computed. Only the diagonal elements of A */
/* are referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* S (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, S contains the scale factors for A. */
/* SCOND (output) DOUBLE PRECISION */
/* If INFO = 0, S contains the ratio of the smallest S(i) to */
/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
/* large nor too small, it is not worth scaling by S. */
/* AMAX (output) DOUBLE PRECISION */
/* Absolute value of largest matrix element. If AMAX is very */
/* close to overflow or very close to underflow, the matrix */
/* should be scaled. */
/* 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 is nonpositive. */
/* Further Details */
/* ======= ======= */
/* Reference: Livne, O.E. and Golub, G.H., "Scaling by Binormalization", */
/* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. */
/* DOI 10.1023/B:NUMA.0000016606.32820.69 */
/* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--s;
--work;
/* Function Body */
*info = 0;
if (! (lsame_(uplo, "U") || lsame_(uplo, "L"))) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYEQUB", &i__1);
return 0;
}
up = lsame_(uplo, "U");
*amax = 0.;
/* Quick return if possible. */
if (*n == 0) {
*scond = 1.;
return 0;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
s[i__] = 0.;
}
*amax = 0.;
if (up) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = s[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
s[i__] = max(d__2,d__3);
/* Computing MAX */
d__2 = s[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
s[j] = max(d__2,d__3);
/* Computing MAX */
d__2 = *amax, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
*amax = max(d__2,d__3);
}
/* Computing MAX */
d__2 = s[j], d__3 = (d__1 = a[j + j * a_dim1], abs(d__1));
s[j] = max(d__2,d__3);
/* Computing MAX */
d__2 = *amax, d__3 = (d__1 = a[j + j * a_dim1], abs(d__1));
*amax = max(d__2,d__3);
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
d__2 = s[j], d__3 = (d__1 = a[j + j * a_dim1], abs(d__1));
s[j] = max(d__2,d__3);
/* Computing MAX */
d__2 = *amax, d__3 = (d__1 = a[j + j * a_dim1], abs(d__1));
*amax = max(d__2,d__3);
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = s[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
s[i__] = max(d__2,d__3);
/* Computing MAX */
d__2 = s[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
s[j] = max(d__2,d__3);
/* Computing MAX */
d__2 = *amax, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
*amax = max(d__2,d__3);
}
}
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
s[j] = 1. / s[j];
}
tol = 1. / sqrt(*n * 2.);
for (iter = 1; iter <= 100; ++iter) {
scale = 0.;
sumsq = 0.;
/* BETA = |A|S */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
}
if (up) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
t = (d__1 = a[i__ + j * a_dim1], abs(d__1));
work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[
j];
work[j] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[
i__];
}
work[j] += (d__1 = a[j + j * a_dim1], abs(d__1)) * s[j];
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
work[j] += (d__1 = a[j + j * a_dim1], abs(d__1)) * s[j];
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
t = (d__1 = a[i__ + j * a_dim1], abs(d__1));
work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[
j];
work[j] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[
i__];
}
}
}
/* avg = s^T beta / n */
avg = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
avg += s[i__] * work[i__];
}
avg /= *n;
std = 0.;
i__1 = *n * 3;
for (i__ = (*n << 1) + 1; i__ <= i__1; ++i__) {
work[i__] = s[i__ - (*n << 1)] * work[i__ - (*n << 1)] - avg;
}
dlassq_(n, &work[(*n << 1) + 1], &c__1, &scale, &sumsq);
std = scale * sqrt(sumsq / *n);
if (std < tol * avg) {
goto L999;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
t = (d__1 = a[i__ + i__ * a_dim1], abs(d__1));
si = s[i__];
c2 = (*n - 1) * t;
c1 = (*n - 2) * (work[i__] - t * si);
c0 = -(t * si) * si + work[i__] * 2 * si - *n * avg;
d__ = c1 * c1 - c0 * 4 * c2;
if (d__ <= 0.) {
*info = -1;
return 0;
}
si = c0 * -2 / (c1 + sqrt(d__));
d__ = si - s[i__];
u = 0.;
if (up) {
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
t = (d__1 = a[j + i__ * a_dim1], abs(d__1));
u += s[j] * t;
work[j] += d__ * t;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
t = (d__1 = a[i__ + j * a_dim1], abs(d__1));
u += s[j] * t;
work[j] += d__ * t;
}
} else {
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
t = (d__1 = a[i__ + j * a_dim1], abs(d__1));
u += s[j] * t;
work[j] += d__ * t;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
t = (d__1 = a[j + i__ * a_dim1], abs(d__1));
u += s[j] * t;
work[j] += d__ * t;
}
}
avg += (u + work[i__]) * d__ / *n;
s[i__] = si;
}
}
L999:
smlnum = dlamch_("SAFEMIN");
bignum = 1. / smlnum;
smin = bignum;
smax = 0.;
t = 1. / sqrt(avg);
base = dlamch_("B");
u = 1. / log(base);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = (integer) (u * log(s[i__] * t));
s[i__] = pow_di(&base, &i__2);
/* Computing MIN */
d__1 = smin, d__2 = s[i__];
smin = min(d__1,d__2);
/* Computing MAX */
d__1 = smax, d__2 = s[i__];
smax = max(d__1,d__2);
}
*scond = max(smin,smlnum) / min(smax,bignum);
return 0;
} /* dsyequb_ */
doublereal dlantp_(char *norm, char *uplo, char *diag, integer *n, doublereal
*ap, doublereal *work)
{
/* System generated locals */
integer i__1, i__2;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k;
doublereal sum, scale;
logical udiag;
extern logical lsame_(char *, char *);
doublereal value;
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLANTP returns the value of the one norm, or the Frobenius norm, or */
/* the infinity norm, or the element of largest absolute value of a */
/* triangular matrix A, supplied in packed form. */
/* Description */
/* =========== */
/* DLANTP returns the value */
/* DLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum), */
/* normI denotes the infinity norm of a matrix (maximum row sum) and */
/* normF denotes the Frobenius norm of a matrix (square root of sum of */
/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in DLANTP as described */
/* above. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, DLANTP is */
/* set to zero. */
/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* The upper or lower triangular matrix A, packed columnwise in */
/* a linear array. The j-th column of A is stored in the array */
/* AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* Note that when DIAG = 'U', the elements of the array AP */
/* corresponding to the diagonal elements of the matrix A are */
/* not referenced, but are assumed to be one. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--work;
--ap;
/* Function Body */
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
k = 1;
if (lsame_(diag, "U")) {
value = 1.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j - 2;
for (i__ = k; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1));
value = max(d__2,d__3);
/* L10: */
}
k += j;
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = k + *n - j;
for (i__ = k + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1));
value = max(d__2,d__3);
/* L30: */
}
k = k + *n - j + 1;
/* L40: */
}
}
} else {
value = 0.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j - 1;
for (i__ = k; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1));
value = max(d__2,d__3);
/* L50: */
}
k += j;
/* L60: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = k + *n - j;
for (i__ = k; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1));
value = max(d__2,d__3);
/* L70: */
}
k = k + *n - j + 1;
/* L80: */
}
}
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.;
k = 1;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.;
i__2 = k + j - 2;
for (i__ = k; i__ <= i__2; ++i__) {
sum += (d__1 = ap[i__], abs(d__1));
/* L90: */
}
} else {
sum = 0.;
i__2 = k + j - 1;
for (i__ = k; i__ <= i__2; ++i__) {
sum += (d__1 = ap[i__], abs(d__1));
/* L100: */
}
}
k += j;
value = max(value,sum);
/* L110: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.;
i__2 = k + *n - j;
for (i__ = k + 1; i__ <= i__2; ++i__) {
sum += (d__1 = ap[i__], abs(d__1));
/* L120: */
}
} else {
sum = 0.;
i__2 = k + *n - j;
for (i__ = k; i__ <= i__2; ++i__) {
sum += (d__1 = ap[i__], abs(d__1));
/* L130: */
}
}
k = k + *n - j + 1;
value = max(value,sum);
/* L140: */
}
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
k = 1;
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.;
/* L150: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (d__1 = ap[k], abs(d__1));
++k;
/* L160: */
}
++k;
/* L170: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L180: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (d__1 = ap[k], abs(d__1));
++k;
/* L190: */
}
/* L200: */
}
}
} else {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.;
/* L210: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
++k;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work[i__] += (d__1 = ap[k], abs(d__1));
++k;
/* L220: */
}
/* L230: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L240: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
work[i__] += (d__1 = ap[k], abs(d__1));
++k;
/* L250: */
}
/* L260: */
}
}
}
value = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L270: */
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
scale = 1.;
sum = (doublereal) (*n);
k = 2;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
dlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k += j;
/* L280: */
}
} else {
scale = 0.;
sum = 1.;
k = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dlassq_(&j, &ap[k], &c__1, &scale, &sum);
k += j;
/* L290: */
}
}
} else {
if (lsame_(diag, "U")) {
scale = 1.;
sum = (doublereal) (*n);
k = 2;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
dlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k = k + *n - j + 1;
/* L300: */
}
} else {
scale = 0.;
sum = 1.;
k = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
dlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k = k + *n - j + 1;
/* L310: */
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANTP */
} /* dlantp_ */
/*< >*/
/* Subroutine */ int dlatdf_(integer *ijob, integer *n, doublereal *z__,
integer *ldz, doublereal *rhs, doublereal *rdsum, doublereal *rdscal,
integer *ipiv, integer *jpiv)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k;
doublereal bm, bp, xm[8], xp[8];
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
integer info;
doublereal temp, work[32];
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern doublereal dasum_(integer *, doublereal *, integer *);
doublereal pmone;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
doublereal sminu;
integer iwork[8];
doublereal splus;
extern /* Subroutine */ int dgesc2_(integer *, doublereal *, integer *,
doublereal *, integer *, integer *, doublereal *), dgecon_(char *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, ftnlen), dlassq_(integer *,
doublereal *, integer *, doublereal *, doublereal *), dlaswp_(
integer *, doublereal *, integer *, integer *, integer *, integer
*, integer *);
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/*< INTEGER IJOB, LDZ, N >*/
/*< DOUBLE PRECISION RDSCAL, RDSUM >*/
/* .. */
/* .. Array Arguments .. */
/*< INTEGER IPIV( * ), JPIV( * ) >*/
/*< DOUBLE PRECISION RHS( * ), Z( LDZ, * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* DLATDF uses the LU factorization of the n-by-n matrix Z computed by */
/* DGETC2 and computes a contribution to the reciprocal Dif-estimate */
/* by solving Z * x = b for x, and choosing the r.h.s. b such that */
/* the norm of x is as large as possible. On entry RHS = b holds the */
/* contribution from earlier solved sub-systems, and on return RHS = x. */
/* The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q, */
/* where P and Q are permutation matrices. L is lower triangular with */
/* unit diagonal elements and U is upper triangular. */
/* Arguments */
/* ========= */
/* IJOB (input) INTEGER */
/* IJOB = 2: First compute an approximative null-vector e */
/* of Z using DGECON, e is normalized and solve for */
/* Zx = +-e - f with the sign giving the greater value */
/* of 2-norm(x). About 5 times as expensive as Default. */
/* IJOB .ne. 2: Local look ahead strategy where all entries of */
/* the r.h.s. b is choosen as either +1 or -1 (Default). */
/* N (input) INTEGER */
/* The number of columns of the matrix Z. */
/* Z (input) DOUBLE PRECISION array, dimension (LDZ, N) */
/* On entry, the LU part of the factorization of the n-by-n */
/* matrix Z computed by DGETC2: Z = P * L * U * Q */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDA >= max(1, N). */
/* RHS (input/output) DOUBLE PRECISION array, dimension N. */
/* On entry, RHS contains contributions from other subsystems. */
/* On exit, RHS contains the solution of the subsystem with */
/* entries acoording to the value of IJOB (see above). */
/* RDSUM (input/output) DOUBLE PRECISION */
/* On entry, the sum of squares of computed contributions to */
/* the Dif-estimate under computation by DTGSYL, where the */
/* scaling factor RDSCAL (see below) has been factored out. */
/* On exit, the corresponding sum of squares updated with the */
/* contributions from the current sub-system. */
/* If TRANS = 'T' RDSUM is not touched. */
/* NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL. */
/* RDSCAL (input/output) DOUBLE PRECISION */
/* On entry, scaling factor used to prevent overflow in RDSUM. */
/* On exit, RDSCAL is updated w.r.t. the current contributions */
/* in RDSUM. */
/* If TRANS = 'T', RDSCAL is not touched. */
/* NOTE: RDSCAL only makes sense when DTGSY2 is called by */
/* DTGSYL. */
/* IPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= i <= N, row i of the */
/* matrix has been interchanged with row IPIV(i). */
/* JPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= j <= N, column j of the */
/* matrix has been interchanged with column JPIV(j). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* This routine is a further developed implementation of algorithm */
/* BSOLVE in [1] using complete pivoting in the LU factorization. */
/* [1] Bo Kagstrom and Lars Westin, */
/* Generalized Schur Methods with Condition Estimators for */
/* Solving the Generalized Sylvester Equation, IEEE Transactions */
/* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. */
/* [2] Peter Poromaa, */
/* On Efficient and Robust Estimators for the Separation */
/* between two Regular Matrix Pairs with Applications in */
/* Condition Estimation. Report IMINF-95.05, Departement of */
/* Computing Science, Umea University, S-901 87 Umea, Sweden, 1995. */
/* ===================================================================== */
/* .. Parameters .. */
/*< INTEGER MAXDIM >*/
/*< PARAMETER ( MAXDIM = 8 ) >*/
/*< DOUBLE PRECISION ZERO, ONE >*/
/*< PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< INTEGER I, INFO, J, K >*/
/*< DOUBLE PRECISION BM, BP, PMONE, SMINU, SPLUS, TEMP >*/
/* .. */
/* .. Local Arrays .. */
/*< INTEGER IWORK( MAXDIM ) >*/
/*< DOUBLE PRECISION WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM ) >*/
/* .. */
/* .. External Subroutines .. */
/*< >*/
/* .. */
/* .. External Functions .. */
/*< DOUBLE PRECISION DASUM, DDOT >*/
/*< EXTERNAL DASUM, DDOT >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC ABS, SQRT >*/
/* .. */
/* .. Executable Statements .. */
/*< IF( IJOB.NE.2 ) THEN >*/
/* Parameter adjustments */
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--rhs;
--ipiv;
--jpiv;
/* Function Body */
if (*ijob != 2) {
/* Apply permutations IPIV to RHS */
/*< CALL DLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 ) >*/
i__1 = *n - 1;
dlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1);
/* Solve for L-part choosing RHS either to +1 or -1. */
/*< PMONE = -ONE >*/
pmone = -1.;
/*< DO 10 J = 1, N - 1 >*/
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/*< BP = RHS( J ) + ONE >*/
bp = rhs[j] + 1.;
/*< BM = RHS( J ) - ONE >*/
bm = rhs[j] - 1.;
/*< SPLUS = ONE >*/
splus = 1.;
/* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and */
/* SMIN computed more efficiently than in BSOLVE [1]. */
/*< SPLUS = SPLUS + DDOT( N-J, Z( J+1, J ), 1, Z( J+1, J ), 1 ) >*/
i__2 = *n - j;
splus += ddot_(&i__2, &z__[j + 1 + j * z_dim1], &c__1, &z__[j + 1
+ j * z_dim1], &c__1);
/*< SMINU = DDOT( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 ) >*/
i__2 = *n - j;
sminu = ddot_(&i__2, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
&c__1);
/*< SPLUS = SPLUS*RHS( J ) >*/
splus *= rhs[j];
/*< IF( SPLUS.GT.SMINU ) THEN >*/
if (splus > sminu) {
/*< RHS( J ) = BP >*/
rhs[j] = bp;
/*< ELSE IF( SMINU.GT.SPLUS ) THEN >*/
} else if (sminu > splus) {
/*< RHS( J ) = BM >*/
rhs[j] = bm;
/*< ELSE >*/
} else {
/* In this case the updating sums are equal and we can */
/* choose RHS(J) +1 or -1. The first time this happens */
/* we choose -1, thereafter +1. This is a simple way to */
/* get good estimates of matrices like Byers well-known */
/* example (see [1]). (Not done in BSOLVE.) */
/*< RHS( J ) = RHS( J ) + PMONE >*/
rhs[j] += pmone;
/*< PMONE = ONE >*/
pmone = 1.;
/*< END IF >*/
}
/* Compute the remaining r.h.s. */
/*< TEMP = -RHS( J ) >*/
temp = -rhs[j];
/*< CALL DAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 ) >*/
i__2 = *n - j;
daxpy_(&i__2, &temp, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
&c__1);
/*< 10 CONTINUE >*/
/* L10: */
}
/* Solve for U-part, look-ahead for RHS(N) = +-1. This is not done */
/* in BSOLVE and will hopefully give us a better estimate because */
/* any ill-conditioning of the original matrix is transfered to U */
/* and not to L. U(N, N) is an approximation to sigma_min(LU). */
/*< CALL DCOPY( N-1, RHS, 1, XP, 1 ) >*/
i__1 = *n - 1;
dcopy_(&i__1, &rhs[1], &c__1, xp, &c__1);
/*< XP( N ) = RHS( N ) + ONE >*/
xp[*n - 1] = rhs[*n] + 1.;
/*< RHS( N ) = RHS( N ) - ONE >*/
rhs[*n] += -1.;
/*< SPLUS = ZERO >*/
splus = 0.;
/*< SMINU = ZERO >*/
sminu = 0.;
/*< DO 30 I = N, 1, -1 >*/
for (i__ = *n; i__ >= 1; --i__) {
/*< TEMP = ONE / Z( I, I ) >*/
temp = 1. / z__[i__ + i__ * z_dim1];
/*< XP( I ) = XP( I )*TEMP >*/
xp[i__ - 1] *= temp;
/*< RHS( I ) = RHS( I )*TEMP >*/
rhs[i__] *= temp;
/*< DO 20 K = I + 1, N >*/
i__1 = *n;
for (k = i__ + 1; k <= i__1; ++k) {
/*< XP( I ) = XP( I ) - XP( K )*( Z( I, K )*TEMP ) >*/
xp[i__ - 1] -= xp[k - 1] * (z__[i__ + k * z_dim1] * temp);
/*< RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP ) >*/
rhs[i__] -= rhs[k] * (z__[i__ + k * z_dim1] * temp);
/*< 20 CONTINUE >*/
/* L20: */
}
/*< SPLUS = SPLUS + ABS( XP( I ) ) >*/
splus += (d__1 = xp[i__ - 1], abs(d__1));
/*< SMINU = SMINU + ABS( RHS( I ) ) >*/
sminu += (d__1 = rhs[i__], abs(d__1));
/*< 30 CONTINUE >*/
/* L30: */
}
/*< >*/
if (splus > sminu) {
dcopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Apply the permutations JPIV to the computed solution (RHS) */
/*< CALL DLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 ) >*/
i__1 = *n - 1;
dlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1);
/* Compute the sum of squares */
/*< CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM ) >*/
dlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
/*< ELSE >*/
} else {
/* IJOB = 2, Compute approximate nullvector XM of Z */
/*< CALL DGECON( 'I', N, Z, LDZ, ONE, TEMP, WORK, IWORK, INFO ) >*/
dgecon_("I", n, &z__[z_offset], ldz, &c_b23, &temp, work, iwork, &
info, (ftnlen)1);
/*< CALL DCOPY( N, WORK( N+1 ), 1, XM, 1 ) >*/
dcopy_(n, &work[*n], &c__1, xm, &c__1);
/* Compute RHS */
/*< CALL DLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 ) >*/
i__1 = *n - 1;
dlaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1);
/*< TEMP = ONE / SQRT( DDOT( N, XM, 1, XM, 1 ) ) >*/
temp = 1. / sqrt(ddot_(n, xm, &c__1, xm, &c__1));
/*< CALL DSCAL( N, TEMP, XM, 1 ) >*/
dscal_(n, &temp, xm, &c__1);
/*< CALL DCOPY( N, XM, 1, XP, 1 ) >*/
dcopy_(n, xm, &c__1, xp, &c__1);
/*< CALL DAXPY( N, ONE, RHS, 1, XP, 1 ) >*/
daxpy_(n, &c_b23, &rhs[1], &c__1, xp, &c__1);
/*< CALL DAXPY( N, -ONE, XM, 1, RHS, 1 ) >*/
daxpy_(n, &c_b37, xm, &c__1, &rhs[1], &c__1);
/*< CALL DGESC2( N, Z, LDZ, RHS, IPIV, JPIV, TEMP ) >*/
dgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &temp);
/*< CALL DGESC2( N, Z, LDZ, XP, IPIV, JPIV, TEMP ) >*/
dgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &temp);
/*< >*/
if (dasum_(n, xp, &c__1) > dasum_(n, &rhs[1], &c__1)) {
dcopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Compute the sum of squares */
/*< CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM ) >*/
dlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
/*< END IF >*/
}
/*< RETURN >*/
return 0;
/* End of DLATDF */
/*< END >*/
} /* dlatdf_ */
doublereal dlangt_(char *norm, integer *n, doublereal *dl, doublereal *d__,
doublereal *du)
{
/* System generated locals */
integer i__1;
doublereal ret_val, d__1, d__2, d__3, d__4, d__5;
/* Local variables */
integer i__;
doublereal sum, scale;
doublereal anorm;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DLANGT returns the value of the one norm, or the Frobenius norm, or */
/* the infinity norm, or the element of largest absolute value of a */
/* real tridiagonal matrix A. */
/* Description */
/* =========== */
/* DLANGT returns the value */
/* DLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum), */
/* normI denotes the infinity norm of a matrix (maximum row sum) and */
/* normF denotes the Frobenius norm of a matrix (square root of sum of */
/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in DLANGT as described */
/* above. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, DLANGT is */
/* set to zero. */
/* DL (input) DOUBLE PRECISION array, dimension (N-1) */
/* The (n-1) sub-diagonal elements of A. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The diagonal elements of A. */
/* DU (input) DOUBLE PRECISION array, dimension (N-1) */
/* The (n-1) super-diagonal elements of A. */
/* ===================================================================== */
/* Parameter adjustments */
--du;
--d__;
--dl;
/* Function Body */
if (*n <= 0) {
anorm = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
anorm = (d__1 = d__[*n], abs(d__1));
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = dl[i__], abs(d__1));
anorm = max(d__2,d__3);
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = d__[i__], abs(d__1));
anorm = max(d__2,d__3);
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = du[i__], abs(d__1));
anorm = max(d__2,d__3);
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
if (*n == 1) {
anorm = abs(d__[1]);
} else {
/* Computing MAX */
d__3 = abs(d__[1]) + abs(dl[1]), d__4 = (d__1 = d__[*n], abs(d__1)
) + (d__2 = du[*n - 1], abs(d__2));
anorm = max(d__3,d__4);
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
d__4 = anorm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 =
dl[i__], abs(d__2)) + (d__3 = du[i__ - 1], abs(d__3));
anorm = max(d__4,d__5);
}
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
if (*n == 1) {
anorm = abs(d__[1]);
} else {
/* Computing MAX */
d__3 = abs(d__[1]) + abs(du[1]), d__4 = (d__1 = d__[*n], abs(d__1)
) + (d__2 = dl[*n - 1], abs(d__2));
anorm = max(d__3,d__4);
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
d__4 = anorm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 =
du[i__], abs(d__2)) + (d__3 = dl[i__ - 1], abs(d__3));
anorm = max(d__4,d__5);
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
dlassq_(n, &d__[1], &c__1, &scale, &sum);
if (*n > 1) {
i__1 = *n - 1;
dlassq_(&i__1, &dl[1], &c__1, &scale, &sum);
i__1 = *n - 1;
dlassq_(&i__1, &du[1], &c__1, &scale, &sum);
}
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of DLANGT */
} /* dlangt_ */
double dlansy_(char *norm, char *uplo, int *n, double *a, int
*lda, double *work)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2;
double ret_val, d__1, d__2, d__3;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int i__, j;
double sum, absa, scale;
extern int lsame_(char *, char *);
double value;
extern int dlassq_(int *, double *, int *,
double *, double *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLANSY returns the value of the one norm, or the Frobenius norm, or */
/* the infinity norm, or the element of largest absolute value of a */
/* float symmetric matrix A. */
/* Description */
/* =========== */
/* DLANSY returns the value */
/* DLANSY = ( MAX(ABS(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum), */
/* normI denotes the infinity norm of a matrix (maximum row sum) and */
/* normF denotes the Frobenius norm of a matrix (square root of sum of */
/* squares). Note that MAX(ABS(A(i,j))) is not a consistent matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in DLANSY as described */
/* above. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is to be referenced. */
/* = 'U': Upper triangular part of A is referenced */
/* = 'L': Lower triangular part of A is referenced */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, DLANSY is */
/* set to zero. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The symmetric matrix A. If UPLO = 'U', the leading n by n */
/* upper triangular part of A contains the upper triangular part */
/* of the matrix A, and the strictly lower triangular part of A */
/* is not referenced. If UPLO = 'L', the leading n by n lower */
/* triangular part of A contains the lower triangular part of */
/* the matrix A, and the strictly upper triangular part of A is */
/* not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(N,1). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
/* WORK is not referenced. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
/* Function Body */
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find MAX(ABS(A(i,j))). */
value = 0.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], ABS(
d__1));
value = MAX(d__2,d__3);
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], ABS(
d__1));
value = MAX(d__2,d__3);
/* L30: */
}
/* L40: */
}
}
} else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
/* Find normI(A) ( = norm1(A), since A is symmetric). */
value = 0.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
absa = (d__1 = a[i__ + j * a_dim1], ABS(d__1));
sum += absa;
work[i__] += absa;
/* L50: */
}
work[j] = sum + (d__1 = a[j + j * a_dim1], ABS(d__1));
/* L60: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = MAX(d__1,d__2);
/* L70: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L80: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = work[j] + (d__1 = a[j + j * a_dim1], ABS(d__1));
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
absa = (d__1 = a[i__ + j * a_dim1], ABS(d__1));
sum += absa;
work[i__] += absa;
/* L90: */
}
value = MAX(value,sum);
/* L100: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L110: */
}
} else {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
dlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum);
/* L120: */
}
}
sum *= 2;
i__1 = *lda + 1;
dlassq_(n, &a[a_offset], &i__1, &scale, &sum);
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANSY */
} /* dlansy_ */
doublereal dlantr_(char *norm, char *uplo, char *diag, integer *m, integer *n,
doublereal *a, integer *lda, doublereal *work, ftnlen norm_len,
ftnlen uplo_len, ftnlen diag_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__, j;
static doublereal sum, scale;
static logical udiag;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static doublereal value;
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLANTR returns the value of the one norm, or the Frobenius norm, or */
/* the infinity norm, or the element of largest absolute value of a */
/* trapezoidal or triangular matrix A. */
/* Description */
/* =========== */
/* DLANTR returns the value */
/* DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum), */
/* normI denotes the infinity norm of a matrix (maximum row sum) and */
/* normF denotes the Frobenius norm of a matrix (square root of sum of */
/* squares). Note that max(abs(A(i,j))) is not a matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in DLANTR as described */
/* above. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower trapezoidal. */
/* = 'U': Upper trapezoidal */
/* = 'L': Lower trapezoidal */
/* Note that A is triangular instead of trapezoidal if M = N. */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A has unit diagonal. */
/* = 'N': Non-unit diagonal */
/* = 'U': Unit diagonal */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0, and if */
/* UPLO = 'U', M <= N. When M = 0, DLANTR is set to zero. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0, and if */
/* UPLO = 'L', N <= M. When N = 0, DLANTR is set to zero. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The trapezoidal matrix A (A is triangular if M = N). */
/* If UPLO = 'U', the leading m by n upper trapezoidal part of */
/* the array A contains the upper trapezoidal matrix, and the */
/* strictly lower triangular part of A is not referenced. */
/* If UPLO = 'L', the leading m by n lower trapezoidal part of */
/* the array A contains the lower trapezoidal matrix, and the */
/* strictly upper triangular part of A is not referenced. Note */
/* that when DIAG = 'U', the diagonal elements of A are not */
/* referenced and are assumed to be one. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(M,1). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), */
/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
/* Function Body */
if (min(*m,*n) == 0) {
value = 0.;
} else if (lsame_(norm, "M", (ftnlen)1, (ftnlen)1)) {
/* Find max(abs(A(i,j))). */
if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
value = 1.;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *m, i__4 = j - 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(
d__1));
value = max(d__2,d__3);
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(
d__1));
value = max(d__2,d__3);
/* L30: */
}
/* L40: */
}
}
} else {
value = 0.;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(*m,j);
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(
d__1));
value = max(d__2,d__3);
/* L50: */
}
/* L60: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(
d__1));
value = max(d__2,d__3);
/* L70: */
}
/* L80: */
}
}
}
} else if (lsame_(norm, "O", (ftnlen)1, (ftnlen)1) || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.;
udiag = lsame_(diag, "U", (ftnlen)1, (ftnlen)1);
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag && j <= *m) {
sum = 1.;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L90: */
}
} else {
sum = 0.;
i__2 = min(*m,j);
for (i__ = 1; i__ <= i__2; ++i__) {
sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L100: */
}
}
value = max(value,sum);
/* L110: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.;
i__2 = *m;
for (i__ = j + 1; i__ <= i__2; ++i__) {
sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L120: */
}
} else {
sum = 0.;
i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) {
sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L130: */
}
}
value = max(value,sum);
/* L140: */
}
}
} else if (lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) {
/* Find normI(A). */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.;
/* L150: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *m, i__4 = j - 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L160: */
}
/* L170: */
}
} else {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L180: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(*m,j);
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L190: */
}
/* L200: */
}
}
} else {
if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.;
/* L210: */
}
i__1 = *m;
for (i__ = *n + 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L220: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L230: */
}
/* L240: */
}
} else {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L250: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) {
work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L260: */
}
/* L270: */
}
}
}
value = 0.;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L280: */
}
} else if (lsame_(norm, "F", (ftnlen)1, (ftnlen)1) || lsame_(norm, "E", (
ftnlen)1, (ftnlen)1)) {
/* Find normF(A). */
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
scale = 1.;
sum = (doublereal) min(*m,*n);
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *m, i__4 = j - 1;
i__2 = min(i__3,i__4);
dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L290: */
}
} else {
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(*m,j);
dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L300: */
}
}
} else {
if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
scale = 1.;
sum = (doublereal) min(*m,*n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m - j;
/* Computing MIN */
i__3 = *m, i__4 = j + 1;
dlassq_(&i__2, &a[min(i__3,i__4) + j * a_dim1], &c__1, &
scale, &sum);
/* L310: */
}
} else {
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m - j + 1;
dlassq_(&i__2, &a[j + j * a_dim1], &c__1, &scale, &sum);
/* L320: */
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANTR */
} /* dlantr_ */
doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer
*lda, doublereal *work)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
DLANGE returns the value of the one norm, or the Frobenius norm, or
the infinity norm, or the element of largest absolute value of a
real matrix A.
Description
===========
DLANGE returns the value
DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
(
( norm1(A), NORM = '1', 'O' or 'o'
(
( normI(A), NORM = 'I' or 'i'
(
( normF(A), NORM = 'F', 'f', 'E' or 'e'
where norm1 denotes the one norm of a matrix (maximum column sum),
normI denotes the infinity norm of a matrix (maximum row sum) and
normF denotes the Frobenius norm of a matrix (square root of sum of
squares). Note that max(abs(A(i,j))) is not a matrix norm.
Arguments
=========
NORM (input) CHARACTER*1
Specifies the value to be returned in DLANGE as described
above.
M (input) INTEGER
The number of rows of the matrix A. M >= 0. When M = 0,
DLANGE is set to zero.
N (input) INTEGER
The number of columns of the matrix A. N >= 0. When N = 0,
DLANGE is set to zero.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
The m by n matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(M,1).
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK),
where LWORK >= M when NORM = 'I'; otherwise, WORK is not
referenced.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__, j;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal value;
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *);
static doublereal sum;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--work;
/* Function Body */
if (min(*m,*n) == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = a_ref(i__, j), abs(d__1));
value = max(d__2,d__3);
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
sum += (d__1 = a_ref(i__, j), abs(d__1));
/* L30: */
}
value = max(value,sum);
/* L40: */
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L50: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (d__1 = a_ref(i__, j), abs(d__1));
/* L60: */
}
/* L70: */
}
value = 0.;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L80: */
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dlassq_(m, &a_ref(1, j), &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANGE */
} /* dlange_ */
doublereal dlangb_(char *norm, integer *n, integer *kl, integer *ku,
doublereal *ab, integer *ldab, doublereal *work)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal ret_val, d__1, d__2, d__3;
/* Local variables */
integer i__, j, k, l;
doublereal sum, scale;
doublereal value;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DLANGB returns the value of the one norm, or the Frobenius norm, or */
/* the infinity norm, or the element of largest absolute value of an */
/* n by n band matrix A, with kl sub-diagonals and ku super-diagonals. */
/* Description */
/* =========== */
/* DLANGB returns the value */
/* DLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum), */
/* normI denotes the infinity norm of a matrix (maximum row sum) and */
/* normF denotes the Frobenius norm of a matrix (square root of sum of */
/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in DLANGB as described */
/* above. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, DLANGB is */
/* set to zero. */
/* KL (input) INTEGER */
/* The number of sub-diagonals of the matrix A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of super-diagonals of the matrix A. KU >= 0. */
/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
/* The band matrix A, stored in rows 1 to KL+KU+1. The j-th */
/* column of A is stored in the j-th column of the array AB as */
/* follows: */
/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* ===================================================================== */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--work;
/* Function Body */
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = *ku + 2 - j;
/* Computing MIN */
i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
i__3 = min(i__4,i__5);
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], abs(d__1))
;
value = max(d__2,d__3);
}
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
/* Computing MAX */
i__3 = *ku + 2 - j;
/* Computing MIN */
i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
i__2 = min(i__4,i__5);
for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1));
}
value = max(value,sum);
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
k = *ku + 1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *ku;
/* Computing MIN */
i__5 = *n, i__6 = j + *kl;
i__4 = min(i__5,i__6);
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
work[i__] += (d__1 = ab[k + i__ + j * ab_dim1], abs(d__1));
}
}
value = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__4 = 1, i__2 = j - *ku;
l = max(i__4,i__2);
k = *ku + 1 - j + l;
/* Computing MIN */
i__2 = *n, i__3 = j + *kl;
i__4 = min(i__2,i__3) - l + 1;
dlassq_(&i__4, &ab[k + j * ab_dim1], &c__1, &scale, &sum);
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANGB */
} /* dlangb_ */
/*< >*/
/* Subroutine */ int dtgsen_(integer *ijob, logical *wantq, logical *wantz,
logical *select, integer *n, doublereal *a, integer *lda, doublereal *
b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
beta, doublereal *q, integer *ldq, doublereal *z__, integer *ldz,
integer *m, doublereal *pl, doublereal *pr, doublereal *dif,
doublereal *work, integer *lwork, integer *iwork, integer *liwork,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
integer i__, k, n1, n2, kk, ks, mn2, ijb;
doublereal eps;
integer kase;
logical pair;
integer ierr;
doublereal dsum;
logical swap;
extern /* Subroutine */ int dlag2_(doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *);
logical wantd;
integer lwmin;
logical wantp, wantd1, wantd2;
extern doublereal dlamch_(char *, ftnlen);
doublereal dscale;
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
doublereal rdscal;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen),
xerbla_(char *, integer *, ftnlen), dtgexc_(logical *, logical *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, integer *, integer *), dlassq_(integer *,
doublereal *, integer *, doublereal *, doublereal *);
integer liwmin;
extern /* Subroutine */ int dtgsyl_(char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *, integer *, ftnlen);
doublereal smlnum;
logical lquery;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/*< LOGICAL WANTQ, WANTZ >*/
/*< >*/
/*< DOUBLE PRECISION PL, PR >*/
/* .. */
/* .. Array Arguments .. */
/*< LOGICAL SELECT( * ) >*/
/*< INTEGER IWORK( * ) >*/
/*< >*/
/* .. */
/* Purpose */
/* ======= */
/* DTGSEN reorders the generalized real Schur decomposition of a real */
/* matrix pair (A, B) (in terms of an orthonormal equivalence trans- */
/* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues */
/* appears in the leading diagonal blocks of the upper quasi-triangular */
/* matrix A and the upper triangular B. The leading columns of Q and */
/* Z form orthonormal bases of the corresponding left and right eigen- */
/* spaces (deflating subspaces). (A, B) must be in generalized real */
/* Schur canonical form (as returned by DGGES), i.e. A is block upper */
/* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper */
/* triangular. */
/* DTGSEN also computes the generalized eigenvalues */
/* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j) */
/* of the reordered matrix pair (A, B). */
/* Optionally, DTGSEN computes the estimates of reciprocal condition */
/* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), */
/* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) */
/* between the matrix pairs (A11, B11) and (A22,B22) that correspond to */
/* the selected cluster and the eigenvalues outside the cluster, resp., */
/* and norms of "projections" onto left and right eigenspaces w.r.t. */
/* the selected cluster in the (1,1)-block. */
/* Arguments */
/* ========= */
/* IJOB (input) INTEGER */
/* Specifies whether condition numbers are required for the */
/* cluster of eigenvalues (PL and PR) or the deflating subspaces */
/* (Difu and Difl): */
/* =0: Only reorder w.r.t. SELECT. No extras. */
/* =1: Reciprocal of norms of "projections" onto left and right */
/* eigenspaces w.r.t. the selected cluster (PL and PR). */
/* =2: Upper bounds on Difu and Difl. F-norm-based estimate */
/* (DIF(1:2)). */
/* =3: Estimate of Difu and Difl. 1-norm-based estimate */
/* (DIF(1:2)). */
/* About 5 times as expensive as IJOB = 2. */
/* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic */
/* version to get it all. */
/* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) */
/* WANTQ (input) LOGICAL */
/* .TRUE. : update the left transformation matrix Q; */
/* .FALSE.: do not update Q. */
/* WANTZ (input) LOGICAL */
/* .TRUE. : update the right transformation matrix Z; */
/* .FALSE.: do not update Z. */
/* SELECT (input) LOGICAL array, dimension (N) */
/* SELECT specifies the eigenvalues in the selected cluster. */
/* To select a real 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 matrices A and B. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension(LDA,N) */
/* On entry, the upper quasi-triangular matrix A, with (A, B) in */
/* generalized real Schur canonical form. */
/* On exit, A is overwritten by the reordered matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) DOUBLE PRECISION array, dimension(LDB,N) */
/* On entry, the upper triangular matrix B, with (A, B) in */
/* generalized real Schur canonical form. */
/* On exit, B is overwritten by the reordered matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array 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 */
/* and BETA(j),j=1,...,N are the diagonals of the complex Schur */
/* form (S,T) that would result if the 2-by-2 diagonal blocks of */
/* the real generalized Schur form of (A,B) were further reduced */
/* to triangular form using 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. */
/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
/* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. */
/* On exit, Q has been postmultiplied by the left orthogonal */
/* transformation matrix which reorder (A, B); The leading M */
/* columns of Q form orthonormal bases for the specified pair of */
/* left eigenspaces (deflating subspaces). */
/* If WANTQ = .FALSE., Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= 1; */
/* and if WANTQ = .TRUE., LDQ >= N. */
/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
/* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. */
/* On exit, Z has been postmultiplied by the left orthogonal */
/* transformation matrix which reorder (A, B); The leading M */
/* columns of Z form orthonormal bases for the specified pair of */
/* left eigenspaces (deflating subspaces). */
/* If WANTZ = .FALSE., Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1; */
/* If WANTZ = .TRUE., LDZ >= N. */
/* M (output) INTEGER */
/* The dimension of the specified pair of left and right eigen- */
/* spaces (deflating subspaces). 0 <= M <= N. */
/* PL, PR (output) DOUBLE PRECISION */
/* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the */
/* reciprocal of the norm of "projections" onto left and right */
/* eigenspaces with respect to the selected cluster. */
/* 0 < PL, PR <= 1. */
/* If M = 0 or M = N, PL = PR = 1. */
/* If IJOB = 0, 2 or 3, PL and PR are not referenced. */
/* DIF (output) DOUBLE PRECISION array, dimension (2). */
/* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. */
/* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on */
/* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based */
/* estimates of Difu and Difl. */
/* If M = 0 or N, DIF(1:2) = F-norm([A, B]). */
/* If IJOB = 0 or 1, DIF is not referenced. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */
/* IF IJOB = 0, WORK is not referenced. Otherwise, */
/* on exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= 4*N+16. */
/* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)). */
/* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*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/output) INTEGER array, dimension (LIWORK) */
/* IF IJOB = 0, IWORK is not referenced. Otherwise, */
/* on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. LIWORK >= 1. */
/* If IJOB = 1, 2 or 4, LIWORK >= N+6. */
/* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6). */
/* 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 (A, B) failed because the transformed */
/* matrix pair (A, B) would be too far from generalized */
/* Schur form; the problem is very ill-conditioned. */
/* (A, B) may have been partially reordered. */
/* If requested, 0 is returned in DIF(*), PL and PR. */
/* Further Details */
/* =============== */
/* DTGSEN first collects the selected eigenvalues by computing */
/* orthogonal U and W that move them to the top left corner of (A, B). */
/* In other words, the selected eigenvalues are the eigenvalues of */
/* (A11, B11) in: */
/* U'*(A, B)*W = (A11 A12) (B11 B12) n1 */
/* ( 0 A22),( 0 B22) n2 */
/* n1 n2 n1 n2 */
/* where N = n1+n2 and U' means the transpose of U. The first n1 columns */
/* of U and W span the specified pair of left and right eigenspaces */
/* (deflating subspaces) of (A, B). */
/* If (A, B) has been obtained from the generalized real Schur */
/* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the */
/* reordered generalized real Schur form of (C, D) is given by */
/* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)', */
/* and the first n1 columns of Q*U and Z*W span the corresponding */
/* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). */
/* Note that if the selected eigenvalue is sufficiently ill-conditioned, */
/* then its value may differ significantly from its value before */
/* reordering. */
/* The reciprocal condition numbers of the left and right eigenspaces */
/* spanned by the first n1 columns of U and W (or Q*U and Z*W) may */
/* be returned in DIF(1:2), corresponding to Difu and Difl, resp. */
/* The Difu and Difl are defined as: */
/* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) */
/* and */
/* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], */
/* where sigma-min(Zu) is the smallest singular value of the */
/* (2*n1*n2)-by-(2*n1*n2) matrix */
/* Zu = [ kron(In2, A11) -kron(A22', In1) ] */
/* [ kron(In2, B11) -kron(B22', In1) ]. */
/* Here, Inx is the identity matrix of size nx and A22' is the */
/* transpose of A22. kron(X, Y) is the Kronecker product between */
/* the matrices X and Y. */
/* When DIF(2) is small, small changes in (A, B) can cause large changes */
/* in the deflating subspace. An approximate (asymptotic) bound on the */
/* maximum angular error in the computed deflating subspaces is */
/* EPS * norm((A, B)) / DIF(2), */
/* where EPS is the machine precision. */
/* The reciprocal norm of the projectors on the left and right */
/* eigenspaces associated with (A11, B11) may be returned in PL and PR. */
/* They are computed as follows. First we compute L and R so that */
/* P*(A, B)*Q is block diagonal, where */
/* P = ( I -L ) n1 Q = ( I R ) n1 */
/* ( 0 I ) n2 and ( 0 I ) n2 */
/* n1 n2 n1 n2 */
/* and (L, R) is the solution to the generalized Sylvester equation */
/* A11*R - L*A22 = -A12 */
/* B11*R - L*B22 = -B12 */
/* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). */
/* An approximate (asymptotic) bound on the average absolute error of */
/* the selected eigenvalues is */
/* EPS * norm((A, B)) / PL. */
/* There are also global error bounds which valid for perturbations up */
/* to a certain restriction: A lower bound (x) on the smallest */
/* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and */
/* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), */
/* (i.e. (A + E, B + F), is */
/* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). */
/* An approximate bound on x can be computed from DIF(1:2), PL and PR. */
/* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed */
/* (L', R') and unperturbed (L, R) left and right deflating subspaces */
/* associated with the selected cluster in the (1,1)-blocks can be */
/* bounded as */
/* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) */
/* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) */
/* See LAPACK User's Guide section 4.11 or the following references */
/* for more information. */
/* Note that if the default method for computing the Frobenius-norm- */
/* based estimate DIF is not wanted (see DLATDF), then the parameter */
/* IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF */
/* (IJOB = 2 will be used)). See DTGSYL for more details. */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* References */
/* ========== */
/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
/* Estimation: Theory, Algorithms and Software, */
/* Report UMINF - 94.04, Department of Computing Science, Umea */
/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */
/* Note 87. To appear in Numerical Algorithms, 1996. */
/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
/* for Solving the Generalized Sylvester Equation and Estimating the */
/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
/* Department of Computing Science, Umea University, S-901 87 Umea, */
/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */
/* 1996. */
/* ===================================================================== */
/* .. Parameters .. */
/*< INTEGER IDIFJB >*/
/*< PARAMETER ( IDIFJB = 3 ) >*/
/*< DOUBLE PRECISION ZERO, ONE >*/
/*< PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< >*/
/*< >*/
/*< DOUBLE PRECISION DSCALE, DSUM, EPS, RDSCAL, SMLNUM >*/
/* .. */
/* .. External Subroutines .. */
/*< >*/
/* .. */
/* .. External Functions .. */
/*< DOUBLE PRECISION DLAMCH >*/
/*< EXTERNAL DLAMCH >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC MAX, SIGN, SQRT >*/
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/*< INFO = 0 >*/
/* Parameter adjustments */
--select;
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;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--dif;
--work;
--iwork;
/* Function Body */
*info = 0;
/*< LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) >*/
lquery = *lwork == -1 || *liwork == -1;
/*< IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN >*/
if (*ijob < 0 || *ijob > 5) {
/*< INFO = -1 >*/
*info = -1;
/*< ELSE IF( N.LT.0 ) THEN >*/
} else if (*n < 0) {
/*< INFO = -5 >*/
*info = -5;
/*< ELSE IF( LDA.LT.MAX( 1, N ) ) THEN >*/
} else if (*lda < max(1,*n)) {
/*< INFO = -7 >*/
*info = -7;
/*< ELSE IF( LDB.LT.MAX( 1, N ) ) THEN >*/
} else if (*ldb < max(1,*n)) {
/*< INFO = -9 >*/
*info = -9;
/*< ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN >*/
} else if (*ldq < 1 || (*wantq && *ldq < *n)) {
/*< INFO = -14 >*/
*info = -14;
/*< ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN >*/
} else if (*ldz < 1 || (*wantz && *ldz < *n)) {
/*< INFO = -16 >*/
*info = -16;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'DTGSEN', -INFO ) >*/
i__1 = -(*info);
xerbla_("DTGSEN", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* Get machine constants */
/*< EPS = DLAMCH( 'P' ) >*/
eps = dlamch_("P", (ftnlen)1);
/*< SMLNUM = DLAMCH( 'S' ) / EPS >*/
smlnum = dlamch_("S", (ftnlen)1) / eps;
/*< IERR = 0 >*/
ierr = 0;
/*< WANTP = IJOB.EQ.1 .OR. IJOB.GE.4 >*/
wantp = *ijob == 1 || *ijob >= 4;
/*< WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4 >*/
wantd1 = *ijob == 2 || *ijob == 4;
/*< WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5 >*/
wantd2 = *ijob == 3 || *ijob == 5;
/*< WANTD = WANTD1 .OR. WANTD2 >*/
wantd = wantd1 || wantd2;
/* Set M to the dimension of the specified pair of deflating */
/* subspaces. */
/*< M = 0 >*/
*m = 0;
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< DO 10 K = 1, N >*/
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/*< IF( PAIR ) THEN >*/
if (pair) {
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< ELSE >*/
} else {
/*< IF( K.LT.N ) THEN >*/
if (k < *n) {
/*< IF( A( K+1, K ).EQ.ZERO ) THEN >*/
if (a[k + 1 + k * a_dim1] == 0.) {
/*< >*/
if (select[k]) {
++(*m);
}
/*< ELSE >*/
} else {
/*< PAIR = .TRUE. >*/
pair = TRUE_;
/*< >*/
if (select[k] || select[k + 1]) {
*m += 2;
}
/*< END IF >*/
}
/*< ELSE >*/
} else {
/*< >*/
if (select[*n]) {
++(*m);
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< 10 CONTINUE >*/
/* L10: */
}
/*< IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN >*/
if (*ijob == 1 || *ijob == 2 || *ijob == 4) {
/*< LWMIN = MAX( 1, 4*N+16, 2*M*( N-M ) ) >*/
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), i__2 = (*m <<
1) * (*n - *m);
lwmin = max(i__1,i__2);
/*< LIWMIN = MAX( 1, N+6 ) >*/
/* Computing MAX */
i__1 = 1, i__2 = *n + 6;
liwmin = max(i__1,i__2);
/*< ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN >*/
} else if (*ijob == 3 || *ijob == 5) {
/*< LWMIN = MAX( 1, 4*N+16, 4*M*( N-M ) ) >*/
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), i__2 = (*m <<
2) * (*n - *m);
lwmin = max(i__1,i__2);
/*< LIWMIN = MAX( 1, 2*M*( N-M ), N+6 ) >*/
/* Computing MAX */
i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = max(i__1,i__2), i__2 =
*n + 6;
liwmin = max(i__1,i__2);
/*< ELSE >*/
} else {
/*< LWMIN = MAX( 1, 4*N+16 ) >*/
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16;
lwmin = max(i__1,i__2);
/*< LIWMIN = 1 >*/
liwmin = 1;
/*< END IF >*/
}
/*< WORK( 1 ) = LWMIN >*/
work[1] = (doublereal) lwmin;
/*< IWORK( 1 ) = LIWMIN >*/
iwork[1] = liwmin;
/*< IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN >*/
if (*lwork < lwmin && ! lquery) {
/*< INFO = -22 >*/
*info = -22;
/*< ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN >*/
} else if (*liwork < liwmin && ! lquery) {
/*< INFO = -24 >*/
*info = -24;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'DTGSEN', -INFO ) >*/
i__1 = -(*info);
xerbla_("DTGSEN", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< ELSE IF( LQUERY ) THEN >*/
} else if (lquery) {
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* Quick return if possible. */
/*< IF( M.EQ.N .OR. M.EQ.0 ) THEN >*/
if (*m == *n || *m == 0) {
/*< IF( WANTP ) THEN >*/
if (wantp) {
/*< PL = ONE >*/
*pl = 1.;
/*< PR = ONE >*/
*pr = 1.;
/*< END IF >*/
}
/*< IF( WANTD ) THEN >*/
if (wantd) {
/*< DSCALE = ZERO >*/
dscale = 0.;
/*< DSUM = ONE >*/
dsum = 1.;
/*< DO 20 I = 1, N >*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< CALL DLASSQ( N, A( 1, I ), 1, DSCALE, DSUM ) >*/
dlassq_(n, &a[i__ * a_dim1 + 1], &c__1, &dscale, &dsum);
/*< CALL DLASSQ( N, B( 1, I ), 1, DSCALE, DSUM ) >*/
dlassq_(n, &b[i__ * b_dim1 + 1], &c__1, &dscale, &dsum);
/*< 20 CONTINUE >*/
/* L20: */
}
/*< DIF( 1 ) = DSCALE*SQRT( DSUM ) >*/
dif[1] = dscale * sqrt(dsum);
/*< DIF( 2 ) = DIF( 1 ) >*/
dif[2] = dif[1];
/*< END IF >*/
}
/*< GO TO 60 >*/
goto L60;
/*< END IF >*/
}
/* Collect the selected blocks at the top-left corner of (A, B). */
/*< KS = 0 >*/
ks = 0;
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< DO 30 K = 1, N >*/
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/*< IF( PAIR ) THEN >*/
if (pair) {
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< ELSE >*/
} else {
/*< SWAP = SELECT( K ) >*/
swap = select[k];
/*< IF( K.LT.N ) THEN >*/
if (k < *n) {
/*< IF( A( K+1, K ).NE.ZERO ) THEN >*/
if (a[k + 1 + k * a_dim1] != 0.) {
/*< PAIR = .TRUE. >*/
pair = TRUE_;
/*< SWAP = SWAP .OR. SELECT( K+1 ) >*/
swap = swap || select[k + 1];
/*< END IF >*/
}
/*< END IF >*/
}
/*< IF( SWAP ) THEN >*/
if (swap) {
/*< KS = KS + 1 >*/
++ks;
/* Swap the K-th block to position KS. */
/* Perform the reordering of diagonal blocks in (A, B) */
/* by orthogonal transformation matrices and update */
/* Q and Z accordingly (if requested): */
/*< KK = K >*/
kk = k;
/*< >*/
if (k != ks) {
dtgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &kk,
&ks, &work[1], lwork, &ierr);
}
/*< IF( IERR.GT.0 ) THEN >*/
if (ierr > 0) {
/* Swap is rejected: exit. */
/*< INFO = 1 >*/
*info = 1;
/*< IF( WANTP ) THEN >*/
if (wantp) {
/*< PL = ZERO >*/
*pl = 0.;
/*< PR = ZERO >*/
*pr = 0.;
/*< END IF >*/
}
/*< IF( WANTD ) THEN >*/
if (wantd) {
/*< DIF( 1 ) = ZERO >*/
dif[1] = 0.;
/*< DIF( 2 ) = ZERO >*/
dif[2] = 0.;
/*< END IF >*/
}
/*< GO TO 60 >*/
goto L60;
/*< END IF >*/
}
/*< >*/
if (pair) {
++ks;
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< 30 CONTINUE >*/
/* L30: */
}
/*< IF( WANTP ) THEN >*/
if (wantp) {
/* Solve generalized Sylvester equation for R and L */
/* and compute PL and PR. */
/*< N1 = M >*/
n1 = *m;
/*< N2 = N - M >*/
n2 = *n - *m;
/*< I = N1 + 1 >*/
i__ = n1 + 1;
/*< IJB = 0 >*/
ijb = 0;
/*< CALL DLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 ) >*/
dlacpy_("Full", &n1, &n2, &a[i__ * a_dim1 + 1], lda, &work[1], &n1, (
ftnlen)4);
/*< >*/
dlacpy_("Full", &n1, &n2, &b[i__ * b_dim1 + 1], ldb, &work[n1 * n2 +
1], &n1, (ftnlen)4);
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * a_dim1]
, lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + i__ *
b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], &
work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr, (ftnlen)1);
/* Estimate the reciprocal of norms of "projections" onto left */
/* and right eigenspaces. */
/*< RDSCAL = ZERO >*/
rdscal = 0.;
/*< DSUM = ONE >*/
dsum = 1.;
/*< CALL DLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM ) >*/
i__1 = n1 * n2;
dlassq_(&i__1, &work[1], &c__1, &rdscal, &dsum);
/*< PL = RDSCAL*SQRT( DSUM ) >*/
*pl = rdscal * sqrt(dsum);
/*< IF( PL.EQ.ZERO ) THEN >*/
if (*pl == 0.) {
/*< PL = ONE >*/
*pl = 1.;
/*< ELSE >*/
} else {
/*< PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) ) >*/
*pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl));
/*< END IF >*/
}
/*< RDSCAL = ZERO >*/
rdscal = 0.;
/*< DSUM = ONE >*/
dsum = 1.;
/*< CALL DLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM ) >*/
i__1 = n1 * n2;
dlassq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum);
/*< PR = RDSCAL*SQRT( DSUM ) >*/
*pr = rdscal * sqrt(dsum);
/*< IF( PR.EQ.ZERO ) THEN >*/
if (*pr == 0.) {
/*< PR = ONE >*/
*pr = 1.;
/*< ELSE >*/
} else {
/*< PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) ) >*/
*pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr));
/*< END IF >*/
}
/*< END IF >*/
}
/*< IF( WANTD ) THEN >*/
if (wantd) {
/* Compute estimates of Difu and Difl. */
/*< IF( WANTD1 ) THEN >*/
if (wantd1) {
/*< N1 = M >*/
n1 = *m;
/*< N2 = N - M >*/
n2 = *n - *m;
/*< I = N1 + 1 >*/
i__ = n1 + 1;
/*< IJB = IDIFJB >*/
ijb = 3;
/* Frobenius norm-based Difu-estimate. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ *
a_dim1], lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ +
i__ * b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &
dif[1], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], &
ierr, (ftnlen)1);
/* Frobenius norm-based Difl-estimate. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, &a[
a_offset], lda, &work[1], &n2, &b[i__ + i__ * b_dim1],
ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &dscale,
&dif[2], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], &
ierr, (ftnlen)1);
/*< ELSE >*/
} else {
/* Compute 1-norm-based estimates of Difu and Difl using */
/* reversed communication with DLACON. In each step a */
/* generalized Sylvester equation or a transposed variant */
/* is solved. */
/*< KASE = 0 >*/
kase = 0;
/*< N1 = M >*/
n1 = *m;
/*< N2 = N - M >*/
n2 = *n - *m;
/*< I = N1 + 1 >*/
i__ = n1 + 1;
/*< IJB = 0 >*/
ijb = 0;
/*< MN2 = 2*N1*N2 >*/
mn2 = (n1 << 1) * n2;
/* 1-norm-based estimate of Difu. */
/*< 40 CONTINUE >*/
L40:
/*< >*/
dlacon_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[1], &kase)
;
/*< IF( KASE.NE.0 ) THEN >*/
if (kase != 0) {
/*< IF( KASE.EQ.1 ) THEN >*/
if (kase == 1) {
/* Solve generalized Sylvester equation. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr, (ftnlen)1);
/*< ELSE >*/
} else {
/* Solve the transposed variant. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("T", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr, (ftnlen)1);
/*< END IF >*/
}
/*< GO TO 40 >*/
goto L40;
/*< END IF >*/
}
/*< DIF( 1 ) = DSCALE / DIF( 1 ) >*/
dif[1] = dscale / dif[1];
/* 1-norm-based estimate of Difl. */
/*< 50 CONTINUE >*/
L50:
/*< >*/
dlacon_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[2], &kase)
;
/*< IF( KASE.NE.0 ) THEN >*/
if (kase != 0) {
/*< IF( KASE.EQ.1 ) THEN >*/
if (kase == 1) {
/* Solve generalized Sylvester equation. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
&a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr, (ftnlen)1);
/*< ELSE >*/
} else {
/* Solve the transposed variant. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("T", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
&a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr, (ftnlen)1);
/*< END IF >*/
}
/*< GO TO 50 >*/
goto L50;
/*< END IF >*/
}
/*< DIF( 2 ) = DSCALE / DIF( 2 ) >*/
dif[2] = dscale / dif[2];
/*< END IF >*/
}
/*< END IF >*/
}
/*< 60 CONTINUE >*/
L60:
/* Compute generalized eigenvalues of reordered pair (A, B) and */
/* normalize the generalized Schur form. */
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< DO 80 K = 1, N >*/
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/*< IF( PAIR ) THEN >*/
if (pair) {
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< ELSE >*/
} else {
/*< IF( K.LT.N ) THEN >*/
if (k < *n) {
/*< IF( A( K+1, K ).NE.ZERO ) THEN >*/
if (a[k + 1 + k * a_dim1] != 0.) {
/*< PAIR = .TRUE. >*/
pair = TRUE_;
/*< END IF >*/
}
/*< END IF >*/
}
/*< IF( PAIR ) THEN >*/
if (pair) {
/* Compute the eigenvalue(s) at position K. */
/*< WORK( 1 ) = A( K, K ) >*/
work[1] = a[k + k * a_dim1];
/*< WORK( 2 ) = A( K+1, K ) >*/
work[2] = a[k + 1 + k * a_dim1];
/*< WORK( 3 ) = A( K, K+1 ) >*/
work[3] = a[k + (k + 1) * a_dim1];
/*< WORK( 4 ) = A( K+1, K+1 ) >*/
work[4] = a[k + 1 + (k + 1) * a_dim1];
/*< WORK( 5 ) = B( K, K ) >*/
work[5] = b[k + k * b_dim1];
/*< WORK( 6 ) = B( K+1, K ) >*/
work[6] = b[k + 1 + k * b_dim1];
/*< WORK( 7 ) = B( K, K+1 ) >*/
work[7] = b[k + (k + 1) * b_dim1];
/*< WORK( 8 ) = B( K+1, K+1 ) >*/
work[8] = b[k + 1 + (k + 1) * b_dim1];
/*< >*/
d__1 = smlnum * eps;
dlag2_(&work[1], &c__2, &work[5], &c__2, &d__1, &beta[k], &
beta[k + 1], &alphar[k], &alphar[k + 1], &alphai[k]);
/*< ALPHAI( K+1 ) = -ALPHAI( K ) >*/
alphai[k + 1] = -alphai[k];
/*< ELSE >*/
} else {
/*< IF( SIGN( ONE, B( K, K ) ).LT.ZERO ) THEN >*/
if (d_sign(&c_b28, &b[k + k * b_dim1]) < 0.) {
/* If B(K,K) is negative, make it positive */
/*< DO 70 I = 1, N >*/
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< A( K, I ) = -A( K, I ) >*/
a[k + i__ * a_dim1] = -a[k + i__ * a_dim1];
/*< B( K, I ) = -B( K, I ) >*/
b[k + i__ * b_dim1] = -b[k + i__ * b_dim1];
/*< Q( I, K ) = -Q( I, K ) >*/
q[i__ + k * q_dim1] = -q[i__ + k * q_dim1];
/*< 70 CONTINUE >*/
/* L70: */
}
/*< END IF >*/
}
/*< ALPHAR( K ) = A( K, K ) >*/
alphar[k] = a[k + k * a_dim1];
/*< ALPHAI( K ) = ZERO >*/
alphai[k] = 0.;
/*< BETA( K ) = B( K, K ) >*/
beta[k] = b[k + k * b_dim1];
/*< END IF >*/
}
/*< END IF >*/
}
/*< 80 CONTINUE >*/
/* L80: */
}
/*< WORK( 1 ) = LWMIN >*/
work[1] = (doublereal) lwmin;
/*< IWORK( 1 ) = LIWMIN >*/
iwork[1] = liwmin;
/*< RETURN >*/
return 0;
/* End of DTGSEN */
/*< END >*/
} /* dtgsen_ */
/* Subroutine */
int dorbdb6_(integer *m1, integer *m2, integer *n, doublereal *x1, integer *incx1, doublereal *x2, integer *incx2, doublereal *q1, integer *ldq1, doublereal *q2, integer *ldq2, doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
integer q1_dim1, q1_offset, q2_dim1, q2_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
integer i__;
doublereal scl1, scl2, ssq1, ssq2;
extern /* Subroutine */
int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *), dlassq_(integer *, doublereal *, integer *, doublereal *, doublereal *);
doublereal normsq1, normsq2;
/* -- LAPACK computational routine (version 3.5.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* July 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Function .. */
/* .. */
/* .. Executable Statements .. */
/* Test input arguments */
/* Parameter adjustments */
--x1;
--x2;
q1_dim1 = *ldq1;
q1_offset = 1 + q1_dim1;
q1 -= q1_offset;
q2_dim1 = *ldq2;
q2_offset = 1 + q2_dim1;
q2 -= q2_offset;
--work;
/* Function Body */
*info = 0;
if (*m1 < 0)
{
*info = -1;
}
else if (*m2 < 0)
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
else if (*incx1 < 1)
{
*info = -5;
}
else if (*incx2 < 1)
{
*info = -7;
}
else if (*ldq1 < max(1,*m1))
{
*info = -9;
}
else if (*ldq2 < max(1,*m2))
{
*info = -11;
}
else if (*lwork < *n)
{
*info = -13;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DORBDB6", &i__1);
return 0;
}
/* First, project X onto the orthogonal complement of Q's column */
/* space */
scl1 = 0.;
ssq1 = 1.;
dlassq_(m1, &x1[1], incx1, &scl1, &ssq1);
scl2 = 0.;
ssq2 = 1.;
dlassq_(m2, &x2[1], incx2, &scl2, &ssq2);
/* Computing 2nd power */
d__1 = scl1;
/* Computing 2nd power */
d__2 = scl2;
normsq1 = d__1 * d__1 * ssq1 + d__2 * d__2 * ssq2;
if (*m1 == 0)
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.;
}
}
else
{
dgemv_("C", m1, n, &c_b4, &q1[q1_offset], ldq1, &x1[1], incx1, &c_b5, &work[1], &c__1);
}
dgemv_("C", m2, n, &c_b4, &q2[q2_offset], ldq2, &x2[1], incx2, &c_b4, & work[1], &c__1);
dgemv_("N", m1, n, &c_b12, &q1[q1_offset], ldq1, &work[1], &c__1, &c_b4, & x1[1], incx1);
dgemv_("N", m2, n, &c_b12, &q2[q2_offset], ldq2, &work[1], &c__1, &c_b4, & x2[1], incx2);
scl1 = 0.;
ssq1 = 1.;
dlassq_(m1, &x1[1], incx1, &scl1, &ssq1);
scl2 = 0.;
ssq2 = 1.;
dlassq_(m2, &x2[1], incx2, &scl2, &ssq2);
/* Computing 2nd power */
d__1 = scl1;
/* Computing 2nd power */
d__2 = scl2;
normsq2 = d__1 * d__1 * ssq1 + d__2 * d__2 * ssq2;
/* If projection is sufficiently large in norm, then stop. */
/* If projection is zero, then stop. */
/* Otherwise, project again. */
if (normsq2 >= normsq1 * .01)
{
return 0;
}
if (normsq2 == 0.)
{
return 0;
}
normsq1 = normsq2;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.;
}
if (*m1 == 0)
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.;
}
}
else
{
dgemv_("C", m1, n, &c_b4, &q1[q1_offset], ldq1, &x1[1], incx1, &c_b5, &work[1], &c__1);
}
dgemv_("C", m2, n, &c_b4, &q2[q2_offset], ldq2, &x2[1], incx2, &c_b4, & work[1], &c__1);
dgemv_("N", m1, n, &c_b12, &q1[q1_offset], ldq1, &work[1], &c__1, &c_b4, & x1[1], incx1);
dgemv_("N", m2, n, &c_b12, &q2[q2_offset], ldq2, &work[1], &c__1, &c_b4, & x2[1], incx2);
scl1 = 0.;
ssq1 = 1.;
dlassq_(m1, &x1[1], incx1, &scl1, &ssq1);
scl2 = 0.;
ssq2 = 1.;
dlassq_(m1, &x1[1], incx1, &scl1, &ssq1);
/* Computing 2nd power */
d__1 = scl1;
/* Computing 2nd power */
d__2 = scl2;
normsq2 = d__1 * d__1 * ssq1 + d__2 * d__2 * ssq2;
/* If second projection is sufficiently large in norm, then do */
/* nothing more. Alternatively, if it shrunk significantly, then */
/* truncate it to zero. */
if (normsq2 < normsq1 * .01)
{
i__1 = *m1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
x1[i__] = 0.;
}
i__1 = *m2;
for (i__ = 1;
i__ <= i__1;
++i__)
{
x2[i__] = 0.;
}
}
return 0;
/* End of DORBDB6 */
}
doublereal dlangb_(char *norm, integer *n, integer *kl, integer *ku,
doublereal *ab, integer *ldab, doublereal *work)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
DLANGB returns the value of the one norm, or the Frobenius norm, or
the infinity norm, or the element of largest absolute value of an
n by n band matrix A, with kl sub-diagonals and ku super-diagonals.
Description
===========
DLANGB returns the value
DLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
(
( norm1(A), NORM = '1', 'O' or 'o'
(
( normI(A), NORM = 'I' or 'i'
(
( normF(A), NORM = 'F', 'f', 'E' or 'e'
where norm1 denotes the one norm of a matrix (maximum column sum),
normI denotes the infinity norm of a matrix (maximum row sum) and
normF denotes the Frobenius norm of a matrix (square root of sum of
squares). Note that max(abs(A(i,j))) is not a matrix norm.
Arguments
=========
NORM (input) CHARACTER*1
Specifies the value to be returned in DLANGB as described
above.
N (input) INTEGER
The order of the matrix A. N >= 0. When N = 0, DLANGB is
set to zero.
KL (input) INTEGER
The number of sub-diagonals of the matrix A. KL >= 0.
KU (input) INTEGER
The number of super-diagonals of the matrix A. KU >= 0.
AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
The band matrix A, stored in rows 1 to KL+KU+1. The j-th
column of A is stored in the j-th column of the array AB as
follows:
AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KL+KU+1.
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK),
where LWORK >= N when NORM = 'I'; otherwise, WORK is not
referenced.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__, j, k, l;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal value;
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *);
static doublereal sum;
#define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--work;
/* Function Body */
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = *ku + 2 - j;
/* Computing MIN */
i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
i__3 = min(i__4,i__5);
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ab_ref(i__, j), abs(d__1));
value = max(d__2,d__3);
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
/* Computing MAX */
i__3 = *ku + 2 - j;
/* Computing MIN */
i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
i__2 = min(i__4,i__5);
for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
sum += (d__1 = ab_ref(i__, j), abs(d__1));
/* L30: */
}
value = max(value,sum);
/* L40: */
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L50: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
k = *ku + 1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *ku;
/* Computing MIN */
i__5 = *n, i__6 = j + *kl;
i__4 = min(i__5,i__6);
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
work[i__] += (d__1 = ab_ref(k + i__, j), abs(d__1));
/* L60: */
}
/* L70: */
}
value = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L80: */
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__4 = 1, i__2 = j - *ku;
l = max(i__4,i__2);
k = *ku + 1 - j + l;
/* Computing MIN */
i__2 = *n, i__3 = j + *kl;
i__4 = min(i__2,i__3) - l + 1;
dlassq_(&i__4, &ab_ref(k, j), &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANGB */
} /* dlangb_ */
doublereal dlanhs_(char *norm, integer *n, doublereal *a, integer *lda,
doublereal *work, ftnlen norm_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__, j;
static doublereal sum, scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static doublereal value;
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLANHS returns the value of the one norm, or the Frobenius norm, or */
/* the infinity norm, or the element of largest absolute value of a */
/* Hessenberg matrix A. */
/* Description */
/* =========== */
/* DLANHS returns the value */
/* DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum), */
/* normI denotes the infinity norm of a matrix (maximum row sum) and */
/* normF denotes the Frobenius norm of a matrix (square root of sum of */
/* squares). Note that max(abs(A(i,j))) is not a matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in DLANHS as described */
/* above. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, DLANHS is */
/* set to zero. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The n by n upper Hessenberg matrix A; the part of A below the */
/* first sub-diagonal is not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(N,1). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), */
/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
/* Function Body */
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, "M", (ftnlen)1, (ftnlen)1)) {
/* Find max(abs(A(i,j))). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
value = max(d__2,d__3);
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, "O", (ftnlen)1, (ftnlen)1) || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L30: */
}
value = max(value,sum);
/* L40: */
}
} else if (lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) {
/* Find normI(A). */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L50: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L60: */
}
/* L70: */
}
value = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L80: */
}
} else if (lsame_(norm, "F", (ftnlen)1, (ftnlen)1) || lsame_(norm, "E", (
ftnlen)1, (ftnlen)1)) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANHS */
} /* dlanhs_ */
doublereal dlanst_(char *norm, integer *n, doublereal *d, doublereal *e)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DLANST returns the value of the one norm, or the Frobenius norm, or
the infinity norm, or the element of largest absolute value of a
real symmetric tridiagonal matrix A.
Description
===========
DLANST returns the value
DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'
(
( norm1(A), NORM = '1', 'O' or 'o'
(
( normI(A), NORM = 'I' or 'i'
(
( normF(A), NORM = 'F', 'f', 'E' or 'e'
where norm1 denotes the one norm of a matrix (maximum column sum),
normI denotes the infinity norm of a matrix (maximum row sum) and
normF denotes the Frobenius norm of a matrix (square root of sum of
squares). Note that max(abs(A(i,j))) is not a matrix norm.
Arguments
=========
NORM (input) CHARACTER*1
Specifies the value to be returned in DLANST as described
above.
N (input) INTEGER
The order of the matrix A. N >= 0. When N = 0, DLANST is
set to zero.
D (input) DOUBLE PRECISION array, dimension (N)
The diagonal elements of A.
E (input) DOUBLE PRECISION array, dimension (N-1)
The (n-1) sub-diagonal or super-diagonal elements of A.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer i__1;
doublereal ret_val, d__1, d__2, d__3, d__4, d__5;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal anorm;
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *);
static doublereal sum;
#define E(I) e[(I)-1]
#define D(I) d[(I)-1]
if (*n <= 0) {
anorm = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
anorm = (d__1 = D(*n), abs(d__1));
i__1 = *n - 1;
for (i = 1; i <= *n-1; ++i) {
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = D(i), abs(d__1));
anorm = max(d__2,d__3);
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = E(i), abs(d__1));
anorm = max(d__2,d__3);
/* L10: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)norm == '1' ||
lsame_(norm, "I")) {
/* Find norm1(A). */
if (*n == 1) {
anorm = abs(D(1));
} else {
/* Computing MAX */
d__3 = abs(D(1)) + abs(E(1)), d__4 = (d__1 = E(*n - 1), abs(d__1))
+ (d__2 = D(*n), abs(d__2));
anorm = max(d__3,d__4);
i__1 = *n - 1;
for (i = 2; i <= *n-1; ++i) {
/* Computing MAX */
d__4 = anorm, d__5 = (d__1 = D(i), abs(d__1)) + (d__2 = E(i),
abs(d__2)) + (d__3 = E(i - 1), abs(d__3));
anorm = max(d__4,d__5);
/* L20: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
if (*n > 1) {
i__1 = *n - 1;
dlassq_(&i__1, &E(1), &c__1, &scale, &sum);
sum *= 2;
}
dlassq_(n, &D(1), &c__1, &scale, &sum);
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of DLANST */
} /* dlanst_ */
doublereal dlantb_(char *norm, char *uplo, char *diag, integer *n, integer *k,
doublereal *ab, integer *ldab, doublereal *work)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
doublereal ret_val, d__1, d__2, d__3;
/* Local variables */
integer i__, j, l;
doublereal sum, scale;
logical udiag;
doublereal value;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DLANTB returns the value of the one norm, or the Frobenius norm, or */
/* the infinity norm, or the element of largest absolute value of an */
/* n by n triangular band matrix A, with ( k + 1 ) diagonals. */
/* Description */
/* =========== */
/* DLANTB returns the value */
/* DLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum), */
/* normI denotes the infinity norm of a matrix (maximum row sum) and */
/* normF denotes the Frobenius norm of a matrix (square root of sum of */
/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in DLANTB as described */
/* above. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, DLANTB is */
/* set to zero. */
/* K (input) INTEGER */
/* The number of super-diagonals of the matrix A if UPLO = 'U', */
/* or the number of sub-diagonals of the matrix A if UPLO = 'L'. */
/* K >= 0. */
/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
/* The upper or lower triangular band matrix A, stored in the */
/* first k+1 rows of AB. The j-th column of A is stored */
/* in the j-th column of the array AB as follows: */
/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */
/* Note that when DIAG = 'U', the elements of the array AB */
/* corresponding to the diagonal elements of the matrix A are */
/* not referenced, but are assumed to be one. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= K+1. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* ===================================================================== */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--work;
/* Function Body */
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
if (lsame_(diag, "U")) {
value = 1.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1],
abs(d__1));
value = max(d__2,d__3);
}
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *n + 1 - j, i__4 = *k + 1;
i__3 = min(i__2,i__4);
for (i__ = 2; i__ <= i__3; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1],
abs(d__1));
value = max(d__2,d__3);
}
}
}
} else {
value = 0.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__3 = *k + 2 - j;
i__2 = *k + 1;
for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1],
abs(d__1));
value = max(d__2,d__3);
}
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n + 1 - j, i__4 = *k + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1],
abs(d__1));
value = max(d__2,d__3);
}
}
}
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.;
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1));
}
} else {
sum = 0.;
/* Computing MAX */
i__3 = *k + 2 - j;
i__2 = *k + 1;
for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1));
}
}
value = max(value,sum);
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.;
/* Computing MIN */
i__3 = *n + 1 - j, i__4 = *k + 1;
i__2 = min(i__3,i__4);
for (i__ = 2; i__ <= i__2; ++i__) {
sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1));
}
} else {
sum = 0.;
/* Computing MIN */
i__3 = *n + 1 - j, i__4 = *k + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1));
}
}
value = max(value,sum);
}
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
value = 0.;
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = *k + 1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
work[i__] += (d__1 = ab[l + i__ + j * ab_dim1], abs(
d__1));
}
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = *k + 1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
work[i__] += (d__1 = ab[l + i__ + j * ab_dim1], abs(
d__1));
}
}
}
} else {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
work[i__] += (d__1 = ab[l + i__ + j * ab_dim1], abs(
d__1));
}
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2);
for (i__ = j; i__ <= i__3; ++i__) {
work[i__] += (d__1 = ab[l + i__ + j * ab_dim1], abs(
d__1));
}
}
}
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
scale = 1.;
sum = (doublereal) (*n);
if (*k > 0) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing MIN */
i__4 = j - 1;
i__3 = min(i__4,*k);
/* Computing MAX */
i__2 = *k + 2 - j;
dlassq_(&i__3, &ab[max(i__2, 1)+ j * ab_dim1], &c__1,
&scale, &sum);
}
}
} else {
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__4 = j, i__2 = *k + 1;
i__3 = min(i__4,i__2);
/* Computing MAX */
i__5 = *k + 2 - j;
dlassq_(&i__3, &ab[max(i__5, 1)+ j * ab_dim1], &c__1, &
scale, &sum);
}
}
} else {
if (lsame_(diag, "U")) {
scale = 1.;
sum = (doublereal) (*n);
if (*k > 0) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__4 = *n - j;
i__3 = min(i__4,*k);
dlassq_(&i__3, &ab[j * ab_dim1 + 2], &c__1, &scale, &
sum);
}
}
} else {
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__4 = *n - j + 1, i__2 = *k + 1;
i__3 = min(i__4,i__2);
dlassq_(&i__3, &ab[j * ab_dim1 + 1], &c__1, &scale, &sum);
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANTB */
} /* dlantb_ */
double dlansp_(char *norm, char *uplo, int *n, double *ap,
double *work)
{
/* System generated locals */
int i__1, i__2;
double ret_val, d__1, d__2, d__3;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int i__, j, k;
double sum, absa, scale;
extern int lsame_(char *, char *);
double value;
extern int dlassq_(int *, double *, int *,
double *, double *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLANSP returns the value of the one norm, or the Frobenius norm, or */
/* the infinity norm, or the element of largest absolute value of a */
/* float symmetric matrix A, supplied in packed form. */
/* Description */
/* =========== */
/* DLANSP returns the value */
/* DLANSP = ( MAX(ABS(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum), */
/* normI denotes the infinity norm of a matrix (maximum row sum) and */
/* normF denotes the Frobenius norm of a matrix (square root of sum of */
/* squares). Note that MAX(ABS(A(i,j))) is not a consistent matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in DLANSP as described */
/* above. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is supplied. */
/* = 'U': Upper triangular part of A is supplied */
/* = 'L': Lower triangular part of A is supplied */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, DLANSP is */
/* set to zero. */
/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* The upper or lower triangle of the symmetric matrix A, packed */
/* columnwise in a linear array. The j-th column of A is stored */
/* in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
/* WORK is not referenced. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--work;
--ap;
/* Function Body */
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find MAX(ABS(A(i,j))). */
value = 0.;
if (lsame_(uplo, "U")) {
k = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j - 1;
for (i__ = k; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ap[i__], ABS(d__1));
value = MAX(d__2,d__3);
/* L10: */
}
k += j;
/* L20: */
}
} else {
k = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = k + *n - j;
for (i__ = k; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ap[i__], ABS(d__1));
value = MAX(d__2,d__3);
/* L30: */
}
k = k + *n - j + 1;
/* L40: */
}
}
} else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
/* Find normI(A) ( = norm1(A), since A is symmetric). */
value = 0.;
k = 1;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
absa = (d__1 = ap[k], ABS(d__1));
sum += absa;
work[i__] += absa;
++k;
/* L50: */
}
work[j] = sum + (d__1 = ap[k], ABS(d__1));
++k;
/* L60: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = MAX(d__1,d__2);
/* L70: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L80: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = work[j] + (d__1 = ap[k], ABS(d__1));
++k;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
absa = (d__1 = ap[k], ABS(d__1));
sum += absa;
work[i__] += absa;
++k;
/* L90: */
}
value = MAX(value,sum);
/* L100: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
k = 2;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
dlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k += j;
/* L110: */
}
} else {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
dlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k = k + *n - j + 1;
/* L120: */
}
}
sum *= 2;
k = 1;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (ap[k] != 0.) {
absa = (d__1 = ap[k], ABS(d__1));
if (scale < absa) {
/* Computing 2nd power */
d__1 = scale / absa;
sum = sum * (d__1 * d__1) + 1.;
scale = absa;
} else {
/* Computing 2nd power */
d__1 = absa / scale;
sum += d__1 * d__1;
}
}
if (lsame_(uplo, "U")) {
k = k + i__ + 1;
} else {
k = k + *n - i__ + 1;
}
/* L130: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANSP */
} /* dlansp_ */
double zlanht_(char *norm, int *n, double *d__, doublecomplex *e)
{
/* System generated locals */
int i__1;
double ret_val, d__1, d__2, d__3;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(double);
/* Local variables */
int i__;
double sum, scale;
extern int lsame_(char *, char *);
double anorm;
extern int dlassq_(int *, double *, int *,
double *, double *), zlassq_(int *, doublecomplex *,
int *, double *, double *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLANHT returns the value of the one norm, or the Frobenius norm, or */
/* the infinity norm, or the element of largest absolute value of a */
/* complex Hermitian tridiagonal matrix A. */
/* Description */
/* =========== */
/* ZLANHT returns the value */
/* ZLANHT = ( MAX(ABS(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum), */
/* normI denotes the infinity norm of a matrix (maximum row sum) and */
/* normF denotes the Frobenius norm of a matrix (square root of sum of */
/* squares). Note that MAX(ABS(A(i,j))) is not a consistent matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in ZLANHT as described */
/* above. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, ZLANHT is */
/* set to zero. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The diagonal elements of A. */
/* E (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) sub-diagonal or super-diagonal elements of A. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--e;
--d__;
/* Function Body */
if (*n <= 0) {
anorm = 0.;
} else if (lsame_(norm, "M")) {
/* Find MAX(ABS(A(i,j))). */
anorm = (d__1 = d__[*n], ABS(d__1));
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = d__[i__], ABS(d__1));
anorm = MAX(d__2,d__3);
/* Computing MAX */
d__1 = anorm, d__2 = z_abs(&e[i__]);
anorm = MAX(d__1,d__2);
/* L10: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1' || lsame_(norm, "I")) {
/* Find norm1(A). */
if (*n == 1) {
anorm = ABS(d__[1]);
} else {
/* Computing MAX */
d__2 = ABS(d__[1]) + z_abs(&e[1]), d__3 = z_abs(&e[*n - 1]) + (
d__1 = d__[*n], ABS(d__1));
anorm = MAX(d__2,d__3);
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = d__[i__], ABS(d__1)) + z_abs(&e[
i__]) + z_abs(&e[i__ - 1]);
anorm = MAX(d__2,d__3);
/* L20: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
if (*n > 1) {
i__1 = *n - 1;
zlassq_(&i__1, &e[1], &c__1, &scale, &sum);
sum *= 2;
}
dlassq_(n, &d__[1], &c__1, &scale, &sum);
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of ZLANHT */
} /* zlanht_ */
doublereal dlantb_(char *norm, char *uplo, char *diag, integer *n, integer *k,
doublereal *ab, integer *ldab, doublereal *work)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
DLANTB returns the value of the one norm, or the Frobenius norm, or
the infinity norm, or the element of largest absolute value of an
n by n triangular band matrix A, with ( k + 1 ) diagonals.
Description
===========
DLANTB returns the value
DLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
(
( norm1(A), NORM = '1', 'O' or 'o'
(
( normI(A), NORM = 'I' or 'i'
(
( normF(A), NORM = 'F', 'f', 'E' or 'e'
where norm1 denotes the one norm of a matrix (maximum column sum),
normI denotes the infinity norm of a matrix (maximum row sum) and
normF denotes the Frobenius norm of a matrix (square root of sum of
squares). Note that max(abs(A(i,j))) is not a matrix norm.
Arguments
=========
NORM (input) CHARACTER*1
Specifies the value to be returned in DLANTB as described
above.
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
DIAG (input) CHARACTER*1
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
N (input) INTEGER
The order of the matrix A. N >= 0. When N = 0, DLANTB is
set to zero.
K (input) INTEGER
The number of super-diagonals of the matrix A if UPLO = 'U',
or the number of sub-diagonals of the matrix A if UPLO = 'L'.
K >= 0.
AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
The upper or lower triangular band matrix A, stored in the
first k+1 rows of AB. The j-th column of A is stored
in the j-th column of the array AB as follows:
if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).
Note that when DIAG = 'U', the elements of the array AB
corresponding to the diagonal elements of the matrix A are
not referenced, but are assumed to be one.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= K+1.
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK),
where LWORK >= N when NORM = 'I'; otherwise, WORK is not
referenced.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__, j, l;
static doublereal scale;
static logical udiag;
extern logical lsame_(char *, char *);
static doublereal value;
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *);
static doublereal sum;
#define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--work;
/* Function Body */
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
if (lsame_(diag, "U")) {
value = 1.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ab_ref(i__, j), abs(d__1)
);
value = max(d__2,d__3);
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *n + 1 - j, i__4 = *k + 1;
i__3 = min(i__2,i__4);
for (i__ = 2; i__ <= i__3; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ab_ref(i__, j), abs(d__1)
);
value = max(d__2,d__3);
/* L30: */
}
/* L40: */
}
}
} else {
value = 0.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__3 = *k + 2 - j;
i__2 = *k + 1;
for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ab_ref(i__, j), abs(d__1)
);
value = max(d__2,d__3);
/* L50: */
}
/* L60: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n + 1 - j, i__4 = *k + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ab_ref(i__, j), abs(d__1)
);
value = max(d__2,d__3);
/* L70: */
}
/* L80: */
}
}
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.;
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
sum += (d__1 = ab_ref(i__, j), abs(d__1));
/* L90: */
}
} else {
sum = 0.;
/* Computing MAX */
i__3 = *k + 2 - j;
i__2 = *k + 1;
for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
sum += (d__1 = ab_ref(i__, j), abs(d__1));
/* L100: */
}
}
value = max(value,sum);
/* L110: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.;
/* Computing MIN */
i__3 = *n + 1 - j, i__4 = *k + 1;
i__2 = min(i__3,i__4);
for (i__ = 2; i__ <= i__2; ++i__) {
sum += (d__1 = ab_ref(i__, j), abs(d__1));
/* L120: */
}
} else {
sum = 0.;
/* Computing MIN */
i__3 = *n + 1 - j, i__4 = *k + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
sum += (d__1 = ab_ref(i__, j), abs(d__1));
/* L130: */
}
}
value = max(value,sum);
/* L140: */
}
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
value = 0.;
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.;
/* L150: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = *k + 1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
work[i__] += (d__1 = ab_ref(l + i__, j), abs(d__1));
/* L160: */
}
/* L170: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L180: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = *k + 1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
work[i__] += (d__1 = ab_ref(l + i__, j), abs(d__1));
/* L190: */
}
/* L200: */
}
}
} else {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.;
/* L210: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
work[i__] += (d__1 = ab_ref(l + i__, j), abs(d__1));
/* L220: */
}
/* L230: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L240: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2);
for (i__ = j; i__ <= i__3; ++i__) {
work[i__] += (d__1 = ab_ref(l + i__, j), abs(d__1));
/* L250: */
}
/* L260: */
}
}
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L270: */
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
scale = 1.;
sum = (doublereal) (*n);
if (*k > 0) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing MAX */
i__3 = *k + 2 - j;
/* Computing MIN */
i__2 = j - 1;
i__4 = min(i__2,*k);
dlassq_(&i__4, &ab_ref(max(i__3,1), j), &c__1, &scale,
&sum);
/* L280: */
}
}
} else {
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__3 = *k + 2 - j;
/* Computing MIN */
i__2 = j, i__5 = *k + 1;
i__4 = min(i__2,i__5);
dlassq_(&i__4, &ab_ref(max(i__3,1), j), &c__1, &scale, &
sum);
/* L290: */
}
}
} else {
if (lsame_(diag, "U")) {
scale = 1.;
sum = (doublereal) (*n);
if (*k > 0) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__4 = *n - j;
i__3 = min(i__4,*k);
dlassq_(&i__3, &ab_ref(2, j), &c__1, &scale, &sum);
/* L300: */
}
}
} else {
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__4 = *n - j + 1, i__2 = *k + 1;
i__3 = min(i__4,i__2);
dlassq_(&i__3, &ab_ref(1, j), &c__1, &scale, &sum);
/* L310: */
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANTB */
} /* dlantb_ */
/* Subroutine */ int dtgsen_(integer *ijob, logical *wantq, logical *wantz,
logical *select, integer *n, doublereal *a, integer *lda, doublereal *
b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
beta, doublereal *q, integer *ldq, doublereal *z__, integer *ldz,
integer *m, doublereal *pl, doublereal *pr, doublereal *dif,
doublereal *work, integer *lwork, integer *iwork, integer *liwork,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
integer i__, k, n1, n2, kk, ks, mn2, ijb;
doublereal eps;
integer kase;
logical pair;
integer ierr;
doublereal dsum;
logical swap;
integer isave[3];
logical wantd;
integer lwmin;
logical wantp;
logical wantd1, wantd2;
doublereal dscale, rdscal;
integer liwmin;
doublereal smlnum;
logical lquery;
/* -- LAPACK routine (version 3.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* January 2007 */
/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
/* Purpose */
/* ======= */
/* DTGSEN reorders the generalized real Schur decomposition of a real */
/* matrix pair (A, B) (in terms of an orthonormal equivalence trans- */
/* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues */
/* appears in the leading diagonal blocks of the upper quasi-triangular */
/* matrix A and the upper triangular B. The leading columns of Q and */
/* Z form orthonormal bases of the corresponding left and right eigen- */
/* spaces (deflating subspaces). (A, B) must be in generalized real */
/* Schur canonical form (as returned by DGGES), i.e. A is block upper */
/* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper */
/* triangular. */
/* DTGSEN also computes the generalized eigenvalues */
/* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j) */
/* of the reordered matrix pair (A, B). */
/* Optionally, DTGSEN computes the estimates of reciprocal condition */
/* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), */
/* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) */
/* between the matrix pairs (A11, B11) and (A22,B22) that correspond to */
/* the selected cluster and the eigenvalues outside the cluster, resp., */
/* and norms of "projections" onto left and right eigenspaces w.r.t. */
/* the selected cluster in the (1,1)-block. */
/* Arguments */
/* ========= */
/* IJOB (input) INTEGER */
/* Specifies whether condition numbers are required for the */
/* cluster of eigenvalues (PL and PR) or the deflating subspaces */
/* (Difu and Difl): */
/* =0: Only reorder w.r.t. SELECT. No extras. */
/* =1: Reciprocal of norms of "projections" onto left and right */
/* eigenspaces w.r.t. the selected cluster (PL and PR). */
/* =2: Upper bounds on Difu and Difl. F-norm-based estimate */
/* (DIF(1:2)). */
/* =3: Estimate of Difu and Difl. 1-norm-based estimate */
/* (DIF(1:2)). */
/* About 5 times as expensive as IJOB = 2. */
/* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic */
/* version to get it all. */
/* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) */
/* WANTQ (input) LOGICAL */
/* .TRUE. : update the left transformation matrix Q; */
/* .FALSE.: do not update Q. */
/* WANTZ (input) LOGICAL */
/* .TRUE. : update the right transformation matrix Z; */
/* .FALSE.: do not update Z. */
/* SELECT (input) LOGICAL array, dimension (N) */
/* SELECT specifies the eigenvalues in the selected cluster. */
/* To select a real eigenvalue w(j), SELECT(j) must be set to */
/* 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 matrices A and B. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension(LDA,N) */
/* On entry, the upper quasi-triangular matrix A, with (A, B) in */
/* generalized real Schur canonical form. */
/* On exit, A is overwritten by the reordered matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) DOUBLE PRECISION array, dimension(LDB,N) */
/* On entry, the upper triangular matrix B, with (A, B) in */
/* generalized real Schur canonical form. */
/* On exit, B is overwritten by the reordered matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array 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. ALPHAR(j) + ALPHAI(j)*i */
/* form (S,T) that would result if the 2-by-2 diagonal blocks of */
/* the real generalized Schur form of (A,B) were further reduced */
/* to triangular form using 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. */
/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
/* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. */
/* On exit, Q has been postmultiplied by the left orthogonal */
/* transformation matrix which reorder (A, B); The leading M */
/* columns of Q form orthonormal bases for the specified pair of */
/* left eigenspaces (deflating subspaces). */
/* If WANTQ = .FALSE., Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= 1; */
/* and if WANTQ = .TRUE., LDQ >= N. */
/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
/* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. */
/* On exit, Z has been postmultiplied by the left orthogonal */
/* transformation matrix which reorder (A, B); The leading M */
/* columns of Z form orthonormal bases for the specified pair of */
/* left eigenspaces (deflating subspaces). */
/* If WANTZ = .FALSE., Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1; */
/* If WANTZ = .TRUE., LDZ >= N. */
/* M (output) INTEGER */
/* The dimension of the specified pair of left and right eigen- */
/* spaces (deflating subspaces). 0 <= M <= N. */
/* PL (output) DOUBLE PRECISION */
/* PR (output) DOUBLE PRECISION */
/* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the */
/* reciprocal of the norm of "projections" onto left and right */
/* eigenspaces with respect to the selected cluster. */
/* 0 < PL, PR <= 1. */
/* If M = 0 or M = N, PL = PR = 1. */
/* If IJOB = 0, 2 or 3, PL and PR are not referenced. */
/* DIF (output) DOUBLE PRECISION array, dimension (2). */
/* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. */
/* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on */
/* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based */
/* estimates of Difu and Difl. */
/* If M = 0 or N, DIF(1:2) = F-norm([A, B]). */
/* If IJOB = 0 or 1, DIF 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 >= 4*N+16. */
/* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)). */
/* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*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/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* IF IJOB = 0, IWORK is not referenced. Otherwise, */
/* on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. LIWORK >= 1. */
/* If IJOB = 1, 2 or 4, LIWORK >= N+6. */
/* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6). */
/* 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 (A, B) failed because the transformed */
/* matrix pair (A, B) would be too far from generalized */
/* Schur form; the problem is very ill-conditioned. */
/* (A, B) may have been partially reordered. */
/* If requested, 0 is returned in DIF(*), PL and PR. */
/* Further Details */
/* =============== */
/* DTGSEN first collects the selected eigenvalues by computing */
/* orthogonal U and W that move them to the top left corner of (A, B). */
/* In other words, the selected eigenvalues are the eigenvalues of */
/* (A11, B11) in: */
/* U'*(A, B)*W = (A11 A12) (B11 B12) n1 */
/* ( 0 A22),( 0 B22) n2 */
/* n1 n2 n1 n2 */
/* where N = n1+n2 and U' means the transpose of U. The first n1 columns */
/* of U and W span the specified pair of left and right eigenspaces */
/* (deflating subspaces) of (A, B). */
/* If (A, B) has been obtained from the generalized real Schur */
/* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the */
/* reordered generalized real Schur form of (C, D) is given by */
/* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)', */
/* and the first n1 columns of Q*U and Z*W span the corresponding */
/* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). */
/* Note that if the selected eigenvalue is sufficiently ill-conditioned, */
/* then its value may differ significantly from its value before */
/* reordering. */
/* The reciprocal condition numbers of the left and right eigenspaces */
/* spanned by the first n1 columns of U and W (or Q*U and Z*W) may */
/* be returned in DIF(1:2), corresponding to Difu and Difl, resp. */
/* The Difu and Difl are defined as: */
/* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) */
/* and */
/* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], */
/* where sigma-min(Zu) is the smallest singular value of the */
/* (2*n1*n2)-by-(2*n1*n2) matrix */
/* Zu = [ kron(In2, A11) -kron(A22', In1) ] */
/* [ kron(In2, B11) -kron(B22', In1) ]. */
/* Here, Inx is the identity matrix of size nx and A22' is the */
/* transpose of A22. kron(X, Y) is the Kronecker product between */
/* the matrices X and Y. */
/* When DIF(2) is small, small changes in (A, B) can cause large changes */
/* in the deflating subspace. An approximate (asymptotic) bound on the */
/* maximum angular error in the computed deflating subspaces is */
/* EPS * norm((A, B)) / DIF(2), */
/* where EPS is the machine precision. */
/* The reciprocal norm of the projectors on the left and right */
/* eigenspaces associated with (A11, B11) may be returned in PL and PR. */
/* They are computed as follows. First we compute L and R so that */
/* P*(A, B)*Q is block diagonal, where */
/* P = ( I -L ) n1 Q = ( I R ) n1 */
/* ( 0 I ) n2 and ( 0 I ) n2 */
/* n1 n2 n1 n2 */
/* and (L, R) is the solution to the generalized Sylvester equation */
/* A11*R - L*A22 = -A12 */
/* B11*R - L*B22 = -B12 */
/* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). */
/* An approximate (asymptotic) bound on the average absolute error of */
/* the selected eigenvalues is */
/* EPS * norm((A, B)) / PL. */
/* There are also global error bounds which valid for perturbations up */
/* to a certain restriction: A lower bound (x) on the smallest */
/* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and */
/* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), */
/* (i.e. (A + E, B + F), is */
/* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). */
/* An approximate bound on x can be computed from DIF(1:2), PL and PR. */
/* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed */
/* (L', R') and unperturbed (L, R) left and right deflating subspaces */
/* associated with the selected cluster in the (1,1)-blocks can be */
/* bounded as */
/* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) */
/* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) */
/* See LAPACK User's Guide section 4.11 or the following references */
/* for more information. */
/* Note that if the default method for computing the Frobenius-norm- */
/* based estimate DIF is not wanted (see DLATDF), then the parameter */
/* IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF */
/* (IJOB = 2 will be used)). See DTGSYL for more details. */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* References */
/* ========== */
/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
/* Estimation: Theory, Algorithms and Software, */
/* Report UMINF - 94.04, Department of Computing Science, Umea */
/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */
/* Note 87. To appear in Numerical Algorithms, 1996. */
/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
/* for Solving the Generalized Sylvester Equation and Estimating the */
/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
/* Department of Computing Science, Umea University, S-901 87 Umea, */
/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */
/* 1996. */
/* ===================================================================== */
/* Decode and test the input parameters */
/* Parameter adjustments */
--select;
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;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--dif;
--work;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1 || *liwork == -1;
if (*ijob < 0 || *ijob > 5) {
*info = -1;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldq < 1 || *wantq && *ldq < *n) {
*info = -14;
} else if (*ldz < 1 || *wantz && *ldz < *n) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTGSEN", &i__1);
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
ierr = 0;
wantp = *ijob == 1 || *ijob >= 4;
wantd1 = *ijob == 2 || *ijob == 4;
wantd2 = *ijob == 3 || *ijob == 5;
wantd = wantd1 || wantd2;
/* Set M to the dimension of the specified pair of deflating */
/* subspaces. */
*m = 0;
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (pair) {
pair = FALSE_;
} else {
if (k < *n) {
if (a[k + 1 + k * a_dim1] == 0.) {
if (select[k]) {
++(*m);
}
} else {
pair = TRUE_;
if (select[k] || select[k + 1]) {
*m += 2;
}
}
} else {
if (select[*n]) {
++(*m);
}
}
}
}
if (*ijob == 1 || *ijob == 2 || *ijob == 4) {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), i__2 = (*m <<
1) * (*n - *m);
lwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = *n + 6;
liwmin = max(i__1,i__2);
} else if (*ijob == 3 || *ijob == 5) {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), i__2 = (*m <<
2) * (*n - *m);
lwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = max(i__1,i__2), i__2 =
*n + 6;
liwmin = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16;
lwmin = max(i__1,i__2);
liwmin = 1;
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -22;
} else if (*liwork < liwmin && ! lquery) {
*info = -24;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTGSEN", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible. */
if (*m == *n || *m == 0) {
if (wantp) {
*pl = 1.;
*pr = 1.;
}
if (wantd) {
dscale = 0.;
dsum = 1.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
dlassq_(n, &a[i__ * a_dim1 + 1], &c__1, &dscale, &dsum);
dlassq_(n, &b[i__ * b_dim1 + 1], &c__1, &dscale, &dsum);
}
dif[1] = dscale * sqrt(dsum);
dif[2] = dif[1];
}
goto L60;
}
/* Collect the selected blocks at the top-left corner of (A, B). */
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 (a[k + 1 + k * a_dim1] != 0.) {
pair = TRUE_;
swap = swap || select[k + 1];
}
}
if (swap) {
++ks;
/* Swap the K-th block to position KS. */
/* Perform the reordering of diagonal blocks in (A, B) */
/* by orthogonal transformation matrices and update */
/* Q and Z accordingly (if requested): */
kk = k;
if (k != ks) {
dtgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &kk,
&ks, &work[1], lwork, &ierr);
}
if (ierr > 0) {
/* Swap is rejected: exit. */
*info = 1;
if (wantp) {
*pl = 0.;
*pr = 0.;
}
if (wantd) {
dif[1] = 0.;
dif[2] = 0.;
}
goto L60;
}
if (pair) {
++ks;
}
}
}
}
if (wantp) {
/* Solve generalized Sylvester equation for R and L */
/* and compute PL and PR. */
n1 = *m;
n2 = *n - *m;
i__ = n1 + 1;
ijb = 0;
dlacpy_("Full", &n1, &n2, &a[i__ * a_dim1 + 1], lda, &work[1], &n1);
dlacpy_("Full", &n1, &n2, &b[i__ * b_dim1 + 1], ldb, &work[n1 * n2 +
1], &n1);
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * a_dim1]
, lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + i__ *
b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], &
work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr);
/* Estimate the reciprocal of norms of "projections" onto left */
/* and right eigenspaces. */
rdscal = 0.;
dsum = 1.;
i__1 = n1 * n2;
dlassq_(&i__1, &work[1], &c__1, &rdscal, &dsum);
*pl = rdscal * sqrt(dsum);
if (*pl == 0.) {
*pl = 1.;
} else {
*pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl));
}
rdscal = 0.;
dsum = 1.;
i__1 = n1 * n2;
dlassq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum);
*pr = rdscal * sqrt(dsum);
if (*pr == 0.) {
*pr = 1.;
} else {
*pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr));
}
}
if (wantd) {
/* Compute estimates of Difu and Difl. */
if (wantd1) {
n1 = *m;
n2 = *n - *m;
i__ = n1 + 1;
ijb = 3;
/* Frobenius norm-based Difu-estimate. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ *
a_dim1], lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ +
i__ * b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &
dif[1], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], &
ierr);
/* Frobenius norm-based Difl-estimate. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, &a[
a_offset], lda, &work[1], &n2, &b[i__ + i__ * b_dim1],
ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &dscale,
&dif[2], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], &
ierr);
} else {
/* Compute 1-norm-based estimates of Difu and Difl using */
/* reversed communication with DLACN2. In each step a */
/* generalized Sylvester equation or a transposed variant */
/* is solved. */
kase = 0;
n1 = *m;
n2 = *n - *m;
i__ = n1 + 1;
ijb = 0;
mn2 = (n1 << 1) * n2;
/* 1-norm-based estimate of Difu. */
L40:
dlacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[1], &kase,
isave);
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr);
} else {
/* Solve the transposed variant. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("T", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr);
}
goto L40;
}
dif[1] = dscale / dif[1];
/* 1-norm-based estimate of Difl. */
L50:
dlacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[2], &kase,
isave);
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
&a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr);
} else {
/* Solve the transposed variant. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("T", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
&a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr);
}
goto L50;
}
dif[2] = dscale / dif[2];
}
}
L60:
/* Compute generalized eigenvalues of reordered pair (A, B) and */
/* normalize the generalized Schur form. */
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (pair) {
pair = FALSE_;
} else {
if (k < *n) {
if (a[k + 1 + k * a_dim1] != 0.) {
pair = TRUE_;
}
}
if (pair) {
/* Compute the eigenvalue(s) at position K. */
work[1] = a[k + k * a_dim1];
work[2] = a[k + 1 + k * a_dim1];
work[3] = a[k + (k + 1) * a_dim1];
work[4] = a[k + 1 + (k + 1) * a_dim1];
work[5] = b[k + k * b_dim1];
work[6] = b[k + 1 + k * b_dim1];
work[7] = b[k + (k + 1) * b_dim1];
work[8] = b[k + 1 + (k + 1) * b_dim1];
d__1 = smlnum * eps;
dlag2_(&work[1], &c__2, &work[5], &c__2, &d__1, &beta[k], &
beta[k + 1], &alphar[k], &alphar[k + 1], &alphai[k]);
alphai[k + 1] = -alphai[k];
} else {
if (d_sign(&c_b28, &b[k + k * b_dim1]) < 0.) {
/* If B(K,K) is negative, make it positive */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
a[k + i__ * a_dim1] = -a[k + i__ * a_dim1];
b[k + i__ * b_dim1] = -b[k + i__ * b_dim1];
if (*wantq) {
q[i__ + k * q_dim1] = -q[i__ + k * q_dim1];
}
}
}
alphar[k] = a[k + k * a_dim1];
alphai[k] = 0.;
beta[k] = b[k + k * b_dim1];
}
}
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
return 0;
/* End of DTGSEN */
} /* dtgsen_ */
doublereal dlangt_(char *norm, integer *n, doublereal *dl, doublereal *d__,
doublereal *du, ftnlen norm_len)
{
/* System generated locals */
integer i__1;
doublereal ret_val, d__1, d__2, d__3, d__4, d__5;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__;
static doublereal sum, scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static doublereal anorm;
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *);
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLANGT returns the value of the one norm, or the Frobenius norm, or */
/* the infinity norm, or the element of largest absolute value of a */
/* real tridiagonal matrix A. */
/* Description */
/* =========== */
/* DLANGT returns the value */
/* DLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum), */
/* normI denotes the infinity norm of a matrix (maximum row sum) and */
/* normF denotes the Frobenius norm of a matrix (square root of sum of */
/* squares). Note that max(abs(A(i,j))) is not a matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in DLANGT as described */
/* above. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, DLANGT is */
/* set to zero. */
/* DL (input) DOUBLE PRECISION array, dimension (N-1) */
/* The (n-1) sub-diagonal elements of A. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The diagonal elements of A. */
/* DU (input) DOUBLE PRECISION array, dimension (N-1) */
/* The (n-1) super-diagonal elements of A. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--du;
--d__;
--dl;
/* Function Body */
if (*n <= 0) {
anorm = 0.;
} else if (lsame_(norm, "M", (ftnlen)1, (ftnlen)1)) {
/* Find max(abs(A(i,j))). */
anorm = (d__1 = d__[*n], abs(d__1));
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = dl[i__], abs(d__1));
anorm = max(d__2,d__3);
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = d__[i__], abs(d__1));
anorm = max(d__2,d__3);
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = du[i__], abs(d__1));
anorm = max(d__2,d__3);
/* L10: */
}
} else if (lsame_(norm, "O", (ftnlen)1, (ftnlen)1) || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
if (*n == 1) {
anorm = abs(d__[1]);
} else {
/* Computing MAX */
d__3 = abs(d__[1]) + abs(dl[1]), d__4 = (d__1 = d__[*n], abs(d__1)
) + (d__2 = du[*n - 1], abs(d__2));
anorm = max(d__3,d__4);
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
d__4 = anorm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 =
dl[i__], abs(d__2)) + (d__3 = du[i__ - 1], abs(d__3));
anorm = max(d__4,d__5);
/* L20: */
}
}
} else if (lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) {
/* Find normI(A). */
if (*n == 1) {
anorm = abs(d__[1]);
} else {
/* Computing MAX */
d__3 = abs(d__[1]) + abs(du[1]), d__4 = (d__1 = d__[*n], abs(d__1)
) + (d__2 = dl[*n - 1], abs(d__2));
anorm = max(d__3,d__4);
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
d__4 = anorm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 =
du[i__], abs(d__2)) + (d__3 = dl[i__ - 1], abs(d__3));
anorm = max(d__4,d__5);
/* L30: */
}
}
} else if (lsame_(norm, "F", (ftnlen)1, (ftnlen)1) || lsame_(norm, "E", (
ftnlen)1, (ftnlen)1)) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
dlassq_(n, &d__[1], &c__1, &scale, &sum);
if (*n > 1) {
i__1 = *n - 1;
dlassq_(&i__1, &dl[1], &c__1, &scale, &sum);
i__1 = *n - 1;
dlassq_(&i__1, &du[1], &c__1, &scale, &sum);
}
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of DLANGT */
} /* dlangt_ */
/* ===================================================================== */
doublereal dlansp_(char *norm, char *uplo, integer *n, doublereal *ap, doublereal *work)
{
/* System generated locals */
integer i__1, i__2;
doublereal ret_val, d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k;
doublereal sum, absa, scale;
extern logical lsame_(char *, char *);
doublereal value;
extern logical disnan_(doublereal *);
extern /* Subroutine */
int dlassq_(integer *, doublereal *, integer *, doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--work;
--ap;
/* Function Body */
if (*n == 0)
{
value = 0.;
}
else if (lsame_(norm, "M"))
{
/* Find max(abs(A(i,j))). */
value = 0.;
if (lsame_(uplo, "U"))
{
k = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = k + j - 1;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum = (d__1 = ap[i__], abs(d__1));
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L10: */
}
k += j;
/* L20: */
}
}
else
{
k = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = k + *n - j;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum = (d__1 = ap[i__], abs(d__1));
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L30: */
}
k = k + *n - j + 1;
/* L40: */
}
}
}
else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1')
{
/* Find normI(A) ( = norm1(A), since A is symmetric). */
value = 0.;
k = 1;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
sum = 0.;
i__2 = j - 1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
absa = (d__1 = ap[k], abs(d__1));
sum += absa;
work[i__] += absa;
++k;
/* L50: */
}
work[j] = sum + (d__1 = ap[k], abs(d__1));
++k;
/* L60: */
}
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
sum = work[i__];
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L70: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.;
/* L80: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
sum = work[j] + (d__1 = ap[k], abs(d__1));
++k;
i__2 = *n;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
absa = (d__1 = ap[k], abs(d__1));
sum += absa;
work[i__] += absa;
++k;
/* L90: */
}
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L100: */
}
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
scale = 0.;
sum = 1.;
k = 2;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 2;
j <= i__1;
++j)
{
i__2 = j - 1;
dlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k += j;
/* L110: */
}
}
else
{
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j;
dlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k = k + *n - j + 1;
/* L120: */
}
}
sum *= 2;
k = 1;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (ap[k] != 0.)
{
absa = (d__1 = ap[k], abs(d__1));
if (scale < absa)
{
/* Computing 2nd power */
d__1 = scale / absa;
sum = sum * (d__1 * d__1) + 1.;
scale = absa;
}
else
{
/* Computing 2nd power */
d__1 = absa / scale;
sum += d__1 * d__1;
}
}
if (lsame_(uplo, "U"))
{
k = k + i__ + 1;
}
else
{
k = k + *n - i__ + 1;
}
/* L130: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANSP */
}
doublereal zlanht_(char *norm, integer *n, doublereal *d__, doublecomplex *e)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1992
Purpose
=======
ZLANHT returns the value of the one norm, or the Frobenius norm, or
the infinity norm, or the element of largest absolute value of a
complex Hermitian tridiagonal matrix A.
Description
===========
ZLANHT returns the value
ZLANHT = ( max(abs(A(i,j))), NORM = 'M' or 'm'
(
( norm1(A), NORM = '1', 'O' or 'o'
(
( normI(A), NORM = 'I' or 'i'
(
( normF(A), NORM = 'F', 'f', 'E' or 'e'
where norm1 denotes the one norm of a matrix (maximum column sum),
normI denotes the infinity norm of a matrix (maximum row sum) and
normF denotes the Frobenius norm of a matrix (square root of sum of
squares). Note that max(abs(A(i,j))) is not a matrix norm.
Arguments
=========
NORM (input) CHARACTER*1
Specifies the value to be returned in ZLANHT as described
above.
N (input) INTEGER
The order of the matrix A. N >= 0. When N = 0, ZLANHT is
set to zero.
D (input) DOUBLE PRECISION array, dimension (N)
The diagonal elements of A.
E (input) COMPLEX*16 array, dimension (N-1)
The (n-1) sub-diagonal or super-diagonal elements of A.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer i__1;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static integer i__;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal anorm;
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *), zlassq_(integer *, doublecomplex *,
integer *, doublereal *, doublereal *);
static doublereal sum;
--e;
--d__;
/* Function Body */
if (*n <= 0) {
anorm = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
anorm = (d__1 = d__[*n], abs(d__1));
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = d__[i__], abs(d__1));
anorm = max(d__2,d__3);
/* Computing MAX */
d__1 = anorm, d__2 = z_abs(&e[i__]);
anorm = max(d__1,d__2);
/* L10: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1' || lsame_(norm, "I")) {
/* Find norm1(A). */
if (*n == 1) {
anorm = abs(d__[1]);
} else {
/* Computing MAX */
d__2 = abs(d__[1]) + z_abs(&e[1]), d__3 = z_abs(&e[*n - 1]) + (
d__1 = d__[*n], abs(d__1));
anorm = max(d__2,d__3);
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = d__[i__], abs(d__1)) + z_abs(&e[
i__]) + z_abs(&e[i__ - 1]);
anorm = max(d__2,d__3);
/* L20: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
if (*n > 1) {
i__1 = *n - 1;
zlassq_(&i__1, &e[1], &c__1, &scale, &sum);
sum *= 2;
}
dlassq_(n, &d__[1], &c__1, &scale, &sum);
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of ZLANHT */
} /* zlanht_ */
/* ===================================================================== */
doublereal dlangb_(char *norm, integer *n, integer *kl, integer *ku, doublereal *ab, integer *ldab, doublereal *work)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal ret_val, d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k, l;
doublereal sum, temp, scale;
extern logical lsame_(char *, char *);
doublereal value;
extern logical disnan_(doublereal *);
extern /* Subroutine */
int dlassq_(integer *, doublereal *, integer *, doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--work;
/* Function Body */
if (*n == 0)
{
value = 0.;
}
else if (lsame_(norm, "M"))
{
/* Find max(abs(A(i,j))). */
value = 0.;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MAX */
i__2 = *ku + 2 - j;
/* Computing MIN */
i__4 = *n + *ku + 1 - j;
i__5 = *kl + *ku + 1; // , expr subst
i__3 = min(i__4,i__5);
for (i__ = max(i__2,1);
i__ <= i__3;
++i__)
{
temp = (d__1 = ab[i__ + j * ab_dim1], abs(d__1));
if (value < temp || disnan_(&temp))
{
value = temp;
}
/* L10: */
}
/* L20: */
}
}
else if (lsame_(norm, "O") || *(unsigned char *) norm == '1')
{
/* Find norm1(A). */
value = 0.;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
sum = 0.;
/* Computing MAX */
i__3 = *ku + 2 - j;
/* Computing MIN */
i__4 = *n + *ku + 1 - j;
i__5 = *kl + *ku + 1; // , expr subst
i__2 = min(i__4,i__5);
for (i__ = max(i__3,1);
i__ <= i__2;
++i__)
{
sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1));
/* L30: */
}
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L40: */
}
}
else if (lsame_(norm, "I"))
{
/* Find normI(A). */
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.;
/* L50: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
k = *ku + 1 - j;
/* Computing MAX */
i__2 = 1;
i__3 = j - *ku; // , expr subst
/* Computing MIN */
i__5 = *n;
i__6 = j + *kl; // , expr subst
i__4 = min(i__5,i__6);
for (i__ = max(i__2,i__3);
i__ <= i__4;
++i__)
{
work[i__] += (d__1 = ab[k + i__ + j * ab_dim1], abs(d__1));
/* L60: */
}
/* L70: */
}
value = 0.;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
temp = work[i__];
if (value < temp || disnan_(&temp))
{
value = temp;
}
/* L80: */
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MAX */
i__4 = 1;
i__2 = j - *ku; // , expr subst
l = max(i__4,i__2);
k = *ku + 1 - j + l;
/* Computing MIN */
i__2 = *n;
i__3 = j + *kl; // , expr subst
i__4 = min(i__2,i__3) - l + 1;
dlassq_(&i__4, &ab[k + j * ab_dim1], &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANGB */
}
doublereal dlanhs_(char *norm, integer *n, doublereal *a, integer *lda,
doublereal *work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal ret_val, d__1, d__2, d__3;
/* Local variables */
integer i__, j;
doublereal sum, scale;
doublereal value;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DLANHS returns the value of the one norm, or the Frobenius norm, or */
/* the infinity norm, or the element of largest absolute value of a */
/* Hessenberg matrix A. */
/* Description */
/* =========== */
/* DLANHS returns the value */
/* DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum), */
/* normI denotes the infinity norm of a matrix (maximum row sum) and */
/* normF denotes the Frobenius norm of a matrix (square root of sum of */
/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in DLANHS as described */
/* above. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, DLANHS is */
/* set to zero. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The n by n upper Hessenberg matrix A; the part of A below the */
/* first sub-diagonal is not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(N,1). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* ===================================================================== */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
/* Function Body */
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
value = max(d__2,d__3);
}
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
}
value = max(value,sum);
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
}
}
value = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANHS */
} /* dlanhs_ */
doublereal dlansb_(char *norm, char *uplo, integer *n, integer *k, doublereal
*ab, integer *ldab, doublereal *work)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, l;
doublereal sum, absa, scale;
extern logical lsame_(char *, char *);
doublereal value;
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLANSB returns the value of the one norm, or the Frobenius norm, or */
/* the infinity norm, or the element of largest absolute value of an */
/* n by n symmetric band matrix A, with k super-diagonals. */
/* Description */
/* =========== */
/* DLANSB returns the value */
/* DLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum), */
/* normI denotes the infinity norm of a matrix (maximum row sum) and */
/* normF denotes the Frobenius norm of a matrix (square root of sum of */
/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in DLANSB as described */
/* above. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* band matrix A is supplied. */
/* = 'U': Upper triangular part is supplied */
/* = 'L': Lower triangular part is supplied */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, DLANSB is */
/* set to zero. */
/* K (input) INTEGER */
/* The number of super-diagonals or sub-diagonals of the */
/* band matrix A. K >= 0. */
/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
/* The upper or lower triangle of the symmetric band matrix A, */
/* stored in the first K+1 rows of AB. The j-th column of A is */
/* stored in the j-th column of the array AB as follows: */
/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= K+1. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
/* WORK is not referenced. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--work;
/* Function Body */
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k + 1;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], abs(
d__1));
value = max(d__2,d__3);
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *n + 1 - j, i__4 = *k + 1;
i__3 = min(i__2,i__4);
for (i__ = 1; i__ <= i__3; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], abs(
d__1));
value = max(d__2,d__3);
/* L30: */
}
/* L40: */
}
}
} else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
/* Find normI(A) ( = norm1(A), since A is symmetric). */
value = 0.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
l = *k + 1 - j;
/* Computing MAX */
i__3 = 1, i__2 = j - *k;
i__4 = j - 1;
for (i__ = max(i__3,i__2); i__ <= i__4; ++i__) {
absa = (d__1 = ab[l + i__ + j * ab_dim1], abs(d__1));
sum += absa;
work[i__] += absa;
/* L50: */
}
work[j] = sum + (d__1 = ab[*k + 1 + j * ab_dim1], abs(d__1));
/* L60: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L70: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L80: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = work[j] + (d__1 = ab[j * ab_dim1 + 1], abs(d__1));
l = 1 - j;
/* Computing MIN */
i__3 = *n, i__2 = j + *k;
i__4 = min(i__3,i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) {
absa = (d__1 = ab[l + i__ + j * ab_dim1], abs(d__1));
sum += absa;
work[i__] += absa;
/* L90: */
}
value = max(value,sum);
/* L100: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
if (*k > 0) {
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j - 1;
i__4 = min(i__3,*k);
/* Computing MAX */
i__2 = *k + 2 - j;
dlassq_(&i__4, &ab[max(i__2, 1)+ j * ab_dim1], &c__1, &
scale, &sum);
/* L110: */
}
l = *k + 1;
} else {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n - j;
i__4 = min(i__3,*k);
dlassq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, &scale, &sum);
/* L120: */
}
l = 1;
}
sum *= 2;
} else {
l = 1;
}
dlassq_(n, &ab[l + ab_dim1], ldab, &scale, &sum);
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANSB */
} /* dlansb_ */
/* Subroutine */ int dlatdf_(integer *ijob, integer *n, doublereal *z__,
integer *ldz, doublereal *rhs, doublereal *rdsum, doublereal *rdscal,
integer *ipiv, integer *jpiv)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
DLATDF uses the LU factorization of the n-by-n matrix Z computed by
DGETC2 and computes a contribution to the reciprocal Dif-estimate
by solving Z * x = b for x, and choosing the r.h.s. b such that
the norm of x is as large as possible. On entry RHS = b holds the
contribution from earlier solved sub-systems, and on return RHS = x.
The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q,
where P and Q are permutation matrices. L is lower triangular with
unit diagonal elements and U is upper triangular.
Arguments
=========
IJOB (input) INTEGER
IJOB = 2: First compute an approximative null-vector e
of Z using DGECON, e is normalized and solve for
Zx = +-e - f with the sign giving the greater value
of 2-norm(x). About 5 times as expensive as Default.
IJOB .ne. 2: Local look ahead strategy where all entries of
the r.h.s. b is choosen as either +1 or -1 (Default).
N (input) INTEGER
The number of columns of the matrix Z.
Z (input) DOUBLE PRECISION array, dimension (LDZ, N)
On entry, the LU part of the factorization of the n-by-n
matrix Z computed by DGETC2: Z = P * L * U * Q
LDZ (input) INTEGER
The leading dimension of the array Z. LDA >= max(1, N).
RHS (input/output) DOUBLE PRECISION array, dimension N.
On entry, RHS contains contributions from other subsystems.
On exit, RHS contains the solution of the subsystem with
entries acoording to the value of IJOB (see above).
RDSUM (input/output) DOUBLE PRECISION
On entry, the sum of squares of computed contributions to
the Dif-estimate under computation by DTGSYL, where the
scaling factor RDSCAL (see below) has been factored out.
On exit, the corresponding sum of squares updated with the
contributions from the current sub-system.
If TRANS = 'T' RDSUM is not touched.
NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL.
RDSCAL (input/output) DOUBLE PRECISION
On entry, scaling factor used to prevent overflow in RDSUM.
On exit, RDSCAL is updated w.r.t. the current contributions
in RDSUM.
If TRANS = 'T', RDSCAL is not touched.
NOTE: RDSCAL only makes sense when DTGSY2 is called by
DTGSYL.
IPIV (input) INTEGER array, dimension (N).
The pivot indices; for 1 <= i <= N, row i of the
matrix has been interchanged with row IPIV(i).
JPIV (input) INTEGER array, dimension (N).
The pivot indices; for 1 <= j <= N, column j of the
matrix has been interchanged with column JPIV(j).
Further Details
===============
Based on contributions by
Bo Kagstrom and Peter Poromaa, Department of Computing Science,
Umea University, S-901 87 Umea, Sweden.
This routine is a further developed implementation of algorithm
BSOLVE in [1] using complete pivoting in the LU factorization.
[1] Bo Kagstrom and Lars Westin,
Generalized Schur Methods with Condition Estimators for
Solving the Generalized Sylvester Equation, IEEE Transactions
on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.
[2] Peter Poromaa,
On Efficient and Robust Estimators for the Separation
between two Regular Matrix Pairs with Applications in
Condition Estimation. Report IMINF-95.05, Departement of
Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b23 = 1.;
static doublereal c_b37 = -1.;
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer info;
static doublereal temp, work[32];
static integer i__, j, k;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern doublereal dasum_(integer *, doublereal *, integer *);
static doublereal pmone;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static doublereal sminu;
static integer iwork[8];
static doublereal splus;
extern /* Subroutine */ int dgesc2_(integer *, doublereal *, integer *,
doublereal *, integer *, integer *, doublereal *);
static doublereal bm, bp;
extern /* Subroutine */ int dgecon_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
integer *);
static doublereal xm[8], xp[8];
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *), dlaswp_(integer *, doublereal *,
integer *, integer *, integer *, integer *, integer *);
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--rhs;
--ipiv;
--jpiv;
/* Function Body */
if (*ijob != 2) {
/* Apply permutations IPIV to RHS */
i__1 = *n - 1;
dlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1);
/* Solve for L-part choosing RHS either to +1 or -1. */
pmone = -1.;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
bp = rhs[j] + 1.;
bm = rhs[j] - 1.;
splus = 1.;
/* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and
SMIN computed more efficiently than in BSOLVE [1]. */
i__2 = *n - j;
splus += ddot_(&i__2, &z___ref(j + 1, j), &c__1, &z___ref(j + 1,
j), &c__1);
i__2 = *n - j;
sminu = ddot_(&i__2, &z___ref(j + 1, j), &c__1, &rhs[j + 1], &
c__1);
splus *= rhs[j];
if (splus > sminu) {
rhs[j] = bp;
} else if (sminu > splus) {
rhs[j] = bm;
} else {
/* In this case the updating sums are equal and we can
choose RHS(J) +1 or -1. The first time this happens
we choose -1, thereafter +1. This is a simple way to
get good estimates of matrices like Byers well-known
example (see [1]). (Not done in BSOLVE.) */
rhs[j] += pmone;
pmone = 1.;
}
/* Compute the remaining r.h.s. */
temp = -rhs[j];
i__2 = *n - j;
daxpy_(&i__2, &temp, &z___ref(j + 1, j), &c__1, &rhs[j + 1], &
c__1);
/* L10: */
}
/* Solve for U-part, look-ahead for RHS(N) = +-1. This is not done
in BSOLVE and will hopefully give us a better estimate because
any ill-conditioning of the original matrix is transfered to U
and not to L. U(N, N) is an approximation to sigma_min(LU). */
i__1 = *n - 1;
dcopy_(&i__1, &rhs[1], &c__1, xp, &c__1);
xp[*n - 1] = rhs[*n] + 1.;
rhs[*n] += -1.;
splus = 0.;
sminu = 0.;
for (i__ = *n; i__ >= 1; --i__) {
temp = 1. / z___ref(i__, i__);
xp[i__ - 1] *= temp;
rhs[i__] *= temp;
i__1 = *n;
for (k = i__ + 1; k <= i__1; ++k) {
xp[i__ - 1] -= xp[k - 1] * (z___ref(i__, k) * temp);
rhs[i__] -= rhs[k] * (z___ref(i__, k) * temp);
/* L20: */
}
splus += (d__1 = xp[i__ - 1], abs(d__1));
sminu += (d__1 = rhs[i__], abs(d__1));
/* L30: */
}
if (splus > sminu) {
dcopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Apply the permutations JPIV to the computed solution (RHS) */
i__1 = *n - 1;
dlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1);
/* Compute the sum of squares */
dlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
} else {
/* IJOB = 2, Compute approximate nullvector XM of Z */
dgecon_("I", n, &z__[z_offset], ldz, &c_b23, &temp, work, iwork, &
info);
dcopy_(n, &work[*n], &c__1, xm, &c__1);
/* Compute RHS */
i__1 = *n - 1;
dlaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1);
temp = 1. / sqrt(ddot_(n, xm, &c__1, xm, &c__1));
dscal_(n, &temp, xm, &c__1);
dcopy_(n, xm, &c__1, xp, &c__1);
daxpy_(n, &c_b23, &rhs[1], &c__1, xp, &c__1);
daxpy_(n, &c_b37, xm, &c__1, &rhs[1], &c__1);
dgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &temp);
dgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &temp);
if (dasum_(n, xp, &c__1) > dasum_(n, &rhs[1], &c__1)) {
dcopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Compute the sum of squares */
dlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
}
return 0;
/* End of DLATDF */
} /* dlatdf_ */
double dlange_(char *norm, int *m, int *n, double *a, int
*lda, double *work)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
DLANGE returns the value of the one norm, or the Frobenius norm, or
the infinity norm, or the element of largest absolute value of a
real matrix A.
Description
===========
DLANGE returns the value
DLANGE = ( MAX(ABS(A(i,j))), NORM = 'M' or 'm'
(
( norm1(A), NORM = '1', 'O' or 'o'
(
( normI(A), NORM = 'I' or 'i'
(
( normF(A), NORM = 'F', 'f', 'E' or 'e'
where norm1 denotes the one norm of a matrix (maximum column sum),
normI denotes the infinity norm of a matrix (maximum row sum) and
normF denotes the Frobenius norm of a matrix (square root of sum of
squares). Note that MAX(ABS(A(i,j))) is not a matrix norm.
Arguments
=========
NORM (input) CHARACTER*1
Specifies the value to be returned in DLANGE as described
above.
M (input) INT
The number of rows of the matrix A. M >= 0. When M = 0,
DLANGE is set to zero.
N (input) INT
The number of columns of the matrix A. N >= 0. When N = 0,
DLANGE is set to zero.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
The m by n matrix A.
LDA (input) INT
The leading dimension of the array A. LDA >= MAX(M,1).
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK),
where LWORK >= M when NORM = 'I'; otherwise, WORK is not
referenced.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static int c__1 = 1;
/* System generated locals */
int i__1, i__2;
double ret_val, d__1, d__2, d__3;
/* Builtin functions */
/* Local variables */
static int i, j;
static double scale;
extern long int lsame_(char *, char *);
static double value;
extern /* Subroutine */ int dlassq_(int *, double *, int *,
double *, double *);
static double sum;
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
if (MIN(*m,*n) == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find MAX(ABS(A(i,j))). */
value = 0.;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = *m;
for (i = 1; i <= *m; ++i) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = A(i,j), ABS(d__1));
value = MAX(d__2,d__3);
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)norm == '1') {
/* Find norm1(A). */
value = 0.;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
sum = 0.;
i__2 = *m;
for (i = 1; i <= *m; ++i) {
sum += (d__1 = A(i,j), ABS(d__1));
/* L30: */
}
value = MAX(value,sum);
/* L40: */
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
i__1 = *m;
for (i = 1; i <= *m; ++i) {
WORK(i) = 0.;
/* L50: */
}
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = *m;
for (i = 1; i <= *m; ++i) {
WORK(i) += (d__1 = A(i,j), ABS(d__1));
/* L60: */
}
/* L70: */
}
value = 0.;
i__1 = *m;
for (i = 1; i <= *m; ++i) {
/* Computing MAX */
d__1 = value, d__2 = WORK(i);
value = MAX(d__1,d__2);
/* L80: */
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
dlassq_(m, &A(1,j), &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANGE */
} /* dlange_ */
doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer
*lda, doublereal *work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
doublereal sum, scale;
extern logical lsame_(char *, char *);
doublereal value;
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLANGE returns the value of the one norm, or the Frobenius norm, or */
/* the infinity norm, or the element of largest absolute value of a */
/* real matrix A. */
/* Description */
/* =========== */
/* DLANGE returns the value */
/* DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum), */
/* normI denotes the infinity norm of a matrix (maximum row sum) and */
/* normF denotes the Frobenius norm of a matrix (square root of sum of */
/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in DLANGE as described */
/* above. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. When M = 0, */
/* DLANGE is set to zero. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. When N = 0, */
/* DLANGE is set to zero. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The m by n matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(M,1). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
/* Function Body */
if (min(*m,*n) == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
value = max(d__2,d__3);
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L30: */
}
value = max(value,sum);
/* L40: */
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L50: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L60: */
}
/* L70: */
}
value = 0.;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L80: */
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANGE */
} /* dlange_ */
doublereal dlantr_(char *norm, char *uplo, char *diag, integer *m, integer *n,
doublereal *a, integer *lda, doublereal *work)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
DLANTR returns the value of the one norm, or the Frobenius norm, or
the infinity norm, or the element of largest absolute value of a
trapezoidal or triangular matrix A.
Description
===========
DLANTR returns the value
DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'
(
( norm1(A), NORM = '1', 'O' or 'o'
(
( normI(A), NORM = 'I' or 'i'
(
( normF(A), NORM = 'F', 'f', 'E' or 'e'
where norm1 denotes the one norm of a matrix (maximum column sum),
normI denotes the infinity norm of a matrix (maximum row sum) and
normF denotes the Frobenius norm of a matrix (square root of sum of
squares). Note that max(abs(A(i,j))) is not a matrix norm.
Arguments
=========
NORM (input) CHARACTER*1
Specifies the value to be returned in DLANTR as described
above.
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower trapezoidal.
= 'U': Upper trapezoidal
= 'L': Lower trapezoidal
Note that A is triangular instead of trapezoidal if M = N.
DIAG (input) CHARACTER*1
Specifies whether or not the matrix A has unit diagonal.
= 'N': Non-unit diagonal
= 'U': Unit diagonal
M (input) INTEGER
The number of rows of the matrix A. M >= 0, and if
UPLO = 'U', M <= N. When M = 0, DLANTR is set to zero.
N (input) INTEGER
The number of columns of the matrix A. N >= 0, and if
UPLO = 'L', N <= M. When N = 0, DLANTR is set to zero.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
The trapezoidal matrix A (A is triangular if M = N).
If UPLO = 'U', the leading m by n upper trapezoidal part of
the array A contains the upper trapezoidal matrix, and the
strictly lower triangular part of A is not referenced.
If UPLO = 'L', the leading m by n lower trapezoidal part of
the array A contains the lower trapezoidal matrix, and the
strictly upper triangular part of A is not referenced. Note
that when DIAG = 'U', the diagonal elements of A are not
referenced and are assumed to be one.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(M,1).
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK),
where LWORK >= M when NORM = 'I'; otherwise, WORK is not
referenced.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i, j;
static doublereal scale;
static logical udiag;
extern logical lsame_(char *, char *);
static doublereal value;
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *);
static doublereal sum;
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
if (min(*m,*n) == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
if (lsame_(diag, "U")) {
value = 1.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
/* Computing MIN */
i__3 = *m, i__4 = j - 1;
i__2 = min(i__3,i__4);
for (i = 1; i <= min(*m,j-1); ++i) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = A(i,j), abs(
d__1));
value = max(d__2,d__3);
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = *m;
for (i = j + 1; i <= *m; ++i) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = A(i,j), abs(
d__1));
value = max(d__2,d__3);
/* L30: */
}
/* L40: */
}
}
} else {
value = 0.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = min(*m,j);
for (i = 1; i <= min(*m,j); ++i) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = A(i,j), abs(
d__1));
value = max(d__2,d__3);
/* L50: */
}
/* L60: */
}
} else {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = *m;
for (i = j; i <= *m; ++i) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = A(i,j), abs(
d__1));
value = max(d__2,d__3);
/* L70: */
}
/* L80: */
}
}
}
} else if (lsame_(norm, "O") || *(unsigned char *)norm == '1') {
/* Find norm1(A). */
value = 0.;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
if (udiag && j <= *m) {
sum = 1.;
i__2 = j - 1;
for (i = 1; i <= j-1; ++i) {
sum += (d__1 = A(i,j), abs(d__1));
/* L90: */
}
} else {
sum = 0.;
i__2 = min(*m,j);
for (i = 1; i <= min(*m,j); ++i) {
sum += (d__1 = A(i,j), abs(d__1));
/* L100: */
}
}
value = max(value,sum);
/* L110: */
}
} else {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
if (udiag) {
sum = 1.;
i__2 = *m;
for (i = j + 1; i <= *m; ++i) {
sum += (d__1 = A(i,j), abs(d__1));
/* L120: */
}
} else {
sum = 0.;
i__2 = *m;
for (i = j; i <= *m; ++i) {
sum += (d__1 = A(i,j), abs(d__1));
/* L130: */
}
}
value = max(value,sum);
/* L140: */
}
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
i__1 = *m;
for (i = 1; i <= *m; ++i) {
WORK(i) = 1.;
/* L150: */
}
i__1 = *n;
for (j = 1; j <= *n; ++j) {
/* Computing MIN */
i__3 = *m, i__4 = j - 1;
i__2 = min(i__3,i__4);
for (i = 1; i <= min(*m,j-1); ++i) {
WORK(i) += (d__1 = A(i,j), abs(d__1));
/* L160: */
}
/* L170: */
}
} else {
i__1 = *m;
for (i = 1; i <= *m; ++i) {
WORK(i) = 0.;
/* L180: */
}
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = min(*m,j);
for (i = 1; i <= min(*m,j); ++i) {
WORK(i) += (d__1 = A(i,j), abs(d__1));
/* L190: */
}
/* L200: */
}
}
} else {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i = 1; i <= *n; ++i) {
WORK(i) = 1.;
/* L210: */
}
i__1 = *m;
for (i = *n + 1; i <= *m; ++i) {
WORK(i) = 0.;
/* L220: */
}
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = *m;
for (i = j + 1; i <= *m; ++i) {
WORK(i) += (d__1 = A(i,j), abs(d__1));
/* L230: */
}
/* L240: */
}
} else {
i__1 = *m;
for (i = 1; i <= *m; ++i) {
WORK(i) = 0.;
/* L250: */
}
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = *m;
for (i = j; i <= *m; ++i) {
WORK(i) += (d__1 = A(i,j), abs(d__1));
/* L260: */
}
/* L270: */
}
}
}
value = 0.;
i__1 = *m;
for (i = 1; i <= *m; ++i) {
/* Computing MAX */
d__1 = value, d__2 = WORK(i);
value = max(d__1,d__2);
/* L280: */
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
scale = 1.;
sum = (doublereal) min(*m,*n);
i__1 = *n;
for (j = 2; j <= *n; ++j) {
/* Computing MIN */
i__3 = *m, i__4 = j - 1;
i__2 = min(i__3,i__4);
dlassq_(&i__2, &A(1,j), &c__1, &scale, &sum);
/* L290: */
}
} else {
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = min(*m,j);
dlassq_(&i__2, &A(1,j), &c__1, &scale, &sum);
/* L300: */
}
}
} else {
if (lsame_(diag, "U")) {
scale = 1.;
sum = (doublereal) min(*m,*n);
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = *m - j;
/* Computing MIN */
i__3 = *m, i__4 = j + 1;
dlassq_(&i__2, &A(min(*m,j+1),j), &c__1, &
scale, &sum);
/* L310: */
}
} else {
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = *m - j + 1;
dlassq_(&i__2, &A(j,j), &c__1, &scale, &sum);
/* L320: */
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANTR */
} /* dlantr_ */
