/* ===================================================================== */
real slangb_(char *norm, integer *n, integer *kl, integer *ku, real *ab, integer *ldab, real *work)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
real ret_val, r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k, l;
real sum, temp, scale;
extern logical lsame_(char *, char *);
real value;
extern logical sisnan_(real *);
extern /* Subroutine */
int slassq_(integer *, real *, integer *, real *, real *);
/* -- 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.f;
}
else if (lsame_(norm, "M"))
{
/* Find max(abs(A(i,j))). */
value = 0.f;
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 = (r__1 = ab[i__ + j * ab_dim1], abs(r__1));
if (value < temp || sisnan_(&temp))
{
value = temp;
}
/* L10: */
}
/* L20: */
}
}
else if (lsame_(norm, "O") || *(unsigned char *) norm == '1')
{
/* Find norm1(A). */
value = 0.f;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
sum = 0.f;
/* 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 += (r__1 = ab[i__ + j * ab_dim1], abs(r__1));
/* L30: */
}
if (value < sum || sisnan_(&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.f;
/* 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__] += (r__1 = ab[k + i__ + j * ab_dim1], abs(r__1));
/* L60: */
}
/* L70: */
}
value = 0.f;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
temp = work[i__];
if (value < temp || sisnan_(&temp))
{
value = temp;
}
/* L80: */
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
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;
slassq_(&i__4, &ab[k + j * ab_dim1], &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANGB */
}
doublereal slansy_(char *norm, char *uplo, int *n, real *a, int *lda,
real *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
=======
SLANSY 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 matrix A.
Description
===========
SLANSY returns the value
SLANSY = ( 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 SLANSY 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, SLANSY is
set to zero.
A (input) REAL 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) REAL array, dimension (LWORK),
where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
WORK is not referenced.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static int c__1 = 1;
/* System generated locals */
/* Unused variables commented out by MDG on 03-09-05
int a_dim1, a_offset;
*/
int i__1, i__2;
real ret_val, r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static real absa;
static int i, j;
static real scale;
extern logical lsame_(char *, char *);
static real value;
extern /* Subroutine */ int slassq_(int *, real *, int *, real *,
real *);
static real sum;
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
if (*n == 0) {
value = 0.f;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.f;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = j;
for (i = 1; i <= j; ++i) {
/* Computing MAX */
r__2 = value, r__3 = (r__1 = A(i,j), dabs(r__1)
);
value = dmax(r__2,r__3);
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = *n;
for (i = j; i <= *n; ++i) {
/* Computing MAX */
r__2 = value, r__3 = (r__1 = A(i,j), dabs(r__1)
);
value = dmax(r__2,r__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.f;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
sum = 0.f;
i__2 = j - 1;
for (i = 1; i <= j-1; ++i) {
absa = (r__1 = A(i,j), dabs(r__1));
sum += absa;
WORK(i) += absa;
/* L50: */
}
WORK(j) = sum + (r__1 = A(j,j), dabs(r__1));
/* L60: */
}
i__1 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
r__1 = value, r__2 = WORK(i);
value = dmax(r__1,r__2);
/* L70: */
}
} else {
i__1 = *n;
for (i = 1; i <= *n; ++i) {
WORK(i) = 0.f;
/* L80: */
}
i__1 = *n;
for (j = 1; j <= *n; ++j) {
sum = WORK(j) + (r__1 = A(j,j), dabs(r__1));
i__2 = *n;
for (i = j + 1; i <= *n; ++i) {
absa = (r__1 = A(i,j), dabs(r__1));
sum += absa;
WORK(i) += absa;
/* L90: */
}
value = dmax(value,sum);
/* L100: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 2; j <= *n; ++j) {
i__2 = j - 1;
slassq_(&i__2, &A(1,j), &c__1, &scale, &sum);
/* L110: */
}
} else {
i__1 = *n - 1;
for (j = 1; j <= *n-1; ++j) {
i__2 = *n - j;
slassq_(&i__2, &A(j+1,j), &c__1, &scale, &sum);
/* L120: */
}
}
sum *= 2;
i__1 = *lda + 1;
slassq_(n, &A(1,1), &i__1, &scale, &sum);
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANSY */
} /* slansy_ */
double slanst_(char *norm, int *n, float *d__, float *e)
{
/* System generated locals */
int i__1;
float ret_val, r__1, r__2, r__3, r__4, r__5;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int i__;
float sum, scale;
extern int lsame_(char *, char *);
float anorm;
extern int slassq_(int *, float *, int *, float *,
float *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLANST 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 tridiagonal matrix A. */
/* Description */
/* =========== */
/* SLANST returns the value */
/* SLANST = ( 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 SLANST as described */
/* above. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, SLANST is */
/* set to zero. */
/* D (input) REAL array, dimension (N) */
/* The diagonal elements of A. */
/* E (input) REAL 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.f;
} else if (lsame_(norm, "M")) {
/* Find MAX(ABS(A(i,j))). */
anorm = (r__1 = d__[*n], ABS(r__1));
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = anorm, r__3 = (r__1 = d__[i__], ABS(r__1));
anorm = MAX(r__2,r__3);
/* Computing MAX */
r__2 = anorm, r__3 = (r__1 = e[i__], ABS(r__1));
anorm = MAX(r__2,r__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 */
r__3 = ABS(d__[1]) + ABS(e[1]), r__4 = (r__1 = e[*n - 1], ABS(
r__1)) + (r__2 = d__[*n], ABS(r__2));
anorm = MAX(r__3,r__4);
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
r__4 = anorm, r__5 = (r__1 = d__[i__], ABS(r__1)) + (r__2 =
e[i__], ABS(r__2)) + (r__3 = e[i__ - 1], ABS(r__3));
anorm = MAX(r__4,r__5);
/* L20: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
if (*n > 1) {
i__1 = *n - 1;
slassq_(&i__1, &e[1], &c__1, &scale, &sum);
sum *= 2;
}
slassq_(n, &d__[1], &c__1, &scale, &sum);
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of SLANST */
} /* slanst_ */
/* Subroutine */ int slatdf_(integer *ijob, integer *n, real *z__, integer *
ldz, real *rhs, real *rdsum, real *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
=======
SLATDF uses the LU factorization of the n-by-n matrix Z computed by
SGETC2 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 SGETC2 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 SGECON, 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) REAL array, dimension (LDZ, N)
On entry, the LU part of the factorization of the n-by-n
matrix Z computed by SGETC2: Z = P * L * U * Q
LDZ (input) INTEGER
The leading dimension of the array Z. LDA >= max(1, N).
RHS (input/output) REAL 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) REAL
On entry, the sum of squares of computed contributions to
the Dif-estimate under computation by STGSYL, 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 STGSY2 is called by STGSYL.
RDSCAL (input/output) REAL
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 STGSY2 is called by
STGSYL.
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 real c_b23 = 1.f;
static real c_b37 = -1.f;
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer info;
static real temp;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
static real work[32];
static integer i__, j, k;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real pmone;
extern doublereal sasum_(integer *, real *, integer *);
static real sminu;
static integer iwork[8];
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), saxpy_(integer *, real *, real *, integer *, real *,
integer *);
static real splus;
extern /* Subroutine */ int sgesc2_(integer *, real *, integer *, real *,
integer *, integer *, real *);
static real bm, bp, xm[8], xp[8];
extern /* Subroutine */ int sgecon_(char *, integer *, real *, integer *,
real *, real *, real *, integer *, integer *), slassq_(
integer *, real *, integer *, real *, real *), slaswp_(integer *,
real *, 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;
slaswp_(&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.f;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
bp = rhs[j] + 1.f;
bm = rhs[j] - 1.f;
splus = 1.f;
/* 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 += sdot_(&i__2, &z___ref(j + 1, j), &c__1, &z___ref(j + 1,
j), &c__1);
i__2 = *n - j;
sminu = sdot_(&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.f;
}
/* Compute the remaining r.h.s. */
temp = -rhs[j];
i__2 = *n - j;
saxpy_(&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;
scopy_(&i__1, &rhs[1], &c__1, xp, &c__1);
xp[*n - 1] = rhs[*n] + 1.f;
rhs[*n] += -1.f;
splus = 0.f;
sminu = 0.f;
for (i__ = *n; i__ >= 1; --i__) {
temp = 1.f / 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 += (r__1 = xp[i__ - 1], dabs(r__1));
sminu += (r__1 = rhs[i__], dabs(r__1));
/* L30: */
}
if (splus > sminu) {
scopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Apply the permutations JPIV to the computed solution (RHS) */
i__1 = *n - 1;
slaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1);
/* Compute the sum of squares */
slassq_(n, &rhs[1], &c__1, rdscal, rdsum);
} else {
/* IJOB = 2, Compute approximate nullvector XM of Z */
sgecon_("I", n, &z__[z_offset], ldz, &c_b23, &temp, work, iwork, &
info);
scopy_(n, &work[*n], &c__1, xm, &c__1);
/* Compute RHS */
i__1 = *n - 1;
slaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1);
temp = 1.f / sqrt(sdot_(n, xm, &c__1, xm, &c__1));
sscal_(n, &temp, xm, &c__1);
scopy_(n, xm, &c__1, xp, &c__1);
saxpy_(n, &c_b23, &rhs[1], &c__1, xp, &c__1);
saxpy_(n, &c_b37, xm, &c__1, &rhs[1], &c__1);
sgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &temp);
sgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &temp);
if (sasum_(n, xp, &c__1) > sasum_(n, &rhs[1], &c__1)) {
scopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Compute the sum of squares */
slassq_(n, &rhs[1], &c__1, rdscal, rdsum);
}
return 0;
/* End of SLATDF */
} /* slatdf_ */
doublereal slantr_(char *norm, char *uplo, char *diag, integer *m, integer *n,
real *a, integer *lda, real *work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
real ret_val, r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
real sum, scale;
logical udiag;
extern logical lsame_(char *, char *);
real value;
extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
real *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLANTR 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 */
/* =========== */
/* SLANTR returns the value */
/* SLANTR = ( 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 SLANTR 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, SLANTR 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, SLANTR is set to zero. */
/* A (input) REAL 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) REAL 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.f;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
if (lsame_(diag, "U")) {
value = 1.f;
if (lsame_(uplo, "U")) {
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 */
r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1],
dabs(r__1));
value = dmax(r__2,r__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 */
r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1],
dabs(r__1));
value = dmax(r__2,r__3);
/* L30: */
}
/* L40: */
}
}
} else {
value = 0.f;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(*m,j);
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1],
dabs(r__1));
value = dmax(r__2,r__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 */
r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1],
dabs(r__1));
value = dmax(r__2,r__3);
/* L70: */
}
/* L80: */
}
}
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.f;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag && j <= *m) {
sum = 1.f;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
/* L90: */
}
} else {
sum = 0.f;
i__2 = min(*m,j);
for (i__ = 1; i__ <= i__2; ++i__) {
sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
/* L100: */
}
}
value = dmax(value,sum);
/* L110: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.f;
i__2 = *m;
for (i__ = j + 1; i__ <= i__2; ++i__) {
sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
/* L120: */
}
} else {
sum = 0.f;
i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) {
sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
/* L130: */
}
}
value = dmax(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__ <= i__1; ++i__) {
work[i__] = 1.f;
/* 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__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
/* L160: */
}
/* L170: */
}
} else {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
/* 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__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
/* L190: */
}
/* L200: */
}
}
} else {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.f;
/* L210: */
}
i__1 = *m;
for (i__ = *n + 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
/* L220: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
/* L230: */
}
/* L240: */
}
} else {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
/* L250: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) {
work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
/* L260: */
}
/* L270: */
}
}
}
value = 0.f;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = value, r__2 = work[i__];
value = dmax(r__1,r__2);
/* L280: */
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
scale = 1.f;
sum = (real) 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);
slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L290: */
}
} else {
scale = 0.f;
sum = 1.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(*m,j);
slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L300: */
}
}
} else {
if (lsame_(diag, "U")) {
scale = 1.f;
sum = (real) 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;
slassq_(&i__2, &a[min(i__3, i__4)+ j * a_dim1], &c__1, &
scale, &sum);
/* L310: */
}
} else {
scale = 0.f;
sum = 1.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m - j + 1;
slassq_(&i__2, &a[j + j * a_dim1], &c__1, &scale, &sum);
/* L320: */
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANTR */
} /* slantr_ */
/* ===================================================================== */
real slantp_(char *norm, char *uplo, char *diag, integer *n, real *ap, real * work)
{
/* System generated locals */
integer i__1, i__2;
real ret_val, r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k;
real sum, scale;
logical udiag;
extern logical lsame_(char *, char *);
real value;
extern logical sisnan_(real *);
extern /* Subroutine */
int slassq_(integer *, real *, integer *, real *, real *);
/* -- 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.f;
}
else if (lsame_(norm, "M"))
{
/* Find max(f2c_abs(A(i,j))). */
k = 1;
if (lsame_(diag, "U"))
{
value = 1.f;
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__)
{
sum = (r__1 = ap[i__], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* 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__)
{
sum = (r__1 = ap[i__], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L30: */
}
k = k + *n - j + 1;
/* L40: */
}
}
}
else
{
value = 0.f;
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__)
{
sum = (r__1 = ap[i__], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* 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__)
{
sum = (r__1 = ap[i__], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L70: */
}
k = k + *n - j + 1;
/* L80: */
}
}
}
}
else if (lsame_(norm, "O") || *(unsigned char *) norm == '1')
{
/* Find norm1(A). */
value = 0.f;
k = 1;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (udiag)
{
sum = 1.f;
i__2 = k + j - 2;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum += (r__1 = ap[i__], f2c_abs(r__1));
/* L90: */
}
}
else
{
sum = 0.f;
i__2 = k + j - 1;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum += (r__1 = ap[i__], f2c_abs(r__1));
/* L100: */
}
}
k += j;
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L110: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (udiag)
{
sum = 1.f;
i__2 = k + *n - j;
for (i__ = k + 1;
i__ <= i__2;
++i__)
{
sum += (r__1 = ap[i__], f2c_abs(r__1));
/* L120: */
}
}
else
{
sum = 0.f;
i__2 = k + *n - j;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum += (r__1 = ap[i__], f2c_abs(r__1));
/* L130: */
}
}
k = k + *n - j + 1;
if (value < sum || sisnan_(&sum))
{
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.f;
/* L150: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j - 1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[i__] += (r__1 = ap[k], f2c_abs(r__1));
++k;
/* L160: */
}
++k;
/* L170: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.f;
/* L180: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j;
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[i__] += (r__1 = ap[k], f2c_abs(r__1));
++k;
/* L190: */
}
/* L200: */
}
}
}
else
{
if (lsame_(diag, "U"))
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 1.f;
/* 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__] += (r__1 = ap[k], f2c_abs(r__1));
++k;
/* L220: */
}
/* L230: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.f;
/* L240: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n;
for (i__ = j;
i__ <= i__2;
++i__)
{
work[i__] += (r__1 = ap[k], f2c_abs(r__1));
++k;
/* L250: */
}
/* L260: */
}
}
}
value = 0.f;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
sum = work[i__];
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L270: */
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
if (lsame_(uplo, "U"))
{
if (lsame_(diag, "U"))
{
scale = 1.f;
sum = (real) (*n);
k = 2;
i__1 = *n;
for (j = 2;
j <= i__1;
++j)
{
i__2 = j - 1;
slassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k += j;
/* L280: */
}
}
else
{
scale = 0.f;
sum = 1.f;
k = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
slassq_(&j, &ap[k], &c__1, &scale, &sum);
k += j;
/* L290: */
}
}
}
else
{
if (lsame_(diag, "U"))
{
scale = 1.f;
sum = (real) (*n);
k = 2;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j;
slassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k = k + *n - j + 1;
/* L300: */
}
}
else
{
scale = 0.f;
sum = 1.f;
k = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j + 1;
slassq_(&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 SLANTP */
}
doublereal slangb_(char *norm, integer *n, integer *kl, integer *ku, real *ab,
integer *ldab, real *work)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
real ret_val, r__1, r__2, r__3;
/* Local variables */
integer i__, j, k, l;
real sum, scale;
real value;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SLANGB 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 */
/* =========== */
/* SLANGB returns the value */
/* SLANGB = ( 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 SLANGB as described */
/* above. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, SLANGB 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) REAL 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) REAL 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.f;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.f;
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 */
r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1], dabs(r__1)
);
value = dmax(r__2,r__3);
}
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.f;
/* 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 += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1));
}
value = dmax(value,sum);
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
}
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__] += (r__1 = ab[k + i__ + j * ab_dim1], dabs(r__1));
}
}
value = 0.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = value, r__2 = work[i__];
value = dmax(r__1,r__2);
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
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;
slassq_(&i__4, &ab[k + j * ab_dim1], &c__1, &scale, &sum);
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANGB */
} /* slangb_ */
/* Subroutine */ int stgex2_(logical *wantq, logical *wantz, integer *n, real
*a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real *
z__, integer *ldz, integer *j1, integer *n1, integer *n2, real *work,
integer *lwork, integer *info)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)
of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair
(A, B) by an orthogonal equivalence transformation.
(A, B) must be in generalized real Schur canonical form (as returned
by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
diagonal blocks. B is upper triangular.
Optionally, the matrices Q and Z of generalized Schur vectors are
updated.
Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
Arguments
=========
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.
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) REAL arrays, dimensions (LDA,N)
On entry, the matrix A in the pair (A, B).
On exit, the updated matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) REAL arrays, dimensions (LDB,N)
On entry, the matrix B in the pair (A, B).
On exit, the updated matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
Q (input/output) REAL array, dimension (LDZ,N)
On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
On exit, the updated matrix Q.
Not referenced if WANTQ = .FALSE..
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= 1.
If WANTQ = .TRUE., LDQ >= N.
Z (input/output) REAL array, dimension (LDZ,N)
On entry, if WANTZ =.TRUE., the orthogonal matrix Z.
On exit, the updated matrix Z.
Not referenced if WANTZ = .FALSE..
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1.
If WANTZ = .TRUE., LDZ >= N.
J1 (input) INTEGER
The index to the first block (A11, B11). 1 <= J1 <= N.
N1 (input) INTEGER
The order of the first block (A11, B11). N1 = 0, 1 or 2.
N2 (input) INTEGER
The order of the second block (A22, B22). N2 = 0, 1 or 2.
WORK (workspace) REAL array, dimension (LWORK).
LWORK (input) INTEGER
The dimension of the array WORK.
LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 )
INFO (output) INTEGER
=0: Successful exit
>0: If INFO = 1, the transformed matrix (A, B) would be
too far from generalized Schur form; the blocks are
not swapped and (A, B) and (Q, Z) are unchanged.
The problem of swapping is too ill-conditioned.
<0: If INFO = -16: LWORK is too small. Appropriate value
for LWORK is returned in WORK(1).
Further Details
===============
Based on contributions by
Bo Kagstrom and Peter Poromaa, Department of Computing Science,
Umea University, S-901 87 Umea, Sweden.
In the current code both weak and strong stability tests are
performed. The user can omit the strong stability test by changing
the internal logical parameter WANDS to .FALSE.. See ref. [2] for
details.
[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.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__16 = 16;
static real c_b3 = 0.f;
static integer c__0 = 0;
static integer c__1 = 1;
static integer c__4 = 4;
static integer c__2 = 2;
static real c_b38 = 1.f;
static real c_b44 = -1.f;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static logical weak;
static real ddum;
static integer idum;
static real taul[4], dsum, taur[4], scpy[16] /* was [4][4] */,
tcpy[16] /* was [4][4] */;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
static real f, g;
static integer i__, m;
static real s[16] /* was [4][4] */, t[16] /* was [4][4] */, scale,
bqra21, brqa21;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real licop[16] /* was [4][4] */;
static integer linfo;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
static real ircop[16] /* was [4][4] */, dnorm;
static integer iwork[4];
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), slagv2_(real *, integer *, real *, integer *, real *,
real *, real *, real *, real *, real *, real *), sgeqr2_(integer *
, integer *, real *, integer *, real *, real *, integer *),
sgerq2_(integer *, integer *, real *, integer *, real *, real *,
integer *);
static real be[2], ai[2];
extern /* Subroutine */ int sorg2r_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *), sorgr2_(integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
);
static real ar[2], sa, sb, li[16] /* was [4][4] */;
extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *), sormr2_(char *, char *, integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
, real *, integer *);
static real dscale, ir[16] /* was [4][4] */;
extern /* Subroutine */ int stgsy2_(char *, integer *, integer *, integer
*, real *, integer *, real *, integer *, real *, integer *, real *
, integer *, real *, integer *, real *, integer *, real *, real *,
real *, integer *, integer *, integer *);
static real ss;
extern doublereal slamch_(char *);
static real ws;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slartg_(real *, real *,
real *, real *, real *);
static real thresh;
extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
real *);
static real smlnum;
static logical strong;
static real eps;
#define scpy_ref(a_1,a_2) scpy[(a_2)*4 + a_1 - 5]
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define s_ref(a_1,a_2) s[(a_2)*4 + a_1 - 5]
#define t_ref(a_1,a_2) t[(a_2)*4 + a_1 - 5]
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
#define li_ref(a_1,a_2) li[(a_2)*4 + a_1 - 5]
#define ir_ref(a_1,a_2) ir[(a_2)*4 + a_1 - 5]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n <= 1 || *n1 <= 0 || *n2 <= 0) {
return 0;
}
if (*n1 > *n || *j1 + *n1 > *n) {
return 0;
}
m = *n1 + *n2;
/* Computing MAX */
i__1 = *n * m, i__2 = m * m << 1;
if (*lwork < max(i__1,i__2)) {
*info = -16;
/* Computing MAX */
i__1 = *n * m, i__2 = m * m << 1;
work[1] = (real) max(i__1,i__2);
return 0;
}
weak = FALSE_;
strong = FALSE_;
/* Make a local copy of selected block */
scopy_(&c__16, &c_b3, &c__0, li, &c__1);
scopy_(&c__16, &c_b3, &c__0, ir, &c__1);
slacpy_("Full", &m, &m, &a_ref(*j1, *j1), lda, s, &c__4);
slacpy_("Full", &m, &m, &b_ref(*j1, *j1), ldb, t, &c__4);
/* Compute threshold for testing acceptance of swapping. */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
dscale = 0.f;
dsum = 1.f;
slacpy_("Full", &m, &m, s, &c__4, &work[1], &m);
i__1 = m * m;
slassq_(&i__1, &work[1], &c__1, &dscale, &dsum);
slacpy_("Full", &m, &m, t, &c__4, &work[1], &m);
i__1 = m * m;
slassq_(&i__1, &work[1], &c__1, &dscale, &dsum);
dnorm = dscale * sqrt(dsum);
/* Computing MAX */
r__1 = eps * 10.f * dnorm;
thresh = dmax(r__1,smlnum);
if (m == 2) {
/* CASE 1: Swap 1-by-1 and 1-by-1 blocks.
Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks
using Givens rotations and perform the swap tentatively. */
f = s_ref(2, 2) * t_ref(1, 1) - t_ref(2, 2) * s_ref(1, 1);
g = s_ref(2, 2) * t_ref(1, 2) - t_ref(2, 2) * s_ref(1, 2);
sb = (r__1 = t_ref(2, 2), dabs(r__1));
sa = (r__1 = s_ref(2, 2), dabs(r__1));
slartg_(&f, &g, &ir_ref(1, 2), &ir_ref(1, 1), &ddum);
ir_ref(2, 1) = -ir_ref(1, 2);
ir_ref(2, 2) = ir_ref(1, 1);
srot_(&c__2, &s_ref(1, 1), &c__1, &s_ref(1, 2), &c__1, &ir_ref(1, 1),
&ir_ref(2, 1));
srot_(&c__2, &t_ref(1, 1), &c__1, &t_ref(1, 2), &c__1, &ir_ref(1, 1),
&ir_ref(2, 1));
if (sa >= sb) {
slartg_(&s_ref(1, 1), &s_ref(2, 1), &li_ref(1, 1), &li_ref(2, 1),
&ddum);
} else {
slartg_(&t_ref(1, 1), &t_ref(2, 1), &li_ref(1, 1), &li_ref(2, 1),
&ddum);
}
srot_(&c__2, &s_ref(1, 1), &c__4, &s_ref(2, 1), &c__4, &li_ref(1, 1),
&li_ref(2, 1));
srot_(&c__2, &t_ref(1, 1), &c__4, &t_ref(2, 1), &c__4, &li_ref(1, 1),
&li_ref(2, 1));
li_ref(2, 2) = li_ref(1, 1);
li_ref(1, 2) = -li_ref(2, 1);
/* Weak stability test:
|S21| + |T21| <= O(EPS * F-norm((S, T))) */
ws = (r__1 = s_ref(2, 1), dabs(r__1)) + (r__2 = t_ref(2, 1), dabs(
r__2));
weak = ws <= thresh;
if (! weak) {
goto L70;
}
if (TRUE_) {
/* Strong stability test:
F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B))) */
slacpy_("Full", &m, &m, &a_ref(*j1, *j1), lda, &work[m * m + 1], &
m);
sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, s, &c__4, &c_b3, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b44, &work[1], &m, ir, &c__4, &
c_b38, &work[m * m + 1], &m);
dscale = 0.f;
dsum = 1.f;
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
slacpy_("Full", &m, &m, &b_ref(*j1, *j1), ldb, &work[m * m + 1], &
m);
sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, t, &c__4, &c_b3, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b44, &work[1], &m, ir, &c__4, &
c_b38, &work[m * m + 1], &m);
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
ss = dscale * sqrt(dsum);
strong = ss <= thresh;
if (! strong) {
goto L70;
}
}
/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
(A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */
i__1 = *j1 + 1;
srot_(&i__1, &a_ref(1, *j1), &c__1, &a_ref(1, *j1 + 1), &c__1, &
ir_ref(1, 1), &ir_ref(2, 1));
i__1 = *j1 + 1;
srot_(&i__1, &b_ref(1, *j1), &c__1, &b_ref(1, *j1 + 1), &c__1, &
ir_ref(1, 1), &ir_ref(2, 1));
i__1 = *n - *j1 + 1;
srot_(&i__1, &a_ref(*j1, *j1), lda, &a_ref(*j1 + 1, *j1), lda, &
li_ref(1, 1), &li_ref(2, 1));
i__1 = *n - *j1 + 1;
srot_(&i__1, &b_ref(*j1, *j1), ldb, &b_ref(*j1 + 1, *j1), ldb, &
li_ref(1, 1), &li_ref(2, 1));
/* Set N1-by-N2 (2,1) - blocks to ZERO. */
a_ref(*j1 + 1, *j1) = 0.f;
b_ref(*j1 + 1, *j1) = 0.f;
/* Accumulate transformations into Q and Z if requested. */
if (*wantz) {
srot_(n, &z___ref(1, *j1), &c__1, &z___ref(1, *j1 + 1), &c__1, &
ir_ref(1, 1), &ir_ref(2, 1));
}
if (*wantq) {
srot_(n, &q_ref(1, *j1), &c__1, &q_ref(1, *j1 + 1), &c__1, &
li_ref(1, 1), &li_ref(2, 1));
}
/* Exit with INFO = 0 if swap was successfully performed. */
return 0;
} else {
/* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2
and 2-by-2 blocks.
Solve the generalized Sylvester equation
S11 * R - L * S22 = SCALE * S12
T11 * R - L * T22 = SCALE * T12
for R and L. Solutions in LI and IR. */
slacpy_("Full", n1, n2, &t_ref(1, *n1 + 1), &c__4, li, &c__4);
slacpy_("Full", n1, n2, &s_ref(1, *n1 + 1), &c__4, &ir_ref(*n2 + 1, *
n1 + 1), &c__4);
stgsy2_("N", &c__0, n1, n2, s, &c__4, &s_ref(*n1 + 1, *n1 + 1), &c__4,
&ir_ref(*n2 + 1, *n1 + 1), &c__4, t, &c__4, &t_ref(*n1 + 1, *
n1 + 1), &c__4, li, &c__4, &scale, &dsum, &dscale, iwork, &
idum, &linfo);
/* Compute orthogonal matrix QL:
QL' * LI = [ TL ]
[ 0 ]
where
LI = [ -L ]
[ SCALE * identity(N2) ] */
i__1 = *n2;
for (i__ = 1; i__ <= i__1; ++i__) {
sscal_(n1, &c_b44, &li_ref(1, i__), &c__1);
li_ref(*n1 + i__, i__) = scale;
/* L10: */
}
sgeqr2_(&m, n2, li, &c__4, taul, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sorg2r_(&m, &m, n2, li, &c__4, taul, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
/* Compute orthogonal matrix RQ:
IR * RQ' = [ 0 TR],
where IR = [ SCALE * identity(N1), R ] */
i__1 = *n1;
for (i__ = 1; i__ <= i__1; ++i__) {
ir_ref(*n2 + i__, i__) = scale;
/* L20: */
}
sgerq2_(n1, &m, &ir_ref(*n2 + 1, 1), &c__4, taur, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sorgr2_(&m, &m, n1, ir, &c__4, taur, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
/* Perform the swapping tentatively: */
sgemm_("T", "N", &m, &m, &m, &c_b38, li, &c__4, s, &c__4, &c_b3, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b38, &work[1], &m, ir, &c__4, &c_b3,
s, &c__4);
sgemm_("T", "N", &m, &m, &m, &c_b38, li, &c__4, t, &c__4, &c_b3, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b38, &work[1], &m, ir, &c__4, &c_b3,
t, &c__4);
slacpy_("F", &m, &m, s, &c__4, scpy, &c__4);
slacpy_("F", &m, &m, t, &c__4, tcpy, &c__4);
slacpy_("F", &m, &m, ir, &c__4, ircop, &c__4);
slacpy_("F", &m, &m, li, &c__4, licop, &c__4);
/* Triangularize the B-part by an RQ factorization.
Apply transformation (from left) to A-part, giving S. */
sgerq2_(&m, &m, t, &c__4, taur, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sormr2_("R", "T", &m, &m, &m, t, &c__4, taur, s, &c__4, &work[1], &
linfo);
if (linfo != 0) {
goto L70;
}
sormr2_("L", "N", &m, &m, &m, t, &c__4, taur, ir, &c__4, &work[1], &
linfo);
if (linfo != 0) {
goto L70;
}
/* Compute F-norm(S21) in BRQA21. (T21 is 0.) */
dscale = 0.f;
dsum = 1.f;
i__1 = *n2;
for (i__ = 1; i__ <= i__1; ++i__) {
slassq_(n1, &s_ref(*n2 + 1, i__), &c__1, &dscale, &dsum);
/* L30: */
}
brqa21 = dscale * sqrt(dsum);
/* Triangularize the B-part by a QR factorization.
Apply transformation (from right) to A-part, giving S. */
sgeqr2_(&m, &m, tcpy, &c__4, taul, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sorm2r_("L", "T", &m, &m, &m, tcpy, &c__4, taul, scpy, &c__4, &work[1]
, info);
sorm2r_("R", "N", &m, &m, &m, tcpy, &c__4, taul, licop, &c__4, &work[
1], info);
if (linfo != 0) {
goto L70;
}
/* Compute F-norm(S21) in BQRA21. (T21 is 0.) */
dscale = 0.f;
dsum = 1.f;
i__1 = *n2;
for (i__ = 1; i__ <= i__1; ++i__) {
slassq_(n1, &scpy_ref(*n2 + 1, i__), &c__1, &dscale, &dsum);
/* L40: */
}
bqra21 = dscale * sqrt(dsum);
/* Decide which method to use.
Weak stability test:
F-norm(S21) <= O(EPS * F-norm((S, T))) */
if (bqra21 <= brqa21 && bqra21 <= thresh) {
slacpy_("F", &m, &m, scpy, &c__4, s, &c__4);
slacpy_("F", &m, &m, tcpy, &c__4, t, &c__4);
slacpy_("F", &m, &m, ircop, &c__4, ir, &c__4);
slacpy_("F", &m, &m, licop, &c__4, li, &c__4);
} else if (brqa21 >= thresh) {
goto L70;
}
/* Set lower triangle of B-part to zero */
i__1 = m;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = m - i__ + 1;
scopy_(&i__2, &c_b3, &c__0, &t_ref(i__, i__ - 1), &c__1);
/* L50: */
}
if (TRUE_) {
/* Strong stability test:
F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B))) */
slacpy_("Full", &m, &m, &a_ref(*j1, *j1), lda, &work[m * m + 1], &
m);
sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, s, &c__4, &c_b3, &
work[1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b44, &work[1], &m, ir, &c__4, &
c_b38, &work[m * m + 1], &m);
dscale = 0.f;
dsum = 1.f;
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
slacpy_("Full", &m, &m, &b_ref(*j1, *j1), ldb, &work[m * m + 1], &
m);
sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, t, &c__4, &c_b3, &
work[1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b44, &work[1], &m, ir, &c__4, &
c_b38, &work[m * m + 1], &m);
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
ss = dscale * sqrt(dsum);
strong = ss <= thresh;
if (! strong) {
goto L70;
}
}
/* If the swap is accepted ("weakly" and "strongly"), apply the
transformations and set N1-by-N2 (2,1)-block to zero. */
i__1 = *n2;
for (i__ = 1; i__ <= i__1; ++i__) {
scopy_(n1, &c_b3, &c__0, &s_ref(*n2 + 1, i__), &c__1);
/* L60: */
}
/* copy back M-by-M diagonal block starting at index J1 of (A, B) */
slacpy_("F", &m, &m, s, &c__4, &a_ref(*j1, *j1), lda);
slacpy_("F", &m, &m, t, &c__4, &b_ref(*j1, *j1), ldb);
scopy_(&c__16, &c_b3, &c__0, t, &c__1);
/* Standardize existing 2-by-2 blocks. */
i__1 = m * m;
scopy_(&i__1, &c_b3, &c__0, &work[1], &c__1);
work[1] = 1.f;
t_ref(1, 1) = 1.f;
idum = *lwork - m * m - 2;
if (*n2 > 1) {
slagv2_(&a_ref(*j1, *j1), lda, &b_ref(*j1, *j1), ldb, ar, ai, be,
&work[1], &work[2], &t_ref(1, 1), &t_ref(2, 1));
work[m + 1] = -work[2];
work[m + 2] = work[1];
t_ref(*n2, *n2) = t_ref(1, 1);
t_ref(1, 2) = -t_ref(2, 1);
}
work[m * m] = 1.f;
t_ref(m, m) = 1.f;
if (*n1 > 1) {
slagv2_(&a_ref(*j1 + *n2, *j1 + *n2), lda, &b_ref(*j1 + *n2, *j1
+ *n2), ldb, taur, taul, &work[m * m + 1], &work[*n2 * m
+ *n2 + 1], &work[*n2 * m + *n2 + 2], &t_ref(*n2 + 1, *n2
+ 1), &t_ref(m, m - 1));
work[m * m] = work[*n2 * m + *n2 + 1];
work[m * m - 1] = -work[*n2 * m + *n2 + 2];
t_ref(m, m) = t_ref(*n2 + 1, *n2 + 1);
t_ref(m - 1, m) = -t_ref(m, m - 1);
}
sgemm_("T", "N", n2, n1, n2, &c_b38, &work[1], &m, &a_ref(*j1, *j1 + *
n2), lda, &c_b3, &work[m * m + 1], n2);
slacpy_("Full", n2, n1, &work[m * m + 1], n2, &a_ref(*j1, *j1 + *n2),
lda);
sgemm_("T", "N", n2, n1, n2, &c_b38, &work[1], &m, &b_ref(*j1, *j1 + *
n2), ldb, &c_b3, &work[m * m + 1], n2);
slacpy_("Full", n2, n1, &work[m * m + 1], n2, &b_ref(*j1, *j1 + *n2),
ldb);
sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, &work[1], &m, &c_b3, &
work[m * m + 1], &m);
slacpy_("Full", &m, &m, &work[m * m + 1], &m, li, &c__4);
sgemm_("N", "N", n2, n1, n1, &c_b38, &a_ref(*j1, *j1 + *n2), lda, &
t_ref(*n2 + 1, *n2 + 1), &c__4, &c_b3, &work[1], n2);
slacpy_("Full", n2, n1, &work[1], n2, &a_ref(*j1, *j1 + *n2), lda);
sgemm_("N", "N", n2, n1, n1, &c_b38, &b_ref(*j1, *j1 + *n2), lda, &
t_ref(*n2 + 1, *n2 + 1), &c__4, &c_b3, &work[1], n2);
slacpy_("Full", n2, n1, &work[1], n2, &b_ref(*j1, *j1 + *n2), ldb);
sgemm_("T", "N", &m, &m, &m, &c_b38, ir, &c__4, t, &c__4, &c_b3, &
work[1], &m);
slacpy_("Full", &m, &m, &work[1], &m, ir, &c__4);
/* Accumulate transformations into Q and Z if requested. */
if (*wantq) {
sgemm_("N", "N", n, &m, &m, &c_b38, &q_ref(1, *j1), ldq, li, &
c__4, &c_b3, &work[1], n);
slacpy_("Full", n, &m, &work[1], n, &q_ref(1, *j1), ldq);
}
if (*wantz) {
sgemm_("N", "N", n, &m, &m, &c_b38, &z___ref(1, *j1), ldz, ir, &
c__4, &c_b3, &work[1], n);
slacpy_("Full", n, &m, &work[1], n, &z___ref(1, *j1), ldz);
}
/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
(A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */
i__ = *j1 + m;
if (i__ <= *n) {
i__1 = *n - i__ + 1;
sgemm_("T", "N", &m, &i__1, &m, &c_b38, li, &c__4, &a_ref(*j1,
i__), lda, &c_b3, &work[1], &m);
i__1 = *n - i__ + 1;
slacpy_("Full", &m, &i__1, &work[1], &m, &a_ref(*j1, i__), lda);
i__1 = *n - i__ + 1;
sgemm_("T", "N", &m, &i__1, &m, &c_b38, li, &c__4, &b_ref(*j1,
i__), lda, &c_b3, &work[1], &m);
i__1 = *n - i__ + 1;
slacpy_("Full", &m, &i__1, &work[1], &m, &b_ref(*j1, i__), lda);
}
i__ = *j1 - 1;
if (i__ > 0) {
sgemm_("N", "N", &i__, &m, &m, &c_b38, &a_ref(1, *j1), lda, ir, &
c__4, &c_b3, &work[1], &i__);
slacpy_("Full", &i__, &m, &work[1], &i__, &a_ref(1, *j1), lda);
sgemm_("N", "N", &i__, &m, &m, &c_b38, &b_ref(1, *j1), ldb, ir, &
c__4, &c_b3, &work[1], &i__);
slacpy_("Full", &i__, &m, &work[1], &i__, &b_ref(1, *j1), ldb);
}
/* Exit with INFO = 0 if swap was successfully performed. */
return 0;
}
/* Exit with INFO = 1 if swap was rejected. */
L70:
*info = 1;
return 0;
/* End of STGEX2 */
} /* stgex2_ */
doublereal slangb_(char *norm, integer *n, integer *kl, integer *ku, real *ab,
integer *ldab, real *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
=======
SLANGB 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
===========
SLANGB returns the value
SLANGB = ( 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 SLANGB as described
above.
N (input) INTEGER
The order of the matrix A. N >= 0. When N = 0, SLANGB 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) REAL 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) REAL 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;
real ret_val, r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__, j, k, l;
static real scale;
extern logical lsame_(char *, char *);
static real value;
extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
real *);
static real 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.f;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.f;
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 */
r__2 = value, r__3 = (r__1 = ab_ref(i__, j), dabs(r__1));
value = dmax(r__2,r__3);
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.f;
/* 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 += (r__1 = ab_ref(i__, j), dabs(r__1));
/* L30: */
}
value = dmax(value,sum);
/* L40: */
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
/* 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__] += (r__1 = ab_ref(k + i__, j), dabs(r__1));
/* L60: */
}
/* L70: */
}
value = 0.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = value, r__2 = work[i__];
value = dmax(r__1,r__2);
/* L80: */
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
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;
slassq_(&i__4, &ab_ref(k, j), &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANGB */
} /* slangb_ */
doublereal slange_(char *norm, integer *m, integer *n, real *a, integer *lda,
real *work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real ret_val, r__1, r__2, r__3;
/* Local variables */
integer i__, j;
real sum, scale;
real value;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SLANGE 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 */
/* =========== */
/* SLANGE returns the value */
/* SLANGE = ( 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 SLANGE as described */
/* above. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. When M = 0, */
/* SLANGE is set to zero. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. When N = 0, */
/* SLANGE is set to zero. */
/* A (input) REAL 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) REAL array, dimension (MAX(1,LWORK)), */
/* where LWORK >= M 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 (min(*m,*n) == 0) {
value = 0.f;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
value = dmax(r__2,r__3);
}
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.f;
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
}
value = dmax(value,sum);
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
}
}
value = 0.f;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = value, r__2 = work[i__];
value = dmax(r__1,r__2);
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
slassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANGE */
} /* slange_ */
/* ===================================================================== */
real slansp_(char *norm, char *uplo, integer *n, real *ap, real *work)
{
/* System generated locals */
integer i__1, i__2;
real ret_val, r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k;
real sum, absa, scale;
extern logical lsame_(char *, char *);
real value;
extern logical sisnan_(real *);
extern /* Subroutine */
int slassq_(integer *, real *, integer *, real *, real *);
/* -- 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.f;
}
else if (lsame_(norm, "M"))
{
/* Find max(f2c_abs(A(i,j))). */
value = 0.f;
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 = (r__1 = ap[i__], f2c_abs(r__1));
if (value < sum || sisnan_(&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 = (r__1 = ap[i__], f2c_abs(r__1));
if (value < sum || sisnan_(&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.f;
k = 1;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
sum = 0.f;
i__2 = j - 1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
absa = (r__1 = ap[k], f2c_abs(r__1));
sum += absa;
work[i__] += absa;
++k;
/* L50: */
}
work[j] = sum + (r__1 = ap[k], f2c_abs(r__1));
++k;
/* L60: */
}
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
sum = work[i__];
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L70: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.f;
/* L80: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
sum = work[j] + (r__1 = ap[k], f2c_abs(r__1));
++k;
i__2 = *n;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
absa = (r__1 = ap[k], f2c_abs(r__1));
sum += absa;
work[i__] += absa;
++k;
/* L90: */
}
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L100: */
}
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
k = 2;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 2;
j <= i__1;
++j)
{
i__2 = j - 1;
slassq_(&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;
slassq_(&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.f)
{
absa = (r__1 = ap[k], f2c_abs(r__1));
if (scale < absa)
{
/* Computing 2nd power */
r__1 = scale / absa;
sum = sum * (r__1 * r__1) + 1.f;
scale = absa;
}
else
{
/* Computing 2nd power */
r__1 = absa / scale;
sum += r__1 * r__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 SLANSP */
}
doublereal clanht_(char *norm, integer *n, real *d, complex *e)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1992
Purpose
=======
CLANHT 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
===========
CLANHT returns the value
CLANHT = ( 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 CLANHT as described
above.
N (input) INTEGER
The order of the matrix A. N >= 0. When N = 0, CLANHT is
set to zero.
D (input) REAL array, dimension (N)
The diagonal elements of A.
E (input) COMPLEX 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;
real ret_val, r__1, r__2, r__3;
/* Builtin functions */
double c_abs(complex *), sqrt(doublereal);
/* Local variables */
static integer i;
static real scale;
extern logical lsame_(char *, char *);
static real anorm;
extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
*, real *), slassq_(integer *, real *, integer *, real *, real *);
static real sum;
#define E(I) e[(I)-1]
#define D(I) d[(I)-1]
if (*n <= 0) {
anorm = 0.f;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
anorm = (r__1 = D(*n), dabs(r__1));
i__1 = *n - 1;
for (i = 1; i <= *n-1; ++i) {
/* Computing MAX */
r__2 = anorm, r__3 = (r__1 = D(i), dabs(r__1));
anorm = dmax(r__2,r__3);
/* Computing MAX */
r__1 = anorm, r__2 = c_abs(&E(i));
anorm = dmax(r__1,r__2);
/* L10: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)norm == '1' ||
lsame_(norm, "I")) {
/* Find norm1(A). */
if (*n == 1) {
anorm = dabs(D(1));
} else {
/* Computing MAX */
r__2 = dabs(D(1)) + c_abs(&E(1)), r__3 = c_abs(&E(*n - 1)) + (
r__1 = D(*n), dabs(r__1));
anorm = dmax(r__2,r__3);
i__1 = *n - 1;
for (i = 2; i <= *n-1; ++i) {
/* Computing MAX */
r__2 = anorm, r__3 = (r__1 = D(i), dabs(r__1)) + c_abs(&E(i))
+ c_abs(&E(i - 1));
anorm = dmax(r__2,r__3);
/* L20: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
if (*n > 1) {
i__1 = *n - 1;
classq_(&i__1, &E(1), &c__1, &scale, &sum);
sum *= 2;
}
slassq_(n, &D(1), &c__1, &scale, &sum);
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of CLANHT */
} /* clanht_ */
/* Subroutine */
int slatdf_(integer *ijob, integer *n, real *z__, integer * ldz, real *rhs, real *rdsum, real *rdscal, integer *ipiv, integer * jpiv)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k;
real bm, bp, xm[8], xp[8];
integer info;
real temp;
extern real sdot_(integer *, real *, integer *, real *, integer *);
real work[32];
extern /* Subroutine */
int sscal_(integer *, real *, real *, integer *);
real pmone;
extern real sasum_(integer *, real *, integer *);
real sminu;
integer iwork[8];
extern /* Subroutine */
int scopy_(integer *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *, integer *);
real splus;
extern /* Subroutine */
int sgesc2_(integer *, real *, integer *, real *, integer *, integer *, real *), sgecon_(char *, integer *, real *, integer *, real *, real *, real *, integer *, integer *), slassq_(integer *, real *, integer *, real *, real *), slaswp_( integer *, real *, integer *, integer *, integer *, integer *, integer *);
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--rhs;
--ipiv;
--jpiv;
/* Function Body */
if (*ijob != 2)
{
/* Apply permutations IPIV to RHS */
i__1 = *n - 1;
slaswp_(&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.f;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
bp = rhs[j] + 1.f;
bm = rhs[j] - 1.f;
splus = 1.f;
/* 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 += sdot_(&i__2, &z__[j + 1 + j * z_dim1], &c__1, &z__[j + 1 + j * z_dim1], &c__1);
i__2 = *n - j;
sminu = sdot_(&i__2, &z__[j + 1 + j * z_dim1], &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.f;
}
/* Compute the remaining r.h.s. */
temp = -rhs[j];
i__2 = *n - j;
saxpy_(&i__2, &temp, &z__[j + 1 + j * z_dim1], &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;
scopy_(&i__1, &rhs[1], &c__1, xp, &c__1);
xp[*n - 1] = rhs[*n] + 1.f;
rhs[*n] += -1.f;
splus = 0.f;
sminu = 0.f;
for (i__ = *n;
i__ >= 1;
--i__)
{
temp = 1.f / z__[i__ + i__ * z_dim1];
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__[i__ + k * z_dim1] * temp);
rhs[i__] -= rhs[k] * (z__[i__ + k * z_dim1] * temp);
/* L20: */
}
splus += (r__1 = xp[i__ - 1], abs(r__1));
sminu += (r__1 = rhs[i__], abs(r__1));
/* L30: */
}
if (splus > sminu)
{
scopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Apply the permutations JPIV to the computed solution (RHS) */
i__1 = *n - 1;
slaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1);
/* Compute the sum of squares */
slassq_(n, &rhs[1], &c__1, rdscal, rdsum);
}
else
{
/* IJOB = 2, Compute approximate nullvector XM of Z */
sgecon_("I", n, &z__[z_offset], ldz, &c_b23, &temp, work, iwork, & info);
scopy_(n, &work[*n], &c__1, xm, &c__1);
/* Compute RHS */
i__1 = *n - 1;
slaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1);
temp = 1.f / sqrt(sdot_(n, xm, &c__1, xm, &c__1));
sscal_(n, &temp, xm, &c__1);
scopy_(n, xm, &c__1, xp, &c__1);
saxpy_(n, &c_b23, &rhs[1], &c__1, xp, &c__1);
saxpy_(n, &c_b37, xm, &c__1, &rhs[1], &c__1);
sgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &temp);
sgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &temp);
if (sasum_(n, xp, &c__1) > sasum_(n, &rhs[1], &c__1))
{
scopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Compute the sum of squares */
slassq_(n, &rhs[1], &c__1, rdscal, rdsum);
}
return 0;
/* End of SLATDF */
}
/*< REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK ) >*/
doublereal slange_(char *norm, integer *m, integer *n, real *a, integer *lda,
real *work, ftnlen norm_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real ret_val, r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
real sum, scale;
extern logical lsame_(const char *, const char *, ftnlen, ftnlen);
real value=0;
extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
real *);
(void)norm_len;
/* -- 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 .. */
/*< CHARACTER NORM >*/
/*< INTEGER LDA, M, N >*/
/* .. */
/* .. Array Arguments .. */
/*< REAL A( LDA, * ), WORK( * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* SLANGE 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 */
/* =========== */
/* SLANGE returns the value */
/* SLANGE = ( 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 SLANGE as described */
/* above. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. When M = 0, */
/* SLANGE is set to zero. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. When N = 0, */
/* SLANGE is set to zero. */
/* A (input) REAL 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) REAL array, dimension (LWORK), */
/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* ===================================================================== */
/* .. Parameters .. */
/*< REAL ONE, ZERO >*/
/*< PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< INTEGER I, J >*/
/*< REAL SCALE, SUM, VALUE >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL SLASSQ >*/
/* .. */
/* .. External Functions .. */
/*< LOGICAL LSAME >*/
/*< EXTERNAL LSAME >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC ABS, MAX, MIN, SQRT >*/
/* .. */
/* .. Executable Statements .. */
/*< IF( MIN( M, N ).EQ.0 ) THEN >*/
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
/* Function Body */
if (min(*m,*n) == 0) {
/*< VALUE = ZERO >*/
value = (float)0.;
/*< ELSE IF( LSAME( NORM, 'M' ) ) THEN >*/
} else if (lsame_(norm, "M", (ftnlen)1, (ftnlen)1)) {
/* Find max(abs(A(i,j))). */
/*< VALUE = ZERO >*/
value = (float)0.;
/*< DO 20 J = 1, N >*/
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/*< DO 10 I = 1, M >*/
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< VALUE = MAX( VALUE, ABS( A( I, J ) ) ) >*/
/* Computing MAX */
r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
value = dmax(r__2,r__3);
/*< 10 CONTINUE >*/
/* L10: */
}
/*< 20 CONTINUE >*/
/* L20: */
}
/*< ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN >*/
} else if (lsame_(norm, "O", (ftnlen)1, (ftnlen)1) || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
/*< VALUE = ZERO >*/
value = (float)0.;
/*< DO 40 J = 1, N >*/
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/*< SUM = ZERO >*/
sum = (float)0.;
/*< DO 30 I = 1, M >*/
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< SUM = SUM + ABS( A( I, J ) ) >*/
sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
/*< 30 CONTINUE >*/
/* L30: */
}
/*< VALUE = MAX( VALUE, SUM ) >*/
value = dmax(value,sum);
/*< 40 CONTINUE >*/
/* L40: */
}
/*< ELSE IF( LSAME( NORM, 'I' ) ) THEN >*/
} else if (lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) {
/* Find normI(A). */
/*< DO 50 I = 1, M >*/
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< WORK( I ) = ZERO >*/
work[i__] = (float)0.;
/*< 50 CONTINUE >*/
/* L50: */
}
/*< DO 70 J = 1, N >*/
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/*< DO 60 I = 1, M >*/
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< WORK( I ) = WORK( I ) + ABS( A( I, J ) ) >*/
work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
/*< 60 CONTINUE >*/
/* L60: */
}
/*< 70 CONTINUE >*/
/* L70: */
}
/*< VALUE = ZERO >*/
value = (float)0.;
/*< DO 80 I = 1, M >*/
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< VALUE = MAX( VALUE, WORK( I ) ) >*/
/* Computing MAX */
r__1 = value, r__2 = work[i__];
value = dmax(r__1,r__2);
/*< 80 CONTINUE >*/
/* L80: */
}
/*< ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN >*/
} else if (lsame_(norm, "F", (ftnlen)1, (ftnlen)1) || lsame_(norm, "E", (
ftnlen)1, (ftnlen)1)) {
/* Find normF(A). */
/*< SCALE = ZERO >*/
scale = (float)0.;
/*< SUM = ONE >*/
sum = (float)1.;
/*< DO 90 J = 1, N >*/
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/*< CALL SLASSQ( M, A( 1, J ), 1, SCALE, SUM ) >*/
slassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/*< 90 CONTINUE >*/
/* L90: */
}
/*< VALUE = SCALE*SQRT( SUM ) >*/
value = scale * sqrt(sum);
/*< END IF >*/
}
/*< SLANGE = VALUE >*/
ret_val = value;
/*< RETURN >*/
return ret_val;
/* End of SLANGE */
/*< END >*/
} /* slange_ */
doublereal clanht_(char *norm, integer *n, real *d__, complex *e)
{
/* System generated locals */
integer i__1;
real ret_val, r__1, r__2, r__3;
/* Local variables */
integer i__;
real sum, scale;
real anorm;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CLANHT 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 */
/* =========== */
/* CLANHT returns the value */
/* CLANHT = ( 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 CLANHT as described */
/* above. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, CLANHT is */
/* set to zero. */
/* D (input) REAL array, dimension (N) */
/* The diagonal elements of A. */
/* E (input) COMPLEX array, dimension (N-1) */
/* The (n-1) sub-diagonal or super-diagonal elements of A. */
/* ===================================================================== */
/* Parameter adjustments */
--e;
--d__;
/* Function Body */
if (*n <= 0) {
anorm = 0.f;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
anorm = (r__1 = d__[*n], dabs(r__1));
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = anorm, r__3 = (r__1 = d__[i__], dabs(r__1));
anorm = dmax(r__2,r__3);
/* Computing MAX */
r__1 = anorm, r__2 = c_abs(&e[i__]);
anorm = dmax(r__1,r__2);
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1' || lsame_(norm, "I")) {
/* Find norm1(A). */
if (*n == 1) {
anorm = dabs(d__[1]);
} else {
/* Computing MAX */
r__2 = dabs(d__[1]) + c_abs(&e[1]), r__3 = c_abs(&e[*n - 1]) + (
r__1 = d__[*n], dabs(r__1));
anorm = dmax(r__2,r__3);
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = anorm, r__3 = (r__1 = d__[i__], dabs(r__1)) + c_abs(&e[
i__]) + c_abs(&e[i__ - 1]);
anorm = dmax(r__2,r__3);
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
if (*n > 1) {
i__1 = *n - 1;
classq_(&i__1, &e[1], &c__1, &scale, &sum);
sum *= 2;
}
slassq_(n, &d__[1], &c__1, &scale, &sum);
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of CLANHT */
} /* clanht_ */
/* Subroutine */ int ssyequb_(char *uplo, integer *n, real *a, integer *lda,
real *s, real *scond, real *amax, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real r__1, r__2, r__3;
/* Local variables */
real d__;
integer i__, j;
real t, u, c0, c1, c2, si;
logical up;
real avg, std, tol, base;
integer iter;
real smin, smax, scale;
real sumsq;
real bignum;
real 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. -- */
/* Purpose */
/* ======= */
/* SSYEQUB 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) REAL 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) REAL array, dimension (N) */
/* If INFO = 0, S contains the scale factors for A. */
/* SCOND (output) REAL */
/* 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) REAL */
/* 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 */
/* ===================================================================== */
/* 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_("SSYEQUB", &i__1);
return 0;
}
up = lsame_(uplo, "U");
*amax = 0.f;
/* Quick return if possible. */
if (*n == 0) {
*scond = 1.f;
return 0;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
s[i__] = 0.f;
}
*amax = 0.f;
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 */
r__2 = s[i__], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1))
;
s[i__] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = s[j], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
s[j] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = *amax, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
*amax = dmax(r__2,r__3);
}
/* Computing MAX */
r__2 = s[j], r__3 = (r__1 = a[j + j * a_dim1], dabs(r__1));
s[j] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = *amax, r__3 = (r__1 = a[j + j * a_dim1], dabs(r__1));
*amax = dmax(r__2,r__3);
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__2 = s[j], r__3 = (r__1 = a[j + j * a_dim1], dabs(r__1));
s[j] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = *amax, r__3 = (r__1 = a[j + j * a_dim1], dabs(r__1));
*amax = dmax(r__2,r__3);
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = s[i__], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1))
;
s[i__] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = s[j], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
s[j] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = *amax, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
*amax = dmax(r__2,r__3);
}
}
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
s[j] = 1.f / s[j];
}
tol = 1.f / sqrt(*n * 2.f);
for (iter = 1; iter <= 100; ++iter) {
scale = 0.f;
sumsq = 0.f;
/* BETA = |A|S */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
}
if (up) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
t = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * s[
j];
work[j] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * s[
i__];
}
work[j] += (r__1 = a[j + j * a_dim1], dabs(r__1)) * s[j];
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
work[j] += (r__1 = a[j + j * a_dim1], dabs(r__1)) * s[j];
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
t = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * s[
j];
work[j] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * s[
i__];
}
}
}
/* avg = s^T beta / n */
avg = 0.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
avg += s[i__] * work[i__];
}
avg /= *n;
std = 0.f;
i__1 = *n * 3;
for (i__ = (*n << 1) + 1; i__ <= i__1; ++i__) {
work[i__] = s[i__ - (*n << 1)] * work[i__ - (*n << 1)] - avg;
}
slassq_(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 = (r__1 = a[i__ + i__ * a_dim1], dabs(r__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.f) {
*info = -1;
return 0;
}
si = c0 * -2 / (c1 + sqrt(d__));
d__ = si - s[i__];
u = 0.f;
if (up) {
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
t = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
u += s[j] * t;
work[j] += d__ * t;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
t = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
u += s[j] * t;
work[j] += d__ * t;
}
} else {
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
t = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
u += s[j] * t;
work[j] += d__ * t;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
t = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
u += s[j] * t;
work[j] += d__ * t;
}
}
avg += (u + work[i__]) * d__ / *n;
s[i__] = si;
}
}
L999:
smlnum = slamch_("SAFEMIN");
bignum = 1.f / smlnum;
smin = bignum;
smax = 0.f;
t = 1.f / sqrt(avg);
base = slamch_("B");
u = 1.f / log(base);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = (integer) (u * log(s[i__] * t));
s[i__] = pow_ri(&base, &i__2);
/* Computing MIN */
r__1 = smin, r__2 = s[i__];
smin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = smax, r__2 = s[i__];
smax = dmax(r__1,r__2);
}
*scond = dmax(smin,smlnum) / dmin(smax,bignum);
return 0;
} /* ssyequb_ */
doublereal slansb_(char *norm, char *uplo, integer *n, integer *k, real *ab,
integer *ldab, real *work)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
real ret_val, r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, l;
real sum, absa, scale;
extern logical lsame_(char *, char *);
real value;
extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
real *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLANSB 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 */
/* =========== */
/* SLANSB returns the value */
/* SLANSB = ( 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 SLANSB 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, SLANSB is */
/* set to zero. */
/* K (input) INTEGER */
/* The number of super-diagonals or sub-diagonals of the */
/* band matrix A. K >= 0. */
/* AB (input) REAL 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) REAL 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.f;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.f;
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 */
r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1], dabs(
r__1));
value = dmax(r__2,r__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 */
r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1], dabs(
r__1));
value = dmax(r__2,r__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.f;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.f;
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 = (r__1 = ab[l + i__ + j * ab_dim1], dabs(r__1));
sum += absa;
work[i__] += absa;
/* L50: */
}
work[j] = sum + (r__1 = ab[*k + 1 + j * ab_dim1], dabs(r__1));
/* L60: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = value, r__2 = work[i__];
value = dmax(r__1,r__2);
/* L70: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
/* L80: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = work[j] + (r__1 = ab[j * ab_dim1 + 1], dabs(r__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 = (r__1 = ab[l + i__ + j * ab_dim1], dabs(r__1));
sum += absa;
work[i__] += absa;
/* L90: */
}
value = dmax(value,sum);
/* L100: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
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;
slassq_(&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);
slassq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, &scale, &sum);
/* L120: */
}
l = 1;
}
sum *= 2;
} else {
l = 1;
}
slassq_(n, &ab[l + ab_dim1], ldab, &scale, &sum);
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANSB */
} /* slansb_ */
/* ===================================================================== */
real slantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, real *a, integer *lda, real *work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
real ret_val, r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
real sum, scale;
logical udiag;
extern logical lsame_(char *, char *);
real value;
extern logical sisnan_(real *);
extern /* Subroutine */
int slassq_(integer *, real *, integer *, real *, real *);
/* -- 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 */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
/* Function Body */
if (min(*m,*n) == 0)
{
value = 0.f;
}
else if (lsame_(norm, "M"))
{
/* Find max(f2c_abs(A(i,j))). */
if (lsame_(diag, "U"))
{
value = 1.f;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
i__3 = *m;
i__4 = j - 1; // , expr subst
i__2 = min(i__3,i__4);
for (i__ = 1;
i__ <= i__2;
++i__)
{
sum = (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L10: */
}
/* L20: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *m;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
sum = (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L30: */
}
/* L40: */
}
}
}
else
{
value = 0.f;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = min(*m,j);
for (i__ = 1;
i__ <= i__2;
++i__)
{
sum = (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L50: */
}
/* L60: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *m;
for (i__ = j;
i__ <= i__2;
++i__)
{
sum = (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L70: */
}
/* L80: */
}
}
}
}
else if (lsame_(norm, "O") || *(unsigned char *) norm == '1')
{
/* Find norm1(A). */
value = 0.f;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (udiag && j <= *m)
{
sum = 1.f;
i__2 = j - 1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
sum += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
/* L90: */
}
}
else
{
sum = 0.f;
i__2 = min(*m,j);
for (i__ = 1;
i__ <= i__2;
++i__)
{
sum += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
/* L100: */
}
}
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L110: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (udiag)
{
sum = 1.f;
i__2 = *m;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
sum += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
/* L120: */
}
}
else
{
sum = 0.f;
i__2 = *m;
for (i__ = j;
i__ <= i__2;
++i__)
{
sum += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
/* L130: */
}
}
if (value < sum || sisnan_(&sum))
{
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__ <= i__1;
++i__)
{
work[i__] = 1.f;
/* L150: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
i__3 = *m;
i__4 = j - 1; // , expr subst
i__2 = min(i__3,i__4);
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[i__] += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
/* L160: */
}
/* L170: */
}
}
else
{
i__1 = *m;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.f;
/* 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__] += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
/* L190: */
}
/* L200: */
}
}
}
else
{
if (lsame_(diag, "U"))
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 1.f;
/* L210: */
}
i__1 = *m;
for (i__ = *n + 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.f;
/* L220: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *m;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
work[i__] += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
/* L230: */
}
/* L240: */
}
}
else
{
i__1 = *m;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.f;
/* L250: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *m;
for (i__ = j;
i__ <= i__2;
++i__)
{
work[i__] += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
/* L260: */
}
/* L270: */
}
}
}
value = 0.f;
i__1 = *m;
for (i__ = 1;
i__ <= i__1;
++i__)
{
sum = work[i__];
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L280: */
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
if (lsame_(uplo, "U"))
{
if (lsame_(diag, "U"))
{
scale = 1.f;
sum = (real) min(*m,*n);
i__1 = *n;
for (j = 2;
j <= i__1;
++j)
{
/* Computing MIN */
i__3 = *m;
i__4 = j - 1; // , expr subst
i__2 = min(i__3,i__4);
slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L290: */
}
}
else
{
scale = 0.f;
sum = 1.f;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = min(*m,j);
slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L300: */
}
}
}
else
{
if (lsame_(diag, "U"))
{
scale = 1.f;
sum = (real) 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; // , expr subst
slassq_(&i__2, &a[min(i__3,i__4) + j * a_dim1], &c__1, & scale, &sum);
/* L310: */
}
}
else
{
scale = 0.f;
sum = 1.f;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *m - j + 1;
slassq_(&i__2, &a[j + j * a_dim1], &c__1, &scale, &sum);
/* L320: */
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANTR */
}
/* Subroutine */ int stgsen_(integer *ijob, logical *wantq, logical *wantz,
logical *select, integer *n, real *a, integer *lda, real *b, integer *
ldb, real *alphar, real *alphai, real *beta, real *q, integer *ldq,
real *z__, integer *ldz, integer *m, real *pl, real *pr, real *dif,
real *work, integer *lwork, integer *iwork, integer *liwork, integer *
info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
STGSEN 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 SGGES), i.e. A is block upper
triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper
triangular.
STGSEN also computes the generalized eigenvalues
w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)
of the reordered matrix pair (A, B).
Optionally, STGSEN 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) REAL 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) REAL 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) REAL array, dimension (N)
ALPHAI (output) REAL array, dimension (N)
BETA (output) REAL 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) REAL 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) REAL 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) REAL
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) REAL 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) REAL 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
===============
STGSEN 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 SLATDF), then the parameter
IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF
(IJOB = 2 will be used)). See STGSYL 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 */
/* Table of constant values */
static integer c__1 = 1;
static integer c__2 = 2;
static real c_b28 = 1.f;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double sqrt(doublereal), r_sign(real *, real *);
/* Local variables */
static integer kase;
static logical pair;
static integer ierr;
static real dsum;
static logical swap;
extern /* Subroutine */ int slag2_(real *, integer *, real *, integer *,
real *, real *, real *, real *, real *, real *);
static integer i__, k;
static logical wantd;
static integer lwmin;
static logical wantp;
static integer n1, n2;
static logical wantd1, wantd2;
static integer kk;
static real dscale;
static integer ks;
static real rdscal;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *), slacon_(
integer *, real *, real *, integer *, real *, integer *), slacpy_(
char *, integer *, integer *, real *, integer *, real *, integer *
), stgexc_(logical *, logical *, integer *, real *,
integer *, real *, integer *, real *, integer *, real *, integer *
, integer *, integer *, real *, integer *, integer *);
static integer liwmin;
extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
real *);
static real smlnum;
static integer mn2;
static logical lquery;
extern /* Subroutine */ int stgsyl_(char *, integer *, integer *, integer
*, real *, integer *, real *, integer *, real *, integer *, real *
, integer *, real *, integer *, real *, integer *, real *, real *,
real *, integer *, integer *, integer *);
static integer ijb;
static real eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
--select;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alphar;
--alphai;
--beta;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
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_("STGSEN", &i__1);
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("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_ref(k + 1, k) == 0.f) {
if (select[k]) {
++(*m);
}
} else {
pair = TRUE_;
if (select[k] || select[k + 1]) {
*m += 2;
}
}
} else {
if (select[*n]) {
++(*m);
}
}
}
/* L10: */
}
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] = (real) lwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -22;
} else if (*liwork < liwmin && ! lquery) {
*info = -24;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STGSEN", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible. */
if (*m == *n || *m == 0) {
if (wantp) {
*pl = 1.f;
*pr = 1.f;
}
if (wantd) {
dscale = 0.f;
dsum = 1.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
slassq_(n, &a_ref(1, i__), &c__1, &dscale, &dsum);
slassq_(n, &b_ref(1, i__), &c__1, &dscale, &dsum);
/* L20: */
}
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_ref(k + 1, k) != 0.f) {
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) {
stgexc_(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.f;
*pr = 0.f;
}
if (wantd) {
dif[1] = 0.f;
dif[2] = 0.f;
}
goto L60;
}
if (pair) {
++ks;
}
}
}
/* L30: */
}
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;
slacpy_("Full", &n1, &n2, &a_ref(1, i__), lda, &work[1], &n1);
slacpy_("Full", &n1, &n2, &b_ref(1, i__), ldb, &work[n1 * n2 + 1], &
n1);
i__1 = *lwork - (n1 << 1) * n2;
stgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(i__, i__), lda,
&work[1], &n1, &b[b_offset], ldb, &b_ref(i__, i__), 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.f;
dsum = 1.f;
i__1 = n1 * n2;
slassq_(&i__1, &work[1], &c__1, &rdscal, &dsum);
*pl = rdscal * sqrt(dsum);
if (*pl == 0.f) {
*pl = 1.f;
} else {
*pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl));
}
rdscal = 0.f;
dsum = 1.f;
i__1 = n1 * n2;
slassq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum);
*pr = rdscal * sqrt(dsum);
if (*pr == 0.f) {
*pr = 1.f;
} 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;
stgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(i__, i__),
lda, &work[1], &n1, &b[b_offset], ldb, &b_ref(i__, i__),
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;
stgsyl_("N", &ijb, &n2, &n1, &a_ref(i__, i__), lda, &a[a_offset],
lda, &work[1], &n2, &b_ref(i__, i__), 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 SLACON. 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:
slacon_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[1], &kase)
;
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation. */
i__1 = *lwork - (n1 << 1) * n2;
stgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(
i__, i__), lda, &work[1], &n1, &b[b_offset], ldb,
&b_ref(i__, i__), 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;
stgsyl_("T", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(
i__, i__), lda, &work[1], &n1, &b[b_offset], ldb,
&b_ref(i__, i__), 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:
slacon_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[2], &kase)
;
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation. */
i__1 = *lwork - (n1 << 1) * n2;
stgsyl_("N", &ijb, &n2, &n1, &a_ref(i__, i__), lda, &a[
a_offset], lda, &work[1], &n2, &b_ref(i__, i__),
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;
stgsyl_("T", &ijb, &n2, &n1, &a_ref(i__, i__), lda, &a[
a_offset], lda, &work[1], &n2, &b_ref(i__, i__),
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_ref(k + 1, k) != 0.f) {
pair = TRUE_;
}
}
if (pair) {
/* Compute the eigenvalue(s) at position K. */
work[1] = a_ref(k, k);
work[2] = a_ref(k + 1, k);
work[3] = a_ref(k, k + 1);
work[4] = a_ref(k + 1, k + 1);
work[5] = b_ref(k, k);
work[6] = b_ref(k + 1, k);
work[7] = b_ref(k, k + 1);
work[8] = b_ref(k + 1, k + 1);
r__1 = smlnum * eps;
slag2_(&work[1], &c__2, &work[5], &c__2, &r__1, &beta[k], &
beta[k + 1], &alphar[k], &alphar[k + 1], &alphai[k]);
alphai[k + 1] = -alphai[k];
} else {
if (r_sign(&c_b28, &b_ref(k, k)) < 0.f) {
/* If B(K,K) is negative, make it positive */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
a_ref(k, i__) = -a_ref(k, i__);
b_ref(k, i__) = -b_ref(k, i__);
q_ref(i__, k) = -q_ref(i__, k);
/* L80: */
}
}
alphar[k] = a_ref(k, k);
alphai[k] = 0.f;
beta[k] = b_ref(k, k);
}
}
/* L70: */
}
work[1] = (real) lwmin;
iwork[1] = liwmin;
return 0;
/* End of STGSEN */
} /* stgsen_ */
doublereal slansp_(char *norm, char *uplo, integer *n, real *ap, real *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
=======
SLANSP 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 matrix A, supplied in packed form.
Description
===========
SLANSP returns the value
SLANSP = ( 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 SLANSP 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, SLANSP is
set to zero.
AP (input) REAL 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) REAL array, dimension (LWORK),
where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
WORK is not referenced.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer i__1, i__2;
real ret_val, r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static real absa;
static integer i__, j, k;
static real scale;
extern logical lsame_(char *, char *);
static real value;
extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
real *);
static real sum;
--work;
--ap;
/* Function Body */
if (*n == 0) {
value = 0.f;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.f;
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 */
r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1));
value = dmax(r__2,r__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 */
r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1));
value = dmax(r__2,r__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.f;
k = 1;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.f;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
absa = (r__1 = ap[k], dabs(r__1));
sum += absa;
work[i__] += absa;
++k;
/* L50: */
}
work[j] = sum + (r__1 = ap[k], dabs(r__1));
++k;
/* L60: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = value, r__2 = work[i__];
value = dmax(r__1,r__2);
/* L70: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
/* L80: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = work[j] + (r__1 = ap[k], dabs(r__1));
++k;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
absa = (r__1 = ap[k], dabs(r__1));
sum += absa;
work[i__] += absa;
++k;
/* L90: */
}
value = dmax(value,sum);
/* L100: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
k = 2;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
slassq_(&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;
slassq_(&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.f) {
absa = (r__1 = ap[k], dabs(r__1));
if (scale < absa) {
/* Computing 2nd power */
r__1 = scale / absa;
sum = sum * (r__1 * r__1) + 1.f;
scale = absa;
} else {
/* Computing 2nd power */
r__1 = absa / scale;
sum += r__1 * r__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 SLANSP */
} /* slansp_ */
double slange_(char *norm, int *m, int *n, float *a, int *lda,
float *work)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2;
float ret_val, r__1, r__2, r__3;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int i__, j;
float sum, scale;
extern int lsame_(char *, char *);
float value;
extern int slassq_(int *, float *, int *, float *,
float *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLANGE 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 matrix A. */
/* Description */
/* =========== */
/* SLANGE returns the value */
/* SLANGE = ( 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 SLANGE as described */
/* above. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. When M = 0, */
/* SLANGE is set to zero. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. When N = 0, */
/* SLANGE is set to zero. */
/* A (input) REAL 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) REAL 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.f;
} else if (lsame_(norm, "M")) {
/* Find MAX(ABS(A(i,j))). */
value = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], ABS(r__1));
value = MAX(r__2,r__3);
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.f;
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
sum += (r__1 = a[i__ + j * a_dim1], ABS(r__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.f;
/* L50: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (r__1 = a[i__ + j * a_dim1], ABS(r__1));
/* L60: */
}
/* L70: */
}
value = 0.f;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = value, r__2 = work[i__];
value = MAX(r__1,r__2);
/* L80: */
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
slassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANGE */
} /* slange_ */
doublereal slanst_(char *norm, integer *n, real *d__, real *e)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
SLANST 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
===========
SLANST returns the value
SLANST = ( 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 SLANST as described
above.
N (input) INTEGER
The order of the matrix A. N >= 0. When N = 0, SLANST is
set to zero.
D (input) REAL array, dimension (N)
The diagonal elements of A.
E (input) REAL 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;
real ret_val, r__1, r__2, r__3, r__4, r__5;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__;
static real scale;
extern logical lsame_(char *, char *);
static real anorm;
extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
real *);
static real sum;
--e;
--d__;
/* Function Body */
if (*n <= 0) {
anorm = 0.f;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
anorm = (r__1 = d__[*n], dabs(r__1));
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = anorm, r__3 = (r__1 = d__[i__], dabs(r__1));
anorm = dmax(r__2,r__3);
/* Computing MAX */
r__2 = anorm, r__3 = (r__1 = e[i__], dabs(r__1));
anorm = dmax(r__2,r__3);
/* L10: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1' || lsame_(norm, "I")) {
/* Find norm1(A). */
if (*n == 1) {
anorm = dabs(d__[1]);
} else {
/* Computing MAX */
r__3 = dabs(d__[1]) + dabs(e[1]), r__4 = (r__1 = e[*n - 1], dabs(
r__1)) + (r__2 = d__[*n], dabs(r__2));
anorm = dmax(r__3,r__4);
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
r__4 = anorm, r__5 = (r__1 = d__[i__], dabs(r__1)) + (r__2 =
e[i__], dabs(r__2)) + (r__3 = e[i__ - 1], dabs(r__3));
anorm = dmax(r__4,r__5);
/* L20: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
if (*n > 1) {
i__1 = *n - 1;
slassq_(&i__1, &e[1], &c__1, &scale, &sum);
sum *= 2;
}
slassq_(n, &d__[1], &c__1, &scale, &sum);
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of SLANST */
} /* slanst_ */
doublereal slantp_(char *norm, char *uplo, char *diag, integer *n, real *ap,
real *work)
{
/* System generated locals */
integer i__1, i__2;
real ret_val, r__1, r__2, r__3;
/* Local variables */
integer i__, j, k;
real sum, scale;
logical udiag;
real value;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SLANTP 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 */
/* =========== */
/* SLANTP returns the value */
/* SLANTP = ( 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 SLANTP 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, SLANTP is */
/* set to zero. */
/* AP (input) REAL 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) REAL array, dimension (MAX(1,LWORK)), */
/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* ===================================================================== */
/* Parameter adjustments */
--work;
--ap;
/* Function Body */
if (*n == 0) {
value = 0.f;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
k = 1;
if (lsame_(diag, "U")) {
value = 1.f;
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 */
r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1));
value = dmax(r__2,r__3);
}
k += j;
}
} 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 */
r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1));
value = dmax(r__2,r__3);
}
k = k + *n - j + 1;
}
}
} else {
value = 0.f;
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 */
r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1));
value = dmax(r__2,r__3);
}
k += j;
}
} 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 */
r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1));
value = dmax(r__2,r__3);
}
k = k + *n - j + 1;
}
}
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.f;
k = 1;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.f;
i__2 = k + j - 2;
for (i__ = k; i__ <= i__2; ++i__) {
sum += (r__1 = ap[i__], dabs(r__1));
}
} else {
sum = 0.f;
i__2 = k + j - 1;
for (i__ = k; i__ <= i__2; ++i__) {
sum += (r__1 = ap[i__], dabs(r__1));
}
}
k += j;
value = dmax(value,sum);
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.f;
i__2 = k + *n - j;
for (i__ = k + 1; i__ <= i__2; ++i__) {
sum += (r__1 = ap[i__], dabs(r__1));
}
} else {
sum = 0.f;
i__2 = k + *n - j;
for (i__ = k; i__ <= i__2; ++i__) {
sum += (r__1 = ap[i__], dabs(r__1));
}
}
k = k + *n - j + 1;
value = dmax(value,sum);
}
}
} 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.f;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (r__1 = ap[k], dabs(r__1));
++k;
}
++k;
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (r__1 = ap[k], dabs(r__1));
++k;
}
}
}
} else {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.f;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
++k;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work[i__] += (r__1 = ap[k], dabs(r__1));
++k;
}
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
work[i__] += (r__1 = ap[k], dabs(r__1));
++k;
}
}
}
}
value = 0.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = value, r__2 = work[i__];
value = dmax(r__1,r__2);
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
scale = 1.f;
sum = (real) (*n);
k = 2;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
slassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k += j;
}
} else {
scale = 0.f;
sum = 1.f;
k = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
slassq_(&j, &ap[k], &c__1, &scale, &sum);
k += j;
}
}
} else {
if (lsame_(diag, "U")) {
scale = 1.f;
sum = (real) (*n);
k = 2;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
slassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k = k + *n - j + 1;
}
} else {
scale = 0.f;
sum = 1.f;
k = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
slassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k = k + *n - j + 1;
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANTP */
} /* slantp_ */
doublereal slantb_(char *norm, char *uplo, char *diag, integer *n, integer *k,
real *ab, integer *ldab, real *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
=======
SLANTB 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
===========
SLANTB returns the value
SLANTB = ( 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 SLANTB 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, SLANTB 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) REAL 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) REAL 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;
real ret_val, r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__, j, l;
static real scale;
static logical udiag;
extern logical lsame_(char *, char *);
static real value;
extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
real *);
static real 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.f;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
if (lsame_(diag, "U")) {
value = 1.f;
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 */
r__2 = value, r__3 = (r__1 = ab_ref(i__, j), dabs(
r__1));
value = dmax(r__2,r__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 */
r__2 = value, r__3 = (r__1 = ab_ref(i__, j), dabs(
r__1));
value = dmax(r__2,r__3);
/* L30: */
}
/* L40: */
}
}
} else {
value = 0.f;
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 */
r__2 = value, r__3 = (r__1 = ab_ref(i__, j), dabs(
r__1));
value = dmax(r__2,r__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 */
r__2 = value, r__3 = (r__1 = ab_ref(i__, j), dabs(
r__1));
value = dmax(r__2,r__3);
/* L70: */
}
/* L80: */
}
}
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.f;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.f;
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
sum += (r__1 = ab_ref(i__, j), dabs(r__1));
/* L90: */
}
} else {
sum = 0.f;
/* Computing MAX */
i__3 = *k + 2 - j;
i__2 = *k + 1;
for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
sum += (r__1 = ab_ref(i__, j), dabs(r__1));
/* L100: */
}
}
value = dmax(value,sum);
/* L110: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.f;
/* 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 += (r__1 = ab_ref(i__, j), dabs(r__1));
/* L120: */
}
} else {
sum = 0.f;
/* 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 += (r__1 = ab_ref(i__, j), dabs(r__1));
/* L130: */
}
}
value = dmax(value,sum);
/* L140: */
}
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
value = 0.f;
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.f;
/* 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__] += (r__1 = ab_ref(l + i__, j), dabs(r__1));
/* L160: */
}
/* L170: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
/* 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__] += (r__1 = ab_ref(l + i__, j), dabs(r__1));
/* L190: */
}
/* L200: */
}
}
} else {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.f;
/* 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__] += (r__1 = ab_ref(l + i__, j), dabs(r__1));
/* L220: */
}
/* L230: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
/* 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__] += (r__1 = ab_ref(l + i__, j), dabs(r__1));
/* L250: */
}
/* L260: */
}
}
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = value, r__2 = work[i__];
value = dmax(r__1,r__2);
/* L270: */
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
scale = 1.f;
sum = (real) (*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);
slassq_(&i__4, &ab_ref(max(i__3,1), j), &c__1, &scale,
&sum);
/* L280: */
}
}
} else {
scale = 0.f;
sum = 1.f;
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);
slassq_(&i__4, &ab_ref(max(i__3,1), j), &c__1, &scale, &
sum);
/* L290: */
}
}
} else {
if (lsame_(diag, "U")) {
scale = 1.f;
sum = (real) (*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);
slassq_(&i__3, &ab_ref(2, j), &c__1, &scale, &sum);
/* L300: */
}
}
} else {
scale = 0.f;
sum = 1.f;
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);
slassq_(&i__3, &ab_ref(1, j), &c__1, &scale, &sum);
/* L310: */
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANTB */
} /* slantb_ */
doublereal slantb_(char *norm, char *uplo, char *diag, integer *n, integer *k,
real *ab, integer *ldab, real *work)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
real ret_val, r__1, r__2, r__3;
/* Local variables */
integer i__, j, l;
real sum, scale;
logical udiag;
real value;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SLANTB 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 */
/* =========== */
/* SLANTB returns the value */
/* SLANTB = ( 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 SLANTB 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, SLANTB 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) REAL 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) REAL 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.f;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
if (lsame_(diag, "U")) {
value = 1.f;
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 */
r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1],
dabs(r__1));
value = dmax(r__2,r__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 */
r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1],
dabs(r__1));
value = dmax(r__2,r__3);
}
}
}
} else {
value = 0.f;
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 */
r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1],
dabs(r__1));
value = dmax(r__2,r__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 */
r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1],
dabs(r__1));
value = dmax(r__2,r__3);
}
}
}
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.f;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.f;
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
sum += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1));
}
} else {
sum = 0.f;
/* Computing MAX */
i__3 = *k + 2 - j;
i__2 = *k + 1;
for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
sum += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1));
}
}
value = dmax(value,sum);
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.f;
/* 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 += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1));
}
} else {
sum = 0.f;
/* 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 += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1));
}
}
value = dmax(value,sum);
}
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
value = 0.f;
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.f;
}
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__] += (r__1 = ab[l + i__ + j * ab_dim1], dabs(
r__1));
}
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
}
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__] += (r__1 = ab[l + i__ + j * ab_dim1], dabs(
r__1));
}
}
}
} else {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.f;
}
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__] += (r__1 = ab[l + i__ + j * ab_dim1], dabs(
r__1));
}
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
}
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__] += (r__1 = ab[l + i__ + j * ab_dim1], dabs(
r__1));
}
}
}
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = value, r__2 = work[i__];
value = dmax(r__1,r__2);
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
scale = 1.f;
sum = (real) (*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;
slassq_(&i__3, &ab[max(i__2, 1)+ j * ab_dim1], &c__1,
&scale, &sum);
}
}
} else {
scale = 0.f;
sum = 1.f;
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;
slassq_(&i__3, &ab[max(i__5, 1)+ j * ab_dim1], &c__1, &
scale, &sum);
}
}
} else {
if (lsame_(diag, "U")) {
scale = 1.f;
sum = (real) (*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);
slassq_(&i__3, &ab[j * ab_dim1 + 2], &c__1, &scale, &
sum);
}
}
} else {
scale = 0.f;
sum = 1.f;
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);
slassq_(&i__3, &ab[j * ab_dim1 + 1], &c__1, &scale, &sum);
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANTB */
} /* slantb_ */
doublereal slansy_(char *norm, char *uplo, integer *n, real *a, integer *lda,
real *work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real ret_val, r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
real sum, absa, scale;
extern logical lsame_(char *, char *);
real value;
extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
real *);
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLANSY 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 matrix A. */
/* Description */
/* =========== */
/* SLANSY returns the value */
/* SLANSY = ( 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 SLANSY 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, SLANSY is */
/* set to zero. */
/* A (input) REAL 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) REAL 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.f;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.f;
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 */
r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(
r__1));
value = dmax(r__2,r__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 */
r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(
r__1));
value = dmax(r__2,r__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.f;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.f;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
absa = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
sum += absa;
work[i__] += absa;
/* L50: */
}
work[j] = sum + (r__1 = a[j + j * a_dim1], dabs(r__1));
/* L60: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = value, r__2 = work[i__];
value = dmax(r__1,r__2);
/* L70: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
/* L80: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = work[j] + (r__1 = a[j + j * a_dim1], dabs(r__1));
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
absa = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
sum += absa;
work[i__] += absa;
/* L90: */
}
value = dmax(value,sum);
/* L100: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
slassq_(&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;
slassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum);
/* L120: */
}
}
sum *= 2;
i__1 = *lda + 1;
slassq_(n, &a[a_offset], &i__1, &scale, &sum);
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANSY */
} /* slansy_ */
/* ===================================================================== */
real slanst_(char *norm, integer *n, real *d__, real *e)
{
/* System generated locals */
integer i__1;
real ret_val, r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
real sum, scale;
extern logical lsame_(char *, char *);
real anorm;
extern logical sisnan_(real *);
extern /* Subroutine */
int slassq_(integer *, real *, integer *, real *, real *);
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--e;
--d__;
/* Function Body */
if (*n <= 0)
{
anorm = 0.f;
}
else if (lsame_(norm, "M"))
{
/* Find max(f2c_abs(A(i,j))). */
anorm = (r__1 = d__[*n], f2c_abs(r__1));
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
sum = (r__1 = d__[i__], f2c_abs(r__1));
if (anorm < sum || sisnan_(&sum))
{
anorm = sum;
}
sum = (r__1 = e[i__], f2c_abs(r__1));
if (anorm < sum || sisnan_(&sum))
{
anorm = sum;
}
/* L10: */
}
}
else if (lsame_(norm, "O") || *(unsigned char *) norm == '1' || lsame_(norm, "I"))
{
/* Find norm1(A). */
if (*n == 1)
{
anorm = f2c_abs(d__[1]);
}
else
{
anorm = f2c_abs(d__[1]) + f2c_abs(e[1]);
sum = (r__1 = e[*n - 1], f2c_abs(r__1)) + (r__2 = d__[*n], f2c_abs(r__2));
if (anorm < sum || sisnan_(&sum))
{
anorm = sum;
}
i__1 = *n - 1;
for (i__ = 2;
i__ <= i__1;
++i__)
{
sum = (r__1 = d__[i__], f2c_abs(r__1)) + (r__2 = e[i__], f2c_abs(r__2) ) + (r__3 = e[i__ - 1], f2c_abs(r__3));
if (anorm < sum || sisnan_(&sum))
{
anorm = sum;
}
/* L20: */
}
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
if (*n > 1)
{
i__1 = *n - 1;
slassq_(&i__1, &e[1], &c__1, &scale, &sum);
sum *= 2;
}
slassq_(n, &d__[1], &c__1, &scale, &sum);
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of SLANST */
}
/* Subroutine */ int stgex2_(logical *wantq, logical *wantz, integer *n, real
*a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real *
z__, integer *ldz, integer *j1, integer *n1, integer *n2, real *work,
integer *lwork, 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;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
real f, g;
integer i__, m;
real s[16] /* was [4][4] */, t[16] /* was [4][4] */, be[2], ai[2], ar[2],
sa, sb, li[16] /* was [4][4] */, ir[16] /* was [4][4]
*/, ss, ws, eps;
logical weak;
real ddum;
integer idum;
real taul[4], dsum, taur[4], scpy[16] /* was [4][4] */, tcpy[16]
/* was [4][4] */;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
real scale, bqra21, brqa21;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real licop[16] /* was [4][4] */;
integer linfo;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
real ircop[16] /* was [4][4] */, dnorm;
integer iwork[4];
extern /* Subroutine */ int slagv2_(real *, integer *, real *, integer *,
real *, real *, real *, real *, real *, real *, real *), sgeqr2_(
integer *, integer *, real *, integer *, real *, real *, integer *
), sgerq2_(integer *, integer *, real *, integer *, real *, real *
, integer *), sorg2r_(integer *, integer *, integer *, real *,
integer *, real *, real *, integer *), sorgr2_(integer *, integer
*, integer *, real *, integer *, real *, real *, integer *),
sorm2r_(char *, char *, integer *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *, integer *), sormr2_(char *, char *, integer *, integer *, integer *,
real *, integer *, real *, real *, integer *, real *, integer *);
real dscale;
extern /* Subroutine */ int stgsy2_(char *, integer *, integer *, integer
*, real *, integer *, real *, integer *, real *, integer *, real *
, integer *, real *, integer *, real *, integer *, real *, real *,
real *, integer *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slartg_(real *, real *,
real *, real *, real *);
real thresh;
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *), slassq_(integer *, real *,
integer *, real *, real *);
real smlnum;
logical strong;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) */
/* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair */
/* (A, B) by an orthogonal equivalence transformation. */
/* (A, B) must be in generalized real Schur canonical form (as returned */
/* by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */
/* diagonal blocks. B is upper triangular. */
/* Optionally, the matrices Q and Z of generalized Schur vectors are */
/* updated. */
/* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */
/* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */
/* Arguments */
/* ========= */
/* 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. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) REAL arrays, dimensions (LDA,N) */
/* On entry, the matrix A in the pair (A, B). */
/* On exit, the updated matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) REAL arrays, dimensions (LDB,N) */
/* On entry, the matrix B in the pair (A, B). */
/* On exit, the updated matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* Q (input/output) REAL array, dimension (LDZ,N) */
/* On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */
/* On exit, the updated matrix Q. */
/* Not referenced if WANTQ = .FALSE.. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= 1. */
/* If WANTQ = .TRUE., LDQ >= N. */
/* Z (input/output) REAL array, dimension (LDZ,N) */
/* On entry, if WANTZ =.TRUE., the orthogonal matrix Z. */
/* On exit, the updated matrix Z. */
/* Not referenced if WANTZ = .FALSE.. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1. */
/* If WANTZ = .TRUE., LDZ >= N. */
/* J1 (input) INTEGER */
/* The index to the first block (A11, B11). 1 <= J1 <= N. */
/* N1 (input) INTEGER */
/* The order of the first block (A11, B11). N1 = 0, 1 or 2. */
/* N2 (input) INTEGER */
/* The order of the second block (A22, B22). N2 = 0, 1 or 2. */
/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)). */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 ) */
/* INFO (output) INTEGER */
/* =0: Successful exit */
/* >0: If INFO = 1, the transformed matrix (A, B) would be */
/* too far from generalized Schur form; the blocks are */
/* not swapped and (A, B) and (Q, Z) are unchanged. */
/* The problem of swapping is too ill-conditioned. */
/* <0: If INFO = -16: LWORK is too small. Appropriate value */
/* for LWORK is returned in WORK(1). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* In the current code both weak and strong stability tests are */
/* performed. The user can omit the strong stability test by changing */
/* the internal logical parameter WANDS to .FALSE.. See ref. [2] for */
/* details. */
/* [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. */
/* ===================================================================== */
/* Replaced various illegal calls to SCOPY by calls to SLASET, or by DO */
/* loops. Sven Hammarling, 1/5/02. */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n <= 1 || *n1 <= 0 || *n2 <= 0) {
return 0;
}
if (*n1 > *n || *j1 + *n1 > *n) {
return 0;
}
m = *n1 + *n2;
/* Computing MAX */
i__1 = *n * m, i__2 = m * m << 1;
if (*lwork < max(i__1,i__2)) {
*info = -16;
/* Computing MAX */
i__1 = *n * m, i__2 = m * m << 1;
work[1] = (real) max(i__1,i__2);
return 0;
}
weak = FALSE_;
strong = FALSE_;
/* Make a local copy of selected block */
slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, li, &c__4);
slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, ir, &c__4);
slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, s, &c__4);
slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, t, &c__4);
/* Compute threshold for testing acceptance of swapping. */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
dscale = 0.f;
dsum = 1.f;
slacpy_("Full", &m, &m, s, &c__4, &work[1], &m);
i__1 = m * m;
slassq_(&i__1, &work[1], &c__1, &dscale, &dsum);
slacpy_("Full", &m, &m, t, &c__4, &work[1], &m);
i__1 = m * m;
slassq_(&i__1, &work[1], &c__1, &dscale, &dsum);
dnorm = dscale * sqrt(dsum);
/* Computing MAX */
r__1 = eps * 10.f * dnorm;
thresh = dmax(r__1,smlnum);
if (m == 2) {
/* CASE 1: Swap 1-by-1 and 1-by-1 blocks. */
/* Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks */
/* using Givens rotations and perform the swap tentatively. */
f = s[5] * t[0] - t[5] * s[0];
g = s[5] * t[4] - t[5] * s[4];
sb = dabs(t[5]);
sa = dabs(s[5]);
slartg_(&f, &g, &ir[4], ir, &ddum);
ir[1] = -ir[4];
ir[5] = ir[0];
srot_(&c__2, s, &c__1, &s[4], &c__1, ir, &ir[1]);
srot_(&c__2, t, &c__1, &t[4], &c__1, ir, &ir[1]);
if (sa >= sb) {
slartg_(s, &s[1], li, &li[1], &ddum);
} else {
slartg_(t, &t[1], li, &li[1], &ddum);
}
srot_(&c__2, s, &c__4, &s[1], &c__4, li, &li[1]);
srot_(&c__2, t, &c__4, &t[1], &c__4, li, &li[1]);
li[5] = li[0];
li[4] = -li[1];
/* Weak stability test: */
/* |S21| + |T21| <= O(EPS * F-norm((S, T))) */
ws = dabs(s[1]) + dabs(t[1]);
weak = ws <= thresh;
if (! weak) {
goto L70;
}
if (TRUE_) {
/* Strong stability test: */
/* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B))) */
slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m
+ 1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
c_b42, &work[m * m + 1], &m);
dscale = 0.f;
dsum = 1.f;
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m
+ 1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
c_b42, &work[m * m + 1], &m);
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
ss = dscale * sqrt(dsum);
strong = ss <= thresh;
if (! strong) {
goto L70;
}
}
/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */
/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */
i__1 = *j1 + 1;
srot_(&i__1, &a[*j1 * a_dim1 + 1], &c__1, &a[(*j1 + 1) * a_dim1 + 1],
&c__1, ir, &ir[1]);
i__1 = *j1 + 1;
srot_(&i__1, &b[*j1 * b_dim1 + 1], &c__1, &b[(*j1 + 1) * b_dim1 + 1],
&c__1, ir, &ir[1]);
i__1 = *n - *j1 + 1;
srot_(&i__1, &a[*j1 + *j1 * a_dim1], lda, &a[*j1 + 1 + *j1 * a_dim1],
lda, li, &li[1]);
i__1 = *n - *j1 + 1;
srot_(&i__1, &b[*j1 + *j1 * b_dim1], ldb, &b[*j1 + 1 + *j1 * b_dim1],
ldb, li, &li[1]);
/* Set N1-by-N2 (2,1) - blocks to ZERO. */
a[*j1 + 1 + *j1 * a_dim1] = 0.f;
b[*j1 + 1 + *j1 * b_dim1] = 0.f;
/* Accumulate transformations into Q and Z if requested. */
if (*wantz) {
srot_(n, &z__[*j1 * z_dim1 + 1], &c__1, &z__[(*j1 + 1) * z_dim1 +
1], &c__1, ir, &ir[1]);
}
if (*wantq) {
srot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[(*j1 + 1) * q_dim1 + 1],
&c__1, li, &li[1]);
}
/* Exit with INFO = 0 if swap was successfully performed. */
return 0;
} else {
/* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 */
/* and 2-by-2 blocks. */
/* Solve the generalized Sylvester equation */
/* S11 * R - L * S22 = SCALE * S12 */
/* T11 * R - L * T22 = SCALE * T12 */
/* for R and L. Solutions in LI and IR. */
slacpy_("Full", n1, n2, &t[(*n1 + 1 << 2) - 4], &c__4, li, &c__4);
slacpy_("Full", n1, n2, &s[(*n1 + 1 << 2) - 4], &c__4, &ir[*n2 + 1 + (
*n1 + 1 << 2) - 5], &c__4);
stgsy2_("N", &c__0, n1, n2, s, &c__4, &s[*n1 + 1 + (*n1 + 1 << 2) - 5]
, &c__4, &ir[*n2 + 1 + (*n1 + 1 << 2) - 5], &c__4, t, &c__4, &
t[*n1 + 1 + (*n1 + 1 << 2) - 5], &c__4, li, &c__4, &scale, &
dsum, &dscale, iwork, &idum, &linfo);
/* Compute orthogonal matrix QL: */
/* QL' * LI = [ TL ] */
/* [ 0 ] */
/* where */
/* LI = [ -L ] */
/* [ SCALE * identity(N2) ] */
i__1 = *n2;
for (i__ = 1; i__ <= i__1; ++i__) {
sscal_(n1, &c_b48, &li[(i__ << 2) - 4], &c__1);
li[*n1 + i__ + (i__ << 2) - 5] = scale;
/* L10: */
}
sgeqr2_(&m, n2, li, &c__4, taul, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sorg2r_(&m, &m, n2, li, &c__4, taul, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
/* Compute orthogonal matrix RQ: */
/* IR * RQ' = [ 0 TR], */
/* where IR = [ SCALE * identity(N1), R ] */
i__1 = *n1;
for (i__ = 1; i__ <= i__1; ++i__) {
ir[*n2 + i__ + (i__ << 2) - 5] = scale;
/* L20: */
}
sgerq2_(n1, &m, &ir[*n2], &c__4, taur, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sorgr2_(&m, &m, n1, ir, &c__4, taur, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
/* Perform the swapping tentatively: */
sgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5,
s, &c__4);
sgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5,
t, &c__4);
slacpy_("F", &m, &m, s, &c__4, scpy, &c__4);
slacpy_("F", &m, &m, t, &c__4, tcpy, &c__4);
slacpy_("F", &m, &m, ir, &c__4, ircop, &c__4);
slacpy_("F", &m, &m, li, &c__4, licop, &c__4);
/* Triangularize the B-part by an RQ factorization. */
/* Apply transformation (from left) to A-part, giving S. */
sgerq2_(&m, &m, t, &c__4, taur, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sormr2_("R", "T", &m, &m, &m, t, &c__4, taur, s, &c__4, &work[1], &
linfo);
if (linfo != 0) {
goto L70;
}
sormr2_("L", "N", &m, &m, &m, t, &c__4, taur, ir, &c__4, &work[1], &
linfo);
if (linfo != 0) {
goto L70;
}
/* Compute F-norm(S21) in BRQA21. (T21 is 0.) */
dscale = 0.f;
dsum = 1.f;
i__1 = *n2;
for (i__ = 1; i__ <= i__1; ++i__) {
slassq_(n1, &s[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, &dsum);
/* L30: */
}
brqa21 = dscale * sqrt(dsum);
/* Triangularize the B-part by a QR factorization. */
/* Apply transformation (from right) to A-part, giving S. */
sgeqr2_(&m, &m, tcpy, &c__4, taul, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sorm2r_("L", "T", &m, &m, &m, tcpy, &c__4, taul, scpy, &c__4, &work[1]
, info);
sorm2r_("R", "N", &m, &m, &m, tcpy, &c__4, taul, licop, &c__4, &work[
1], info);
if (linfo != 0) {
goto L70;
}
/* Compute F-norm(S21) in BQRA21. (T21 is 0.) */
dscale = 0.f;
dsum = 1.f;
i__1 = *n2;
for (i__ = 1; i__ <= i__1; ++i__) {
slassq_(n1, &scpy[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, &
dsum);
/* L40: */
}
bqra21 = dscale * sqrt(dsum);
/* Decide which method to use. */
/* Weak stability test: */
/* F-norm(S21) <= O(EPS * F-norm((S, T))) */
if (bqra21 <= brqa21 && bqra21 <= thresh) {
slacpy_("F", &m, &m, scpy, &c__4, s, &c__4);
slacpy_("F", &m, &m, tcpy, &c__4, t, &c__4);
slacpy_("F", &m, &m, ircop, &c__4, ir, &c__4);
slacpy_("F", &m, &m, licop, &c__4, li, &c__4);
} else if (brqa21 >= thresh) {
goto L70;
}
/* Set lower triangle of B-part to zero */
i__1 = m - 1;
i__2 = m - 1;
slaset_("Lower", &i__1, &i__2, &c_b5, &c_b5, &t[1], &c__4);
if (TRUE_) {
/* Strong stability test: */
/* F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B))) */
slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m
+ 1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
c_b42, &work[m * m + 1], &m);
dscale = 0.f;
dsum = 1.f;
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m
+ 1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
c_b42, &work[m * m + 1], &m);
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
ss = dscale * sqrt(dsum);
strong = ss <= thresh;
if (! strong) {
goto L70;
}
}
/* If the swap is accepted ("weakly" and "strongly"), apply the */
/* transformations and set N1-by-N2 (2,1)-block to zero. */
slaset_("Full", n1, n2, &c_b5, &c_b5, &s[*n2], &c__4);
/* copy back M-by-M diagonal block starting at index J1 of (A, B) */
slacpy_("F", &m, &m, s, &c__4, &a[*j1 + *j1 * a_dim1], lda)
;
slacpy_("F", &m, &m, t, &c__4, &b[*j1 + *j1 * b_dim1], ldb)
;
slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, t, &c__4);
/* Standardize existing 2-by-2 blocks. */
i__1 = m * m;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
/* L50: */
}
work[1] = 1.f;
t[0] = 1.f;
idum = *lwork - m * m - 2;
if (*n2 > 1) {
slagv2_(&a[*j1 + *j1 * a_dim1], lda, &b[*j1 + *j1 * b_dim1], ldb,
ar, ai, be, &work[1], &work[2], t, &t[1]);
work[m + 1] = -work[2];
work[m + 2] = work[1];
t[*n2 + (*n2 << 2) - 5] = t[0];
t[4] = -t[1];
}
work[m * m] = 1.f;
t[m + (m << 2) - 5] = 1.f;
if (*n1 > 1) {
slagv2_(&a[*j1 + *n2 + (*j1 + *n2) * a_dim1], lda, &b[*j1 + *n2 +
(*j1 + *n2) * b_dim1], ldb, taur, taul, &work[m * m + 1],
&work[*n2 * m + *n2 + 1], &work[*n2 * m + *n2 + 2], &t[*
n2 + 1 + (*n2 + 1 << 2) - 5], &t[m + (m - 1 << 2) - 5]);
work[m * m] = work[*n2 * m + *n2 + 1];
work[m * m - 1] = -work[*n2 * m + *n2 + 2];
t[m + (m << 2) - 5] = t[*n2 + 1 + (*n2 + 1 << 2) - 5];
t[m - 1 + (m << 2) - 5] = -t[m + (m - 1 << 2) - 5];
}
sgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &a[*j1 + (*j1 + *
n2) * a_dim1], lda, &c_b5, &work[m * m + 1], n2);
slacpy_("Full", n2, n1, &work[m * m + 1], n2, &a[*j1 + (*j1 + *n2) *
a_dim1], lda);
sgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &b[*j1 + (*j1 + *
n2) * b_dim1], ldb, &c_b5, &work[m * m + 1], n2);
slacpy_("Full", n2, n1, &work[m * m + 1], n2, &b[*j1 + (*j1 + *n2) *
b_dim1], ldb);
sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, &work[1], &m, &c_b5, &
work[m * m + 1], &m);
slacpy_("Full", &m, &m, &work[m * m + 1], &m, li, &c__4);
sgemm_("N", "N", n2, n1, n1, &c_b42, &a[*j1 + (*j1 + *n2) * a_dim1],
lda, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1],
n2);
slacpy_("Full", n2, n1, &work[1], n2, &a[*j1 + (*j1 + *n2) * a_dim1],
lda);
sgemm_("N", "N", n2, n1, n1, &c_b42, &b[*j1 + (*j1 + *n2) * b_dim1],
ldb, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1],
n2);
slacpy_("Full", n2, n1, &work[1], n2, &b[*j1 + (*j1 + *n2) * b_dim1],
ldb);
sgemm_("T", "N", &m, &m, &m, &c_b42, ir, &c__4, t, &c__4, &c_b5, &
work[1], &m);
slacpy_("Full", &m, &m, &work[1], &m, ir, &c__4);
/* Accumulate transformations into Q and Z if requested. */
if (*wantq) {
sgemm_("N", "N", n, &m, &m, &c_b42, &q[*j1 * q_dim1 + 1], ldq, li,
&c__4, &c_b5, &work[1], n);
slacpy_("Full", n, &m, &work[1], n, &q[*j1 * q_dim1 + 1], ldq);
}
if (*wantz) {
sgemm_("N", "N", n, &m, &m, &c_b42, &z__[*j1 * z_dim1 + 1], ldz,
ir, &c__4, &c_b5, &work[1], n);
slacpy_("Full", n, &m, &work[1], n, &z__[*j1 * z_dim1 + 1], ldz);
}
/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */
/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */
i__ = *j1 + m;
if (i__ <= *n) {
i__1 = *n - i__ + 1;
sgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &a[*j1 + i__ *
a_dim1], lda, &c_b5, &work[1], &m);
i__1 = *n - i__ + 1;
slacpy_("Full", &m, &i__1, &work[1], &m, &a[*j1 + i__ * a_dim1],
lda);
i__1 = *n - i__ + 1;
sgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &b[*j1 + i__ *
b_dim1], ldb, &c_b5, &work[1], &m);
i__1 = *n - i__ + 1;
slacpy_("Full", &m, &i__1, &work[1], &m, &b[*j1 + i__ * b_dim1],
ldb);
}
i__ = *j1 - 1;
if (i__ > 0) {
sgemm_("N", "N", &i__, &m, &m, &c_b42, &a[*j1 * a_dim1 + 1], lda,
ir, &c__4, &c_b5, &work[1], &i__);
slacpy_("Full", &i__, &m, &work[1], &i__, &a[*j1 * a_dim1 + 1],
lda);
sgemm_("N", "N", &i__, &m, &m, &c_b42, &b[*j1 * b_dim1 + 1], ldb,
ir, &c__4, &c_b5, &work[1], &i__);
slacpy_("Full", &i__, &m, &work[1], &i__, &b[*j1 * b_dim1 + 1],
ldb);
}
/* Exit with INFO = 0 if swap was successfully performed. */
return 0;
}
/* Exit with INFO = 1 if swap was rejected. */
L70:
*info = 1;
return 0;
/* End of STGEX2 */
} /* stgex2_ */
doublereal slantp_(char *norm, char *uplo, char *diag, integer *n, real *ap,
real *work, ftnlen norm_len, ftnlen uplo_len, ftnlen diag_len)
{
/* System generated locals */
integer i__1, i__2;
real ret_val, r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__, j, k;
static real sum, scale;
static logical udiag;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static real value;
extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
real *);
/* -- 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 */
/* ======= */
/* SLANTP 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 */
/* =========== */
/* SLANTP returns the value */
/* SLANTP = ( 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 SLANTP 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, SLANTP is */
/* set to zero. */
/* AP (input) REAL 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) REAL 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 */
--work;
--ap;
/* Function Body */
if (*n == 0) {
value = 0.f;
} else if (lsame_(norm, "M", (ftnlen)1, (ftnlen)1)) {
/* Find max(abs(A(i,j))). */
k = 1;
if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
value = 1.f;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j - 2;
for (i__ = k; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1));
value = dmax(r__2,r__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 */
r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1));
value = dmax(r__2,r__3);
/* L30: */
}
k = k + *n - j + 1;
/* L40: */
}
}
} else {
value = 0.f;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)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 */
r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1));
value = dmax(r__2,r__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 */
r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1));
value = dmax(r__2,r__3);
/* L70: */
}
k = k + *n - j + 1;
/* L80: */
}
}
}
} else if (lsame_(norm, "O", (ftnlen)1, (ftnlen)1) || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.f;
k = 1;
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) {
sum = 1.f;
i__2 = k + j - 2;
for (i__ = k; i__ <= i__2; ++i__) {
sum += (r__1 = ap[i__], dabs(r__1));
/* L90: */
}
} else {
sum = 0.f;
i__2 = k + j - 1;
for (i__ = k; i__ <= i__2; ++i__) {
sum += (r__1 = ap[i__], dabs(r__1));
/* L100: */
}
}
k += j;
value = dmax(value,sum);
/* L110: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.f;
i__2 = k + *n - j;
for (i__ = k + 1; i__ <= i__2; ++i__) {
sum += (r__1 = ap[i__], dabs(r__1));
/* L120: */
}
} else {
sum = 0.f;
i__2 = k + *n - j;
for (i__ = k; i__ <= i__2; ++i__) {
sum += (r__1 = ap[i__], dabs(r__1));
/* L130: */
}
}
k = k + *n - j + 1;
value = dmax(value,sum);
/* L140: */
}
}
} else if (lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) {
/* Find normI(A). */
k = 1;
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.f;
/* L150: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (r__1 = ap[k], dabs(r__1));
++k;
/* L160: */
}
++k;
/* L170: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
/* L180: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (r__1 = ap[k], dabs(r__1));
++k;
/* L190: */
}
/* L200: */
}
}
} else {
if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.f;
/* 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__] += (r__1 = ap[k], dabs(r__1));
++k;
/* L220: */
}
/* L230: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
/* L240: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
work[i__] += (r__1 = ap[k], dabs(r__1));
++k;
/* L250: */
}
/* L260: */
}
}
}
value = 0.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = value, r__2 = work[i__];
value = dmax(r__1,r__2);
/* L270: */
}
} 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.f;
sum = (real) (*n);
k = 2;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
slassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k += j;
/* L280: */
}
} else {
scale = 0.f;
sum = 1.f;
k = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
slassq_(&j, &ap[k], &c__1, &scale, &sum);
k += j;
/* L290: */
}
}
} else {
if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
scale = 1.f;
sum = (real) (*n);
k = 2;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
slassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k = k + *n - j + 1;
/* L300: */
}
} else {
scale = 0.f;
sum = 1.f;
k = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
slassq_(&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 SLANTP */
} /* slantp_ */
