doublereal clangt_(char *norm, integer *n, complex *dl, complex *d__, complex
*du)
{
/* System generated locals */
integer i__1;
real ret_val, r__1, r__2;
/* Builtin functions */
double c_abs(complex *), sqrt(doublereal);
/* Local variables */
integer i__;
real sum, scale;
extern logical lsame_(char *, char *);
real anorm;
extern /* Subroutine */ int classq_(integer *, complex *, 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 */
/* ======= */
/* CLANGT 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 tridiagonal matrix A. */
/* Description */
/* =========== */
/* CLANGT returns the value */
/* CLANGT = ( 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 CLANGT as described */
/* above. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, CLANGT is */
/* set to zero. */
/* DL (input) COMPLEX array, dimension (N-1) */
/* The (n-1) sub-diagonal elements of A. */
/* D (input) COMPLEX array, dimension (N) */
/* The diagonal elements of A. */
/* DU (input) COMPLEX array, dimension (N-1) */
/* The (n-1) super-diagonal elements of A. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--du;
--d__;
--dl;
/* Function Body */
if (*n <= 0) {
anorm = 0.f;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
anorm = c_abs(&d__[*n]);
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = anorm, r__2 = c_abs(&dl[i__]);
anorm = dmax(r__1,r__2);
/* Computing MAX */
r__1 = anorm, r__2 = c_abs(&d__[i__]);
anorm = dmax(r__1,r__2);
/* Computing MAX */
r__1 = anorm, r__2 = c_abs(&du[i__]);
anorm = dmax(r__1,r__2);
/* L10: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
if (*n == 1) {
anorm = c_abs(&d__[1]);
} else {
/* Computing MAX */
r__1 = c_abs(&d__[1]) + c_abs(&dl[1]), r__2 = c_abs(&d__[*n]) +
c_abs(&du[*n - 1]);
anorm = dmax(r__1,r__2);
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = anorm, r__2 = c_abs(&d__[i__]) + c_abs(&dl[i__]) +
c_abs(&du[i__ - 1]);
anorm = dmax(r__1,r__2);
/* L20: */
}
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
if (*n == 1) {
anorm = c_abs(&d__[1]);
} else {
/* Computing MAX */
r__1 = c_abs(&d__[1]) + c_abs(&du[1]), r__2 = c_abs(&d__[*n]) +
c_abs(&dl[*n - 1]);
anorm = dmax(r__1,r__2);
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = anorm, r__2 = c_abs(&d__[i__]) + c_abs(&du[i__]) +
c_abs(&dl[i__ - 1]);
anorm = dmax(r__1,r__2);
/* L30: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
classq_(n, &d__[1], &c__1, &scale, &sum);
if (*n > 1) {
i__1 = *n - 1;
classq_(&i__1, &dl[1], &c__1, &scale, &sum);
i__1 = *n - 1;
classq_(&i__1, &du[1], &c__1, &scale, &sum);
}
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of CLANGT */
} /* clangt_ */
doublereal clange_(char *norm, integer *m, integer *n, complex *a, integer *
lda, 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
=======
CLANGE 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 matrix A.
Description
===========
CLANGE returns the value
CLANGE = ( 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 CLANGE as described
above.
M (input) INTEGER
The number of rows of the matrix A. M >= 0. When M = 0,
CLANGE is set to zero.
N (input) INTEGER
The number of columns of the matrix A. N >= 0. When N = 0,
CLANGE is set to zero.
A (input) COMPLEX 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.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real ret_val, r__1, r__2;
/* Builtin functions */
double c_abs(complex *), sqrt(doublereal);
/* Local variables */
static integer i__, j;
static real scale;
extern logical lsame_(char *, char *);
static real value;
extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
*, real *);
static real sum;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--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__1 = value, r__2 = c_abs(&a_ref(i__, j));
value = dmax(r__1,r__2);
/* 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 += c_abs(&a_ref(i__, j));
/* L30: */
}
value = dmax(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__] += c_abs(&a_ref(i__, j));
/* 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 = 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) {
classq_(m, &a_ref(1, j), &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of CLANGE */
} /* clange_ */
doublereal clanhb_(char *norm, char *uplo, integer *n, integer *k, complex *
ab, integer *ldab, 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
=======
CLANHB 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 hermitian band matrix A, with k super-diagonals.
Description
===========
CLANHB returns the value
CLANHB = ( 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 CLANHB 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
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0. When N = 0, CLANHB is
set to zero.
K (input) INTEGER
The number of super-diagonals or sub-diagonals of the
band matrix A. K >= 0.
AB (input) COMPLEX array, dimension (LDAB,N)
The upper or lower triangle of the hermitian 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 the imaginary parts of the diagonal elements need
not be set and are assumed to be zero.
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' or '1' or 'O'; otherwise,
WORK is not referenced.
=====================================================================
Parameter adjustments
Function Body */
/* 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;
real ret_val, r__1, r__2, r__3;
/* Builtin functions */
double c_abs(complex *), sqrt(doublereal);
/* Local variables */
static real absa;
static integer i, j, l;
static real scale;
extern logical lsame_(char *, char *);
static real value;
extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
*, real *);
static real sum;
#define WORK(I) work[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
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) {
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i = max(*k+2-j,1); i <= *k; ++i) {
/* Computing MAX */
r__1 = value, r__2 = c_abs(&AB(i,j));
value = dmax(r__1,r__2);
/* L10: */
}
/* Computing MAX */
i__3 = *k + 1 + j * ab_dim1;
r__2 = value, r__3 = (r__1 = AB(*k+1,j).r, dabs(r__1));
value = dmax(r__2,r__3);
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
/* Computing MAX */
i__3 = j * ab_dim1 + 1;
r__2 = value, r__3 = (r__1 = AB(1,j).r, dabs(r__1));
value = dmax(r__2,r__3);
/* Computing MIN */
i__2 = *n + 1 - j, i__4 = *k + 1;
i__3 = min(i__2,i__4);
for (i = 2; i <= min(*n+1-j,*k+1); ++i) {
/* Computing MAX */
r__1 = value, r__2 = c_abs(&AB(i,j));
value = dmax(r__1,r__2);
/* L30: */
}
/* L40: */
}
}
} else if (lsame_(norm, "I") || lsame_(norm, "O") || *(
unsigned char *)norm == '1') {
/* Find normI(A) ( = norm1(A), since A is hermitian). */
value = 0.f;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
sum = 0.f;
l = *k + 1 - j;
/* Computing MAX */
i__3 = 1, i__2 = j - *k;
i__4 = j - 1;
for (i = max(1,j-*k); i <= j-1; ++i) {
absa = c_abs(&AB(l+i,j));
sum += absa;
WORK(i) += absa;
/* L50: */
}
i__4 = *k + 1 + j * ab_dim1;
WORK(j) = sum + (r__1 = AB(*k+1,j).r, 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) {
i__4 = j * ab_dim1 + 1;
sum = WORK(j) + (r__1 = AB(1,j).r, 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 <= min(*n,j+*k); ++i) {
absa = c_abs(&AB(l+i,j));
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 <= *n; ++j) {
/* Computing MIN */
i__3 = j - 1;
i__4 = min(i__3,*k);
/* Computing MAX */
i__2 = *k + 2 - j;
classq_(&i__4, &AB(max(*k+2-j,1),j), &c__1, &
scale, &sum);
/* L110: */
}
l = *k + 1;
} else {
i__1 = *n - 1;
for (j = 1; j <= *n-1; ++j) {
/* Computing MIN */
i__3 = *n - j;
i__4 = min(i__3,*k);
classq_(&i__4, &AB(2,j), &c__1, &scale, &sum);
/* L120: */
}
l = 1;
}
sum *= 2;
} else {
l = 1;
}
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__4 = l + j * ab_dim1;
if (AB(l,j).r != 0.f) {
i__4 = l + j * ab_dim1;
absa = (r__1 = AB(l,j).r, 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;
}
}
/* L130: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of CLANHB */
} /* clanhb_ */
doublereal clange_(char *norm, integer *m, integer *n, complex *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;
/* Builtin functions */
double c_abs(complex *), sqrt(doublereal);
/* Local variables */
static integer i__, j;
static real sum, scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static real value;
extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
*, real *);
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLANGE 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 matrix A. */
/* Description */
/* =========== */
/* CLANGE returns the value */
/* CLANGE = ( 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 CLANGE as described */
/* above. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. When M = 0, */
/* CLANGE is set to zero. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. When N = 0, */
/* CLANGE is set to zero. */
/* A (input) COMPLEX 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 .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. 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", (ftnlen)1, (ftnlen)1)) {
/* 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__1 = value, r__2 = c_abs(&a[i__ + j * a_dim1]);
value = dmax(r__1,r__2);
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, "O", (ftnlen)1, (ftnlen)1) || *(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 += c_abs(&a[i__ + j * a_dim1]);
/* L30: */
}
value = dmax(value,sum);
/* L40: */
}
} else if (lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) {
/* 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__] += c_abs(&a[i__ + j * a_dim1]);
/* 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 = dmax(r__1,r__2);
/* L80: */
}
} else if (lsame_(norm, "F", (ftnlen)1, (ftnlen)1) || lsame_(norm, "E", (
ftnlen)1, (ftnlen)1)) {
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
classq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of CLANGE */
} /* clange_ */
doublereal clanhs_(char *norm, integer *n, complex *a, integer *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
=======
CLANHS returns the value of the one norm, or the Frobenius norm, or
the infinity norm, or the element of largest absolute value of a
Hessenberg matrix A.
Description
===========
CLANHS returns the value
CLANHS = ( 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 CLANHS as described
above.
N (input) INTEGER
The order of the matrix A. N >= 0. When N = 0, CLANHS is
set to zero.
A (input) COMPLEX array, dimension (LDA,N)
The n by n upper Hessenberg matrix A; the part of A below the
first sub-diagonal is not referenced.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(N,1).
WORK (workspace) REAL array, dimension (LWORK),
where LWORK >= N when NORM = 'I'; otherwise, WORK is not
referenced.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
real ret_val, r__1, r__2;
/* Builtin functions */
double c_abs(complex *), sqrt(doublereal);
/* Local variables */
static integer i, j;
static real scale;
extern logical lsame_(char *, char *);
static real value;
extern /* Subroutine */ int classq_(integer *, complex *, integer *, 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;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i = 1; i <= min(*n,j+1); ++i) {
/* Computing MAX */
r__1 = value, r__2 = c_abs(&A(i,j));
value = dmax(r__1,r__2);
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)norm == '1') {
/* Find norm1(A). */
value = 0.f;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
sum = 0.f;
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i = 1; i <= min(*n,j+1); ++i) {
sum += c_abs(&A(i,j));
/* L30: */
}
value = dmax(value,sum);
/* L40: */
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
i__1 = *n;
for (i = 1; i <= *n; ++i) {
WORK(i) = 0.f;
/* L50: */
}
i__1 = *n;
for (j = 1; j <= *n; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i = 1; i <= min(*n,j+1); ++i) {
WORK(i) += c_abs(&A(i,j));
/* L60: */
}
/* L70: */
}
value = 0.f;
i__1 = *n;
for (i = 1; i <= *n; ++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 <= *n; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
classq_(&i__2, &A(1,j), &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of CLANHS */
} /* clanhs_ */
doublereal clansp_(char *norm, char *uplo, integer *n, complex *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
=======
CLANSP 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 symmetric matrix A, supplied in packed form.
Description
===========
CLANSP returns the value
CLANSP = ( 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 CLANSP 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, CLANSP is
set to zero.
AP (input) COMPLEX 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;
/* Builtin functions */
double c_abs(complex *), r_imag(complex *), 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 classq_(integer *, complex *, 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__1 = value, r__2 = c_abs(&ap[i__]);
value = dmax(r__1,r__2);
/* 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__1 = value, r__2 = c_abs(&ap[i__]);
value = dmax(r__1,r__2);
/* 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 = c_abs(&ap[k]);
sum += absa;
work[i__] += absa;
++k;
/* L50: */
}
work[j] = sum + c_abs(&ap[k]);
++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] + c_abs(&ap[k]);
++k;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
absa = c_abs(&ap[k]);
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;
classq_(&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;
classq_(&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__) {
i__2 = k;
if (ap[i__2].r != 0.f) {
i__2 = k;
absa = (r__1 = ap[i__2].r, 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 (r_imag(&ap[k]) != 0.f) {
absa = (r__1 = r_imag(&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 CLANSP */
} /* clansp_ */
int csyequb_(char *uplo, int *n, complex *a, int *
lda, float *s, float *scond, float *amax, complex *work, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
float r__1, r__2, r__3, r__4;
double d__1;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *), sqrt(double), log(double), pow_ri(float *
, int *);
/* Local variables */
float d__;
int i__, j;
float t, u, c0, c1, c2, si;
int up;
float avg, std, tol, base;
int iter;
float smin, smax, scale;
extern int lsame_(char *, char *);
float sumsq;
extern double slamch_(char *);
extern int xerbla_(char *, int *);
float bignum;
extern int classq_(int *, complex *, int *, float
*, float *);
float smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CSYEQUB 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) COMPLEX 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 */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* Statement Function Definitions */
/* .. */
/* .. Executable Statements .. */
/* Test the 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_("CSYEQUB", &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 */
i__3 = i__ + j * a_dim1;
r__3 = s[i__], r__4 = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&a[i__ + j * a_dim1]), ABS(r__2));
s[i__] = MAX(r__3,r__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
r__3 = s[j], r__4 = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&a[i__ + j * a_dim1]), ABS(r__2));
s[j] = MAX(r__3,r__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
r__3 = *amax, r__4 = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&a[i__ + j * a_dim1]), ABS(r__2));
*amax = MAX(r__3,r__4);
}
/* Computing MAX */
i__2 = j + j * a_dim1;
r__3 = s[j], r__4 = (r__1 = a[i__2].r, ABS(r__1)) + (r__2 =
r_imag(&a[j + j * a_dim1]), ABS(r__2));
s[j] = MAX(r__3,r__4);
/* Computing MAX */
i__2 = j + j * a_dim1;
r__3 = *amax, r__4 = (r__1 = a[i__2].r, ABS(r__1)) + (r__2 =
r_imag(&a[j + j * a_dim1]), ABS(r__2));
*amax = MAX(r__3,r__4);
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j + j * a_dim1;
r__3 = s[j], r__4 = (r__1 = a[i__2].r, ABS(r__1)) + (r__2 =
r_imag(&a[j + j * a_dim1]), ABS(r__2));
s[j] = MAX(r__3,r__4);
/* Computing MAX */
i__2 = j + j * a_dim1;
r__3 = *amax, r__4 = (r__1 = a[i__2].r, ABS(r__1)) + (r__2 =
r_imag(&a[j + j * a_dim1]), ABS(r__2));
*amax = MAX(r__3,r__4);
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ + j * a_dim1;
r__3 = s[i__], r__4 = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&a[i__ + j * a_dim1]), ABS(r__2));
s[i__] = MAX(r__3,r__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
r__3 = s[j], r__4 = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&a[i__ + j * a_dim1]), ABS(r__2));
s[j] = MAX(r__3,r__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
r__3 = *amax, r__4 = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&a[i__ + j * a_dim1]), ABS(r__2));
*amax = MAX(r__3,r__4);
}
}
}
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__) {
i__2 = i__;
work[i__2].r = 0.f, work[i__2].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__) {
i__3 = i__ + j * a_dim1;
t = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 = r_imag(&a[
i__ + j * a_dim1]), ABS(r__2));
i__3 = i__;
i__4 = i__;
i__5 = i__ + j * a_dim1;
r__3 = ((r__1 = a[i__5].r, ABS(r__1)) + (r__2 = r_imag(&
a[i__ + j * a_dim1]), ABS(r__2))) * s[j];
q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
i__3 = j;
i__4 = j;
i__5 = i__ + j * a_dim1;
r__3 = ((r__1 = a[i__5].r, ABS(r__1)) + (r__2 = r_imag(&
a[i__ + j * a_dim1]), ABS(r__2))) * s[i__];
q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
}
i__2 = j;
i__3 = j;
i__4 = j + j * a_dim1;
r__3 = ((r__1 = a[i__4].r, ABS(r__1)) + (r__2 = r_imag(&a[j
+ j * a_dim1]), ABS(r__2))) * s[j];
q__1.r = work[i__3].r + r__3, q__1.i = work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
i__3 = j;
i__4 = j + j * a_dim1;
r__3 = ((r__1 = a[i__4].r, ABS(r__1)) + (r__2 = r_imag(&a[j
+ j * a_dim1]), ABS(r__2))) * s[j];
q__1.r = work[i__3].r + r__3, q__1.i = work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
t = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 = r_imag(&a[
i__ + j * a_dim1]), ABS(r__2));
i__3 = i__;
i__4 = i__;
i__5 = i__ + j * a_dim1;
r__3 = ((r__1 = a[i__5].r, ABS(r__1)) + (r__2 = r_imag(&
a[i__ + j * a_dim1]), ABS(r__2))) * s[j];
q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
i__3 = j;
i__4 = j;
i__5 = i__ + j * a_dim1;
r__3 = ((r__1 = a[i__5].r, ABS(r__1)) + (r__2 = r_imag(&
a[i__ + j * a_dim1]), ABS(r__2))) * s[i__];
q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
}
}
}
/* avg = s^T beta / n */
avg = 0.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
q__2.r = s[i__2] * work[i__3].r, q__2.i = s[i__2] * work[i__3].i;
q__1.r = avg + q__2.r, q__1.i = q__2.i;
avg = q__1.r;
}
avg /= *n;
std = 0.f;
i__1 = *n << 1;
for (i__ = *n + 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__ - *n;
i__4 = i__ - *n;
q__2.r = s[i__3] * work[i__4].r, q__2.i = s[i__3] * work[i__4].i;
q__1.r = q__2.r - avg, q__1.i = q__2.i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
}
classq_(n, &work[*n + 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__) {
i__2 = i__ + i__ * a_dim1;
t = (r__1 = a[i__2].r, ABS(r__1)) + (r__2 = r_imag(&a[i__ + i__ *
a_dim1]), ABS(r__2));
si = s[i__];
c2 = (*n - 1) * t;
i__2 = *n - 2;
i__3 = i__;
r__1 = t * si;
q__2.r = work[i__3].r - r__1, q__2.i = work[i__3].i;
d__1 = (double) i__2;
q__1.r = d__1 * q__2.r, q__1.i = d__1 * q__2.i;
c1 = q__1.r;
r__1 = -(t * si) * si;
i__2 = i__;
d__1 = 2.;
q__4.r = d__1 * work[i__2].r, q__4.i = d__1 * work[i__2].i;
q__3.r = si * q__4.r, q__3.i = si * q__4.i;
q__2.r = r__1 + q__3.r, q__2.i = q__3.i;
r__2 = *n * avg;
q__1.r = q__2.r - r__2, q__1.i = q__2.i;
c0 = q__1.r;
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) {
i__3 = j + i__ * a_dim1;
t = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 = r_imag(&a[j
+ i__ * a_dim1]), ABS(r__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
r__1 = d__ * t;
q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
t = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 = r_imag(&a[
i__ + j * a_dim1]), ABS(r__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
r__1 = d__ * t;
q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
}
} else {
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
t = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 = r_imag(&a[
i__ + j * a_dim1]), ABS(r__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
r__1 = d__ * t;
q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
t = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 = r_imag(&a[j
+ i__ * a_dim1]), ABS(r__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
r__1 = d__ * t;
q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
}
}
i__2 = i__;
q__4.r = u + work[i__2].r, q__4.i = work[i__2].i;
q__3.r = d__ * q__4.r, q__3.i = d__ * q__4.i;
d__1 = (double) (*n);
q__2.r = q__3.r / d__1, q__2.i = q__3.i / d__1;
q__1.r = avg + q__2.r, q__1.i = q__2.i;
avg = q__1.r;
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 = (int) (u * log(s[i__] * t));
s[i__] = pow_ri(&base, &i__2);
/* Computing MIN */
r__1 = smin, r__2 = s[i__];
smin = MIN(r__1,r__2);
/* Computing MAX */
r__1 = smax, r__2 = s[i__];
smax = MAX(r__1,r__2);
}
*scond = MAX(smin,smlnum) / MIN(smax,bignum);
return 0;
} /* csyequb_ */
/* Subroutine */ int ctgsen_(integer *ijob, logical *wantq, logical *wantz,
logical *select, integer *n, complex *a, integer *lda, complex *b,
integer *ldb, complex *alpha, complex *beta, complex *q, integer *ldq,
complex *z__, integer *ldz, integer *m, real *pl, real *pr, real *
dif, complex *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
=======
CTGSEN reorders the generalized Schur decomposition of a complex
matrix pair (A, B) (in terms of an unitary equivalence trans-
formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
appears in the leading diagonal blocks of the pair (A,B). The leading
columns of Q and Z form unitary bases of the corresponding left and
right eigenspaces (deflating subspaces). (A, B) must be in
generalized Schur canonical form, that is, A and B are both upper
triangular.
CTGSEN also computes the generalized eigenvalues
w(j)= ALPHA(j) / BETA(j)
of the reordered matrix pair (A, B).
Optionally, the routine computes 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 an eigenvalue w(j), SELECT(j) must be set to
.TRUE..
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) COMPLEX array, dimension(LDA,N)
On entry, the upper triangular matrix A, in generalized
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) COMPLEX array, dimension(LDB,N)
On entry, the upper triangular matrix B, in generalized
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).
ALPHA (output) COMPLEX array, dimension (N)
BETA (output) COMPLEX array, dimension (N)
The diagonal elements of A and B, respectively,
when the pair (A,B) has been reduced to generalized Schur
form. ALPHA(i)/BETA(i) i=1,...,N are the generalized
eigenvalues.
Q (input/output) COMPLEX 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 unitary
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.
If WANTQ = .TRUE., LDQ >= N.
Z (input/output) COMPLEX 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 unitary
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
eigenspaces, (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
eigenspace 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, 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, computed using reversed
communication with CLACON.
If M = 0 or N, DIF(1:2) = F-norm([A, B]).
If IJOB = 0 or 1, DIF is not referenced.
WORK (workspace/output) COMPLEX 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 >= 1
If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M)
If IJOB = 3 or 5, LWORK >= 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, 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+2;
If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));
If LIWORK = -1, then a workspace query is assumed; the
routine only calculates the optimal size of the IWORK array,
returns this value as the first entry of the IWORK array, and
no error message related to LIWORK is issued by XERBLA.
INFO (output) INTEGER
=0: Successful exit.
<0: If INFO = -i, the i-th argument had an illegal value.
=1: Reordering of (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
===============
CTGSEN first collects the selected eigenvalues by computing unitary
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 conjugate 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 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 CLATDF), then the parameter
IDIFJB (see below) should be changed from 3 to 4 (routine CLATDF
(IJOB = 2 will be used)). See CTGSYL 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;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2, i__3;
complex q__1, q__2;
/* Builtin functions */
double sqrt(doublereal), c_abs(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static integer kase, ierr;
static real dsum;
static logical swap;
static integer i__, k;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
static logical wantd;
static integer lwmin;
static logical wantp;
static integer n1, n2;
static logical wantd1, wantd2;
static real dscale;
static integer ks;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
extern doublereal slamch_(char *);
static real rdscal;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *);
static real safmin;
extern /* Subroutine */ int ctgexc_(logical *, logical *, integer *,
complex *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, integer *, integer *, integer *), xerbla_(
char *, integer *), classq_(integer *, complex *, integer
*, real *, real *);
static integer liwmin;
extern /* Subroutine */ int ctgsyl_(char *, integer *, integer *, integer
*, complex *, integer *, complex *, integer *, complex *, integer
*, complex *, integer *, complex *, integer *, complex *, integer
*, real *, real *, complex *, integer *, integer *, integer *);
static integer mn2;
static logical lquery;
static integer ijb;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
--select;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alpha;
--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 = -13;
} else if (*ldz < 1 || *wantz && *ldz < *n) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGSEN", &i__1);
return 0;
}
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;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
i__3 = a_subscr(k, k);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = k;
i__3 = b_subscr(k, k);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
if (k < *n) {
if (select[k]) {
++(*m);
}
} else {
if (select[*n]) {
++(*m);
}
}
/* L10: */
}
if (*ijob == 1 || *ijob == 2 || *ijob == 4) {
/* Computing MAX */
i__1 = 1, i__2 = (*m << 1) * (*n - *m);
lwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = *n + 2;
liwmin = max(i__1,i__2);
} else if (*ijob == 3 || *ijob == 5) {
/* Computing MAX */
i__1 = 1, 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 + 2;
liwmin = max(i__1,i__2);
} else {
lwmin = 1;
liwmin = 1;
}
work[1].r = (real) lwmin, work[1].i = 0.f;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -21;
} else if (*liwork < liwmin && ! lquery) {
*info = -23;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGSEN", &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__) {
classq_(n, &a_ref(1, i__), &c__1, &dscale, &dsum);
classq_(n, &b_ref(1, i__), &c__1, &dscale, &dsum);
/* L20: */
}
dif[1] = dscale * sqrt(dsum);
dif[2] = dif[1];
}
goto L70;
}
/* Get machine constant */
safmin = slamch_("S");
/* Collect the selected blocks at the top-left corner of (A, B). */
ks = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
swap = select[k];
if (swap) {
++ks;
/* Swap the K-th block to position KS. Compute unitary Q
and Z that will swap adjacent diagonal blocks in (A, B). */
if (k != ks) {
ctgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb,
&q[q_offset], ldq, &z__[z_offset], ldz, &k, &ks, &
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 L70;
}
}
/* L30: */
}
if (wantp) {
/* Solve generalized Sylvester equation for R and L:
A11 * R - L * A22 = A12
B11 * R - L * B22 = B12 */
n1 = *m;
n2 = *n - *m;
i__ = n1 + 1;
clacpy_("Full", &n1, &n2, &a_ref(1, i__), lda, &work[1], &n1);
clacpy_("Full", &n1, &n2, &b_ref(1, i__), ldb, &work[n1 * n2 + 1], &
n1);
ijb = 0;
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("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;
classq_(&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;
classq_(&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 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;
ctgsyl_("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);
/* Frobenius norm-based Difl estimate. */
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("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
* n2 << 1) + 1], &i__1, &iwork[1], &ierr);
} else {
/* Compute 1-norm-based estimates of Difu and Difl using
reversed communication with CLACON. 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:
clacon_(&mn2, &work[mn2 + 1], &work[1], &dif[1], &kase);
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation */
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("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);
} else {
/* Solve the transposed variant. */
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("C", &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);
}
goto L40;
}
dif[1] = dscale / dif[1];
/* 1-norm-based estimate of Difl. */
L50:
clacon_(&mn2, &work[mn2 + 1], &work[1], &dif[2], &kase);
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation */
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("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 * n2 << 1) + 1], &i__1,
&iwork[1], &ierr);
} else {
/* Solve the transposed variant. */
i__1 = *lwork - (n1 << 1) * n2;
ctgsyl_("C", &ijb, &n2, &n1, &a_ref(i__, i__), lda, &a[
a_offset], lda, &work[1], &n2, &b[b_offset], ldb,
&b_ref(i__, i__), ldb, &work[n1 * n2 + 1], &n2, &
dscale, &dif[2], &work[(n1 * n2 << 1) + 1], &i__1,
&iwork[1], &ierr);
}
goto L50;
}
dif[2] = dscale / dif[2];
}
}
/* If B(K,K) is complex, make it real and positive (normalization
of the generalized Schur form) and Store the generalized
eigenvalues of reordered pair (A, B) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
dscale = c_abs(&b_ref(k, k));
if (dscale > safmin) {
i__2 = b_subscr(k, k);
q__2.r = b[i__2].r / dscale, q__2.i = b[i__2].i / dscale;
r_cnjg(&q__1, &q__2);
work[1].r = q__1.r, work[1].i = q__1.i;
i__2 = b_subscr(k, k);
q__1.r = b[i__2].r / dscale, q__1.i = b[i__2].i / dscale;
work[2].r = q__1.r, work[2].i = q__1.i;
i__2 = b_subscr(k, k);
b[i__2].r = dscale, b[i__2].i = 0.f;
i__2 = *n - k;
cscal_(&i__2, &work[1], &b_ref(k, k + 1), ldb);
i__2 = *n - k + 1;
cscal_(&i__2, &work[1], &a_ref(k, k), lda);
if (*wantq) {
cscal_(n, &work[2], &q_ref(1, k), &c__1);
}
} else {
i__2 = b_subscr(k, k);
b[i__2].r = 0.f, b[i__2].i = 0.f;
}
i__2 = k;
i__3 = a_subscr(k, k);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = k;
i__3 = b_subscr(k, k);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
/* L60: */
}
L70:
work[1].r = (real) lwmin, work[1].i = 0.f;
iwork[1] = liwmin;
return 0;
/* End of CTGSEN */
} /* ctgsen_ */
doublereal clanht_(char *norm, integer *n, real *d__, complex *e)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1992
Purpose
=======
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 */
/* 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;
--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);
/* 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__ <= 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);
/* 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_ */
doublereal clansb_(char *norm, char *uplo, integer *n, integer *k, complex *
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;
/* Local variables */
integer i__, j, l;
real sum, absa, scale;
real value;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CLANSB 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 */
/* =========== */
/* CLANSB returns the value */
/* CLANSB = ( 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 CLANSB 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, CLANSB is */
/* set to zero. */
/* K (input) INTEGER */
/* The number of super-diagonals or sub-diagonals of the */
/* band matrix A. K >= 0. */
/* AB (input) COMPLEX 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. */
/* ===================================================================== */
/* 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__1 = value, r__2 = c_abs(&ab[i__ + j * ab_dim1]);
value = dmax(r__1,r__2);
}
}
} 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__1 = value, r__2 = c_abs(&ab[i__ + j * ab_dim1]);
value = dmax(r__1,r__2);
}
}
}
} 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 = c_abs(&ab[l + i__ + j * ab_dim1]);
sum += absa;
work[i__] += absa;
}
work[j] = sum + c_abs(&ab[*k + 1 + j * ab_dim1]);
}
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 {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = work[j] + c_abs(&ab[j * ab_dim1 + 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 = c_abs(&ab[l + i__ + j * ab_dim1]);
sum += absa;
work[i__] += absa;
}
value = dmax(value,sum);
}
}
} 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;
classq_(&i__4, &ab[max(i__2, 1)+ j * ab_dim1], &c__1, &
scale, &sum);
}
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);
classq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, &scale, &sum);
}
l = 1;
}
sum *= 2;
} else {
l = 1;
}
classq_(n, &ab[l + ab_dim1], ldab, &scale, &sum);
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of CLANSB */
} /* clansb_ */
double clangb_(char *norm, int *n, int *kl, int *ku, complex *
ab, int *ldab, float *work)
{
/* System generated locals */
int ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
float ret_val, r__1, r__2;
/* Builtin functions */
double c_abs(complex *), sqrt(double);
/* Local variables */
int i__, j, k, l;
float sum, scale;
extern int lsame_(char *, char *);
float value;
extern int classq_(int *, complex *, 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 */
/* ======= */
/* CLANGB 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 */
/* =========== */
/* CLANGB returns the value */
/* CLANGB = ( 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 CLANGB as described */
/* above. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, CLANGB 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) COMPLEX 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. 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;
i__3 = MIN(i__4,i__5);
for (i__ = MAX(i__2,1); i__ <= i__3; ++i__) {
/* Computing MAX */
r__1 = value, r__2 = c_abs(&ab[i__ + j * ab_dim1]);
value = MAX(r__1,r__2);
/* 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 += c_abs(&ab[i__ + j * ab_dim1]);
/* L30: */
}
value = MAX(value,sum);
/* L40: */
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.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__] += c_abs(&ab[k + i__ + j * ab_dim1]);
/* 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 = 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) {
/* 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;
classq_(&i__4, &ab[k + j * ab_dim1], &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of CLANGB */
} /* clangb_ */
doublereal clanhe_(char *norm, char *uplo, integer *n, complex *a, integer *
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
=======
CLANHE 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 matrix A.
Description
===========
CLANHE returns the value
CLANHE = ( 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 CLANHE as described
above.
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
hermitian 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, CLANHE is
set to zero.
A (input) COMPLEX array, dimension (LDA,N)
The hermitian matrix A. If UPLO = 'U', the leading n by n
upper triangular part of A contains the upper triangular part
of the matrix A, and the strictly lower triangular part of A
is not referenced. If UPLO = 'L', the leading n by n lower
triangular part of A contains the lower triangular part of
the matrix A, and the strictly upper triangular part of A is
not referenced. Note that the imaginary parts of the diagonal
elements need not be set and are assumed to be zero.
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 integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real ret_val, r__1, r__2, r__3;
/* Builtin functions */
double c_abs(complex *), sqrt(doublereal);
/* Local variables */
static real absa;
static integer i, j;
static real scale;
extern logical lsame_(char *, char *);
static real value;
extern /* Subroutine */ int classq_(integer *, complex *, integer *, 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 - 1;
for (i = 1; i <= j-1; ++i) {
/* Computing MAX */
r__1 = value, r__2 = c_abs(&A(i,j));
value = dmax(r__1,r__2);
/* L10: */
}
/* Computing MAX */
i__2 = j + j * a_dim1;
r__2 = value, r__3 = (r__1 = A(j,j).r, dabs(r__1));
value = dmax(r__2,r__3);
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
/* Computing MAX */
i__2 = j + j * a_dim1;
r__2 = value, r__3 = (r__1 = A(j,j).r, dabs(r__1));
value = dmax(r__2,r__3);
i__2 = *n;
for (i = j + 1; i <= *n; ++i) {
/* Computing MAX */
r__1 = value, r__2 = c_abs(&A(i,j));
value = dmax(r__1,r__2);
/* L30: */
}
/* L40: */
}
}
} else if (lsame_(norm, "I") || lsame_(norm, "O") || *(
unsigned char *)norm == '1') {
/* Find normI(A) ( = norm1(A), since A is hermitian). */
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 = c_abs(&A(i,j));
sum += absa;
WORK(i) += absa;
/* L50: */
}
i__2 = j + j * a_dim1;
WORK(j) = sum + (r__1 = A(j,j).r, 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) {
i__2 = j + j * a_dim1;
sum = WORK(j) + (r__1 = A(j,j).r, dabs(r__1));
i__2 = *n;
for (i = j + 1; i <= *n; ++i) {
absa = c_abs(&A(i,j));
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;
classq_(&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;
classq_(&i__2, &A(j+1,j), &c__1, &scale, &sum);
/* L120: */
}
}
sum *= 2;
i__1 = *n;
for (i = 1; i <= *n; ++i) {
i__2 = i + i * a_dim1;
if (A(i,i).r != 0.f) {
i__2 = i + i * a_dim1;
absa = (r__1 = A(i,i).r, 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;
}
}
/* L130: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of CLANHE */
} /* clanhe_ */
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_ */
doublereal clanhp_(char *norm, char *uplo, integer *n, complex *ap, real *
work)
{
/* System generated locals */
integer i__1, i__2;
real ret_val, r__1, r__2, r__3;
/* Builtin functions */
double c_abs(complex *), sqrt(doublereal);
/* Local variables */
integer i__, j, k;
real sum, absa, scale;
extern logical lsame_(char *, char *);
real value;
extern /* Subroutine */ int classq_(integer *, complex *, 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 */
/* ======= */
/* CLANHP 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 matrix A, supplied in packed form. */
/* Description */
/* =========== */
/* CLANHP returns the value */
/* CLANHP = ( 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 CLANHP as described */
/* above. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* hermitian 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, CLANHP is */
/* set to zero. */
/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The upper or lower triangle of the hermitian matrix A, packed */
/* columnwise in a linear array. The j-th column of A is stored */
/* in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* Note that the imaginary parts of the diagonal elements need */
/* not be set and are assumed to be zero. */
/* 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 Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--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 = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j - 1;
for (i__ = k + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__1 = value, r__2 = c_abs(&ap[i__]);
value = dmax(r__1,r__2);
/* L10: */
}
k += j;
/* Computing MAX */
i__2 = k;
r__2 = value, r__3 = (r__1 = ap[i__2].r, dabs(r__1));
value = dmax(r__2,r__3);
/* L20: */
}
} else {
k = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = k;
r__2 = value, r__3 = (r__1 = ap[i__2].r, dabs(r__1));
value = dmax(r__2,r__3);
i__2 = k + *n - j;
for (i__ = k + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__1 = value, r__2 = c_abs(&ap[i__]);
value = dmax(r__1,r__2);
/* 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 hermitian). */
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 = c_abs(&ap[k]);
sum += absa;
work[i__] += absa;
++k;
/* L50: */
}
i__2 = k;
work[j] = sum + (r__1 = ap[i__2].r, 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) {
i__2 = k;
sum = work[j] + (r__1 = ap[i__2].r, dabs(r__1));
++k;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
absa = c_abs(&ap[k]);
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;
classq_(&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;
classq_(&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__) {
i__2 = k;
if (ap[i__2].r != 0.f) {
i__2 = k;
absa = (r__1 = ap[i__2].r, 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 CLANHP */
} /* clanhp_ */
doublereal clantp_(char *norm, char *uplo, char *diag, integer *n, complex *
ap, real *work)
{
/* System generated locals */
integer i__1, i__2;
real ret_val, r__1, r__2;
/* Builtin functions */
double c_abs(complex *), sqrt(doublereal);
/* Local variables */
integer i__, j, k;
real sum, scale;
logical udiag;
extern logical lsame_(char *, char *);
real value;
extern /* Subroutine */ int classq_(integer *, complex *, 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 */
/* ======= */
/* CLANTP 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 */
/* =========== */
/* CLANTP returns the value */
/* CLANTP = ( 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 CLANTP 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, CLANTP is */
/* set to zero. */
/* AP (input) COMPLEX 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* 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__1 = value, r__2 = c_abs(&ap[i__]);
value = dmax(r__1,r__2);
/* 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__1 = value, r__2 = c_abs(&ap[i__]);
value = dmax(r__1,r__2);
/* 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__) {
/* Computing MAX */
r__1 = value, r__2 = c_abs(&ap[i__]);
value = dmax(r__1,r__2);
/* 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__1 = value, r__2 = c_abs(&ap[i__]);
value = dmax(r__1,r__2);
/* 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 += c_abs(&ap[i__]);
/* L90: */
}
} else {
sum = 0.f;
i__2 = k + j - 1;
for (i__ = k; i__ <= i__2; ++i__) {
sum += c_abs(&ap[i__]);
/* 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 += c_abs(&ap[i__]);
/* L120: */
}
} else {
sum = 0.f;
i__2 = k + *n - j;
for (i__ = k; i__ <= i__2; ++i__) {
sum += c_abs(&ap[i__]);
/* L130: */
}
}
k = k + *n - j + 1;
value = dmax(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__] += c_abs(&ap[k]);
++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__] += c_abs(&ap[k]);
++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__] += c_abs(&ap[k]);
++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__] += c_abs(&ap[k]);
++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") || 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;
classq_(&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) {
classq_(&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;
classq_(&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;
classq_(&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 CLANTP */
} /* clantp_ */
double clantb_(char *norm, char *uplo, char *diag, int *n, int *k,
complex *ab, int *ldab, float *work)
{
/* System generated locals */
int ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
float ret_val, r__1, r__2;
/* Builtin functions */
double c_abs(complex *), sqrt(double);
/* Local variables */
int i__, j, l;
float sum, scale;
int udiag;
extern int lsame_(char *, char *);
float value;
extern int classq_(int *, complex *, 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 */
/* ======= */
/* CLANTB 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 */
/* =========== */
/* CLANTB returns the value */
/* CLANTB = ( 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 CLANTB 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, CLANTB 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) COMPLEX 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. 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))). */
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__1 = value, r__2 = c_abs(&ab[i__ + j * ab_dim1]);
value = MAX(r__1,r__2);
/* 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__1 = value, r__2 = c_abs(&ab[i__ + j * ab_dim1]);
value = MAX(r__1,r__2);
/* 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__1 = value, r__2 = c_abs(&ab[i__ + j * ab_dim1]);
value = MAX(r__1,r__2);
/* 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__1 = value, r__2 = c_abs(&ab[i__ + j * ab_dim1]);
value = MAX(r__1,r__2);
/* 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 += c_abs(&ab[i__ + j * ab_dim1]);
/* 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 += c_abs(&ab[i__ + j * ab_dim1]);
/* L100: */
}
}
value = MAX(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 += c_abs(&ab[i__ + j * ab_dim1]);
/* 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 += c_abs(&ab[i__ + j * ab_dim1]);
/* L130: */
}
}
value = MAX(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__] += c_abs(&ab[l + i__ + j * ab_dim1]);
/* 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__] += c_abs(&ab[l + i__ + j * ab_dim1]);
/* 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__] += c_abs(&ab[l + i__ + j * ab_dim1]);
/* 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__] += c_abs(&ab[l + i__ + j * ab_dim1]);
/* L250: */
}
/* L260: */
}
}
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = value, r__2 = work[i__];
value = MAX(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 = (float) (*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;
classq_(&i__3, &ab[MAX(i__2, 1)+ j * ab_dim1], &c__1,
&scale, &sum);
/* L280: */
}
}
} 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;
classq_(&i__3, &ab[MAX(i__5, 1)+ j * ab_dim1], &c__1, &
scale, &sum);
/* L290: */
}
}
} else {
if (lsame_(diag, "U")) {
scale = 1.f;
sum = (float) (*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);
classq_(&i__3, &ab[j * ab_dim1 + 2], &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);
classq_(&i__3, &ab[j * ab_dim1 + 1], &c__1, &scale, &sum);
/* L310: */
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of CLANTB */
} /* clantb_ */
doublereal clantb_(char *norm, char *uplo, char *diag, integer *n, integer *k,
complex *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
=======
CLANTB 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
===========
CLANTB returns the value
CLANTB = ( 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 CLANTB 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, CLANTB 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) COMPLEX 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;
/* Builtin functions */
double c_abs(complex *), 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 classq_(integer *, complex *, integer *, real
*, real *);
static real sum;
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
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__1 = value, r__2 = c_abs(&ab_ref(i__, j));
value = dmax(r__1,r__2);
/* 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__1 = value, r__2 = c_abs(&ab_ref(i__, j));
value = dmax(r__1,r__2);
/* 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__1 = value, r__2 = c_abs(&ab_ref(i__, j));
value = dmax(r__1,r__2);
/* 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__1 = value, r__2 = c_abs(&ab_ref(i__, j));
value = dmax(r__1,r__2);
/* 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 += c_abs(&ab_ref(i__, j));
/* 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 += c_abs(&ab_ref(i__, j));
/* 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 += c_abs(&ab_ref(i__, j));
/* 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 += c_abs(&ab_ref(i__, j));
/* 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__] += c_abs(&ab_ref(l + i__, j));
/* 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__] += c_abs(&ab_ref(l + i__, j));
/* 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__] += c_abs(&ab_ref(l + i__, j));
/* 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__] += c_abs(&ab_ref(l + i__, j));
/* 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);
classq_(&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);
classq_(&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);
classq_(&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);
classq_(&i__3, &ab_ref(1, j), &c__1, &scale, &sum);
/* L310: */
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of CLANTB */
} /* clantb_ */
double clantr_(char *norm, char *uplo, char *diag, int *m, int *n,
complex *a, int *lda, float *work)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3, i__4;
float ret_val, r__1, r__2;
/* Builtin functions */
double c_abs(complex *), sqrt(double);
/* Local variables */
int i__, j;
float sum, scale;
int udiag;
extern int lsame_(char *, char *);
float value;
extern int classq_(int *, complex *, 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 */
/* ======= */
/* CLANTR 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 */
/* =========== */
/* CLANTR returns the value */
/* CLANTR = ( 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 CLANTR 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, CLANTR 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, CLANTR is set to zero. */
/* A (input) COMPLEX 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 Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. 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__1 = value, r__2 = c_abs(&a[i__ + j * a_dim1]);
value = MAX(r__1,r__2);
/* 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__1 = value, r__2 = c_abs(&a[i__ + j * a_dim1]);
value = MAX(r__1,r__2);
/* 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__1 = value, r__2 = c_abs(&a[i__ + j * a_dim1]);
value = MAX(r__1,r__2);
/* 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__1 = value, r__2 = c_abs(&a[i__ + j * a_dim1]);
value = MAX(r__1,r__2);
/* 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 += c_abs(&a[i__ + j * a_dim1]);
/* L90: */
}
} else {
sum = 0.f;
i__2 = MIN(*m,j);
for (i__ = 1; i__ <= i__2; ++i__) {
sum += c_abs(&a[i__ + j * a_dim1]);
/* L100: */
}
}
value = MAX(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 += c_abs(&a[i__ + j * a_dim1]);
/* L120: */
}
} else {
sum = 0.f;
i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) {
sum += c_abs(&a[i__ + j * a_dim1]);
/* L130: */
}
}
value = MAX(value,sum);
/* L140: */
}
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
i__1 = *m;
for (i__ = 1; i__ <= 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__] += c_abs(&a[i__ + j * a_dim1]);
/* 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__] += c_abs(&a[i__ + j * a_dim1]);
/* 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__] += c_abs(&a[i__ + j * a_dim1]);
/* 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__] += c_abs(&a[i__ + j * a_dim1]);
/* 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 = MAX(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 = (float) 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);
classq_(&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);
classq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L300: */
}
}
} else {
if (lsame_(diag, "U")) {
scale = 1.f;
sum = (float) 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;
classq_(&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;
classq_(&i__2, &a[j + j * a_dim1], &c__1, &scale, &sum);
/* L320: */
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of CLANTR */
} /* clantr_ */
/* ===================================================================== */
real clansy_(char *norm, char *uplo, integer *n, complex *a, integer *lda, real *work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real ret_val;
/* Builtin functions */
double c_abs(complex *), sqrt(doublereal);
/* Local variables */
integer i__, j;
real sum, absa, scale;
extern logical lsame_(char *, char *);
real value;
extern /* Subroutine */
int classq_(integer *, complex *, integer *, real *, real *);
extern logical sisnan_(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 */
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(f2c_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__)
{
sum = c_abs(&a[i__ + j * a_dim1]);
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L10: */
}
/* L20: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n;
for (i__ = j;
i__ <= i__2;
++i__)
{
sum = c_abs(&a[i__ + j * a_dim1]);
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* 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 = c_abs(&a[i__ + j * a_dim1]);
sum += absa;
work[i__] += absa;
/* L50: */
}
work[j] = sum + c_abs(&a[j + j * a_dim1]);
/* 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] + c_abs(&a[j + j * a_dim1]);
i__2 = *n;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
absa = c_abs(&a[i__ + j * a_dim1]);
sum += absa;
work[i__] += absa;
/* 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;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 2;
j <= i__1;
++j)
{
i__2 = j - 1;
classq_(&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;
classq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum);
/* L120: */
}
}
sum *= 2;
i__1 = *lda + 1;
classq_(n, &a[a_offset], &i__1, &scale, &sum);
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of CLANSY */
}
