/* ===================================================================== */
doublereal zlantp_(char *norm, char *uplo, char *diag, integer *n, doublecomplex *ap, doublereal *work)
{
/* System generated locals */
integer i__1, i__2;
doublereal ret_val;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
integer i__, j, k;
doublereal sum, scale;
logical udiag;
extern logical lsame_(char *, char *);
doublereal value;
extern logical disnan_(doublereal *);
extern /* Subroutine */
int zlassq_(integer *, doublecomplex *, integer *, doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--work;
--ap;
/* Function Body */
if (*n == 0)
{
value = 0.;
}
else if (lsame_(norm, "M"))
{
/* Find max(abs(A(i,j))). */
k = 1;
if (lsame_(diag, "U"))
{
value = 1.;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = k + j - 2;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum = z_abs(&ap[i__]);
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L10: */
}
k += j;
/* L20: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = k + *n - j;
for (i__ = k + 1;
i__ <= i__2;
++i__)
{
sum = z_abs(&ap[i__]);
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L30: */
}
k = k + *n - j + 1;
/* L40: */
}
}
}
else
{
value = 0.;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = k + j - 1;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum = z_abs(&ap[i__]);
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L50: */
}
k += j;
/* L60: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = k + *n - j;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum = z_abs(&ap[i__]);
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L70: */
}
k = k + *n - j + 1;
/* L80: */
}
}
}
}
else if (lsame_(norm, "O") || *(unsigned char *) norm == '1')
{
/* Find norm1(A). */
value = 0.;
k = 1;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (udiag)
{
sum = 1.;
i__2 = k + j - 2;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum += z_abs(&ap[i__]);
/* L90: */
}
}
else
{
sum = 0.;
i__2 = k + j - 1;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum += z_abs(&ap[i__]);
/* L100: */
}
}
k += j;
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L110: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (udiag)
{
sum = 1.;
i__2 = k + *n - j;
for (i__ = k + 1;
i__ <= i__2;
++i__)
{
sum += z_abs(&ap[i__]);
/* L120: */
}
}
else
{
sum = 0.;
i__2 = k + *n - j;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum += z_abs(&ap[i__]);
/* L130: */
}
}
k = k + *n - j + 1;
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L140: */
}
}
}
else if (lsame_(norm, "I"))
{
/* Find normI(A). */
k = 1;
if (lsame_(uplo, "U"))
{
if (lsame_(diag, "U"))
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 1.;
/* L150: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j - 1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[i__] += z_abs(&ap[k]);
++k;
/* L160: */
}
++k;
/* L170: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.;
/* L180: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j;
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[i__] += z_abs(&ap[k]);
++k;
/* L190: */
}
/* L200: */
}
}
}
else
{
if (lsame_(diag, "U"))
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 1.;
/* L210: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
++k;
i__2 = *n;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
work[i__] += z_abs(&ap[k]);
++k;
/* L220: */
}
/* L230: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.;
/* L240: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n;
for (i__ = j;
i__ <= i__2;
++i__)
{
work[i__] += z_abs(&ap[k]);
++k;
/* L250: */
}
/* L260: */
}
}
}
value = 0.;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
sum = work[i__];
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L270: */
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
if (lsame_(uplo, "U"))
{
if (lsame_(diag, "U"))
{
scale = 1.;
sum = (doublereal) (*n);
k = 2;
i__1 = *n;
for (j = 2;
j <= i__1;
++j)
{
i__2 = j - 1;
zlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k += j;
/* L280: */
}
}
else
{
scale = 0.;
sum = 1.;
k = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
zlassq_(&j, &ap[k], &c__1, &scale, &sum);
k += j;
/* L290: */
}
}
}
else
{
if (lsame_(diag, "U"))
{
scale = 1.;
sum = (doublereal) (*n);
k = 2;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j;
zlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k = k + *n - j + 1;
/* L300: */
}
}
else
{
scale = 0.;
sum = 1.;
k = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j + 1;
zlassq_(&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 ZLANTP */
}
/* Subroutine */
int zheequb_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *s, doublereal *scond, doublereal *amax, doublecomplex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag(doublecomplex *), sqrt(doublereal), log(doublereal), pow_di( doublereal *, integer *);
/* Local variables */
doublereal d__;
integer i__, j;
doublereal t, u, c0, c1, c2, si;
logical up;
doublereal avg, std, tol, base;
integer iter;
doublereal smin, smax, scale;
extern logical lsame_(char *, char *);
doublereal sumsq;
extern doublereal dlamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *);
doublereal bignum, smlnum;
extern /* Subroutine */
int zlassq_(integer *, doublecomplex *, integer *, doublereal *, doublereal *);
/* -- LAPACK computational routine (version 3.4.1) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* April 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function Definitions .. */
/* Test input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--s;
--work;
/* Function Body */
*info = 0;
if (! (lsame_(uplo, "U") || lsame_(uplo, "L")))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*lda < max(1,*n))
{
*info = -4;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZHEEQUB", &i__1);
return 0;
}
up = lsame_(uplo, "U");
*amax = 0.;
/* Quick return if possible. */
if (*n == 0)
{
*scond = 1.;
return 0;
}
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
s[i__] = 0.;
}
*amax = 0.;
if (up)
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j - 1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = s[i__];
d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j * a_dim1]), abs(d__2)); // , expr subst
s[i__] = max(d__3,d__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = s[j];
d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j * a_dim1]), abs(d__2)); // , expr subst
s[j] = max(d__3,d__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = *amax;
d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j * a_dim1]), abs(d__2)); // , expr subst
*amax = max(d__3,d__4);
}
/* Computing MAX */
i__2 = j + j * a_dim1;
d__3 = s[j];
d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a[j + j * a_dim1]), abs(d__2)); // , expr subst
s[j] = max(d__3,d__4);
/* Computing MAX */
i__2 = j + j * a_dim1;
d__3 = *amax;
d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a[j + j * a_dim1]), abs(d__2)); // , expr subst
*amax = max(d__3,d__4);
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MAX */
i__2 = j + j * a_dim1;
d__3 = s[j];
d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a[j + j * a_dim1]), abs(d__2)); // , expr subst
s[j] = max(d__3,d__4);
/* Computing MAX */
i__2 = j + j * a_dim1;
d__3 = *amax;
d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a[j + j * a_dim1]), abs(d__2)); // , expr subst
*amax = max(d__3,d__4);
i__2 = *n;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = s[i__];
d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j * a_dim1]), abs(d__2)); // , expr subst
s[i__] = max(d__3,d__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = s[j];
d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j * a_dim1]), abs(d__2)); // , expr subst
s[j] = max(d__3,d__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = *amax;
d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j * a_dim1]), abs(d__2)); // , expr subst
*amax = max(d__3,d__4);
}
}
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
s[j] = 1. / s[j];
}
tol = 1. / sqrt(*n * 2.);
for (iter = 1;
iter <= 100;
++iter)
{
scale = 0.;
sumsq = 0.;
/* beta = |A|s */
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i__2 = i__;
work[i__2].r = 0.;
work[i__2].i = 0.; // , expr subst
}
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 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j * a_dim1]), abs(d__2));
i__3 = i__;
i__4 = i__;
i__5 = i__ + j * a_dim1;
d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[ i__ + j * a_dim1]), abs(d__2))) * s[j];
z__1.r = work[i__4].r + d__3;
z__1.i = work[i__4].i; // , expr subst
work[i__3].r = z__1.r;
work[i__3].i = z__1.i; // , expr subst
i__3 = j;
i__4 = j;
i__5 = i__ + j * a_dim1;
d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[ i__ + j * a_dim1]), abs(d__2))) * s[i__];
z__1.r = work[i__4].r + d__3;
z__1.i = work[i__4].i; // , expr subst
work[i__3].r = z__1.r;
work[i__3].i = z__1.i; // , expr subst
}
i__2 = j;
i__3 = j;
i__4 = j + j * a_dim1;
d__3 = ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[j + j * a_dim1]), abs(d__2))) * s[j];
z__1.r = work[i__3].r + d__3;
z__1.i = work[i__3].i; // , expr subst
work[i__2].r = z__1.r;
work[i__2].i = z__1.i; // , expr subst
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j;
i__3 = j;
i__4 = j + j * a_dim1;
d__3 = ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[j + j * a_dim1]), abs(d__2))) * s[j];
z__1.r = work[i__3].r + d__3;
z__1.i = work[i__3].i; // , expr subst
work[i__2].r = z__1.r;
work[i__2].i = z__1.i; // , expr subst
i__2 = *n;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
i__3 = i__ + j * a_dim1;
t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j * a_dim1]), abs(d__2));
i__3 = i__;
i__4 = i__;
i__5 = i__ + j * a_dim1;
d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[ i__ + j * a_dim1]), abs(d__2))) * s[j];
z__1.r = work[i__4].r + d__3;
z__1.i = work[i__4].i; // , expr subst
work[i__3].r = z__1.r;
work[i__3].i = z__1.i; // , expr subst
i__3 = j;
i__4 = j;
i__5 = i__ + j * a_dim1;
d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[ i__ + j * a_dim1]), abs(d__2))) * s[i__];
z__1.r = work[i__4].r + d__3;
z__1.i = work[i__4].i; // , expr subst
work[i__3].r = z__1.r;
work[i__3].i = z__1.i; // , expr subst
}
}
}
/* avg = s^T beta / n */
avg = 0.;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i__2 = i__;
i__3 = i__;
z__2.r = s[i__2] * work[i__3].r;
z__2.i = s[i__2] * work[i__3].i; // , expr subst
z__1.r = avg + z__2.r;
z__1.i = z__2.i; // , expr subst
avg = z__1.r;
}
avg /= *n;
std = 0.;
i__1 = *n * 3;
for (i__ = (*n << 1) + 1;
i__ <= i__1;
++i__)
{
i__2 = i__;
i__3 = i__ - (*n << 1);
i__4 = i__ - (*n << 1);
z__2.r = s[i__3] * work[i__4].r;
z__2.i = s[i__3] * work[i__4].i; // , expr subst
z__1.r = z__2.r - avg;
z__1.i = z__2.i; // , expr subst
work[i__2].r = z__1.r;
work[i__2].i = z__1.i; // , expr subst
}
zlassq_(n, &work[(*n << 1) + 1], &c__1, &scale, &sumsq);
std = scale * sqrt(sumsq / *n);
if (std < tol * avg)
{
goto L999;
}
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i__2 = i__ + i__ * a_dim1;
t = (d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + i__ * a_dim1]), abs(d__2));
si = s[i__];
c2 = (*n - 1) * t;
i__2 = *n - 2;
i__3 = i__;
d__1 = t * si;
z__2.r = work[i__3].r - d__1;
z__2.i = work[i__3].i; // , expr subst
d__2 = (doublereal) i__2;
z__1.r = d__2 * z__2.r;
z__1.i = d__2 * z__2.i; // , expr subst
c1 = z__1.r;
d__1 = -(t * si) * si;
i__2 = i__;
d__2 = 2.;
z__4.r = d__2 * work[i__2].r;
z__4.i = d__2 * work[i__2].i; // , expr subst
z__3.r = si * z__4.r;
z__3.i = si * z__4.i; // , expr subst
z__2.r = d__1 + z__3.r;
z__2.i = z__3.i; // , expr subst
d__3 = *n * avg;
z__1.r = z__2.r - d__3;
z__1.i = z__2.i; // , expr subst
c0 = z__1.r;
d__ = c1 * c1 - c0 * 4 * c2;
if (d__ <= 0.)
{
*info = -1;
return 0;
}
si = c0 * -2 / (c1 + sqrt(d__));
d__ = si - s[i__];
u = 0.;
if (up)
{
i__2 = i__;
for (j = 1;
j <= i__2;
++j)
{
i__3 = j + i__ * a_dim1;
t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j + i__ * a_dim1]), abs(d__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
d__1 = d__ * t;
z__1.r = work[i__4].r + d__1;
z__1.i = work[i__4].i; // , expr subst
work[i__3].r = z__1.r;
work[i__3].i = z__1.i; // , expr subst
}
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
i__3 = i__ + j * a_dim1;
t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j * a_dim1]), abs(d__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
d__1 = d__ * t;
z__1.r = work[i__4].r + d__1;
z__1.i = work[i__4].i; // , expr subst
work[i__3].r = z__1.r;
work[i__3].i = z__1.i; // , expr subst
}
}
else
{
i__2 = i__;
for (j = 1;
j <= i__2;
++j)
{
i__3 = i__ + j * a_dim1;
t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j * a_dim1]), abs(d__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
d__1 = d__ * t;
z__1.r = work[i__4].r + d__1;
z__1.i = work[i__4].i; // , expr subst
work[i__3].r = z__1.r;
work[i__3].i = z__1.i; // , expr subst
}
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
i__3 = j + i__ * a_dim1;
t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j + i__ * a_dim1]), abs(d__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
d__1 = d__ * t;
z__1.r = work[i__4].r + d__1;
z__1.i = work[i__4].i; // , expr subst
work[i__3].r = z__1.r;
work[i__3].i = z__1.i; // , expr subst
}
}
i__2 = i__;
z__4.r = u + work[i__2].r;
z__4.i = work[i__2].i; // , expr subst
z__3.r = d__ * z__4.r;
z__3.i = d__ * z__4.i; // , expr subst
d__1 = (doublereal) (*n);
z__2.r = z__3.r / d__1;
z__2.i = z__3.i / d__1; // , expr subst
z__1.r = avg + z__2.r;
z__1.i = z__2.i; // , expr subst
avg = z__1.r;
s[i__] = si;
}
}
L999:
smlnum = dlamch_("SAFEMIN");
bignum = 1. / smlnum;
smin = bignum;
smax = 0.;
t = 1. / sqrt(avg);
base = dlamch_("B");
u = 1. / log(base);
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i__2 = (integer) (u * log(s[i__] * t));
s[i__] = pow_di(&base, &i__2);
/* Computing MIN */
d__1 = smin;
d__2 = s[i__]; // , expr subst
smin = min(d__1,d__2);
/* Computing MAX */
d__1 = smax;
d__2 = s[i__]; // , expr subst
smax = max(d__1,d__2);
}
*scond = max(smin,smlnum) / min(smax,bignum);
return 0;
}
doublereal zlansb_(char *norm, char *uplo, integer *n, integer *k,
doublecomplex *ab, integer *ldab, doublereal *work)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
doublereal ret_val, d__1, d__2;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
integer i__, j, l;
doublereal sum, absa, scale;
extern logical lsame_(char *, char *);
doublereal value;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLANSB 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 */
/* =========== */
/* ZLANSB returns the value */
/* ZLANSB = ( 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 ZLANSB 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, ZLANSB 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*16 array, dimension (LDAB,N) */
/* The upper or lower triangle of the symmetric band matrix A, */
/* stored in the first K+1 rows of AB. The j-th column of A is */
/* stored in the j-th column of the array AB as follows: */
/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= K+1. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
/* WORK is not referenced. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External 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.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k + 1;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
value = max(d__1,d__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__ = 1; i__ <= i__3; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
value = max(d__1,d__2);
/* L30: */
}
/* L40: */
}
}
} else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
/* Find normI(A) ( = norm1(A), since A is symmetric). */
value = 0.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
l = *k + 1 - j;
/* Computing MAX */
i__3 = 1, i__2 = j - *k;
i__4 = j - 1;
for (i__ = max(i__3,i__2); i__ <= i__4; ++i__) {
absa = z_abs(&ab[l + i__ + j * ab_dim1]);
sum += absa;
work[i__] += absa;
/* L50: */
}
work[j] = sum + z_abs(&ab[*k + 1 + j * ab_dim1]);
/* L60: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L70: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L80: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = work[j] + z_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 = z_abs(&ab[l + i__ + j * ab_dim1]);
sum += absa;
work[i__] += absa;
/* L90: */
}
value = max(value,sum);
/* L100: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
if (*k > 0) {
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j - 1;
i__4 = min(i__3,*k);
/* Computing MAX */
i__2 = *k + 2 - j;
zlassq_(&i__4, &ab[max(i__2, 1)+ j * ab_dim1], &c__1, &
scale, &sum);
/* L110: */
}
l = *k + 1;
} else {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n - j;
i__4 = min(i__3,*k);
zlassq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, &scale, &sum);
/* L120: */
}
l = 1;
}
sum *= 2;
} else {
l = 1;
}
zlassq_(n, &ab[l + ab_dim1], ldab, &scale, &sum);
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of ZLANSB */
} /* zlansb_ */
doublereal zlanhp_(char *norm, char *uplo, integer *n, doublecomplex *ap,
doublereal *work)
{
/* System generated locals */
integer i__1, i__2;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
integer i__, j, k;
doublereal sum, absa, scale;
extern logical lsame_(char *, char *);
doublereal value;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLANHP 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 */
/* =========== */
/* ZLANHP returns the value */
/* ZLANHP = ( 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 ZLANHP 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, ZLANHP is */
/* set to zero. */
/* AP (input) COMPLEX*16 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) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
/* WORK is not referenced. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--work;
--ap;
/* Function Body */
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.;
if (lsame_(uplo, "U")) {
k = 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 */
d__1 = value, d__2 = z_abs(&ap[i__]);
value = max(d__1,d__2);
/* L10: */
}
k += j;
/* Computing MAX */
i__2 = k;
d__2 = value, d__3 = (d__1 = ap[i__2].r, abs(d__1));
value = max(d__2,d__3);
/* L20: */
}
} else {
k = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = k;
d__2 = value, d__3 = (d__1 = ap[i__2].r, abs(d__1));
value = max(d__2,d__3);
i__2 = k + *n - j;
for (i__ = k + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&ap[i__]);
value = max(d__1,d__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.;
k = 1;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
absa = z_abs(&ap[k]);
sum += absa;
work[i__] += absa;
++k;
/* L50: */
}
i__2 = k;
work[j] = sum + (d__1 = ap[i__2].r, abs(d__1));
++k;
/* L60: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L70: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L80: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = k;
sum = work[j] + (d__1 = ap[i__2].r, abs(d__1));
++k;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
absa = z_abs(&ap[k]);
sum += absa;
work[i__] += absa;
++k;
/* L90: */
}
value = max(value,sum);
/* L100: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
k = 2;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
zlassq_(&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;
zlassq_(&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.) {
i__2 = k;
absa = (d__1 = ap[i__2].r, abs(d__1));
if (scale < absa) {
/* Computing 2nd power */
d__1 = scale / absa;
sum = sum * (d__1 * d__1) + 1.;
scale = absa;
} else {
/* Computing 2nd power */
d__1 = absa / scale;
sum += d__1 * d__1;
}
}
if (lsame_(uplo, "U")) {
k = k + i__ + 1;
} else {
k = k + *n - i__ + 1;
}
/* L130: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of ZLANHP */
} /* zlanhp_ */
/* Subroutine */ int ztgex2_(logical *wantq, logical *wantz, integer *n,
doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
doublecomplex *q, integer *ldq, doublecomplex *z__, integer *ldz,
integer *j1, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
double sqrt(doublereal), z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static doublecomplex f, g;
static integer i__, m;
static doublecomplex s[4] /* was [2][2] */, t[4] /* was [2][2] */;
static doublereal cq, sa, sb, cz;
static doublecomplex sq;
static doublereal ss, ws;
static doublecomplex sz;
static doublereal eps, sum;
static logical weak;
static doublecomplex cdum, work[8];
extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublecomplex *);
static doublereal scale;
extern doublereal dlamch_(char *, ftnlen);
static logical dtrong;
static doublereal thresh;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen),
zlartg_(doublecomplex *, doublecomplex *, doublereal *,
doublecomplex *, doublecomplex *);
static doublereal smlnum;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22) */
/* in an upper triangular matrix pair (A, B) by an unitary equivalence */
/* transformation. */
/* (A, B) must be in generalized Schur canonical form, that is, A and */
/* B are both upper triangular. */
/* Optionally, the matrices Q and Z of generalized Schur vectors are */
/* updated. */
/* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */
/* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */
/* Arguments */
/* ========= */
/* WANTQ (input) LOGICAL */
/* .TRUE. : update the left transformation matrix Q; */
/* .FALSE.: do not update Q. */
/* WANTZ (input) LOGICAL */
/* .TRUE. : update the right transformation matrix Z; */
/* .FALSE.: do not update Z. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) COMPLEX*16 arrays, dimensions (LDA,N) */
/* On entry, the matrix A in the pair (A, B). */
/* On exit, the updated matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) COMPLEX*16 arrays, dimensions (LDB,N) */
/* On entry, the matrix B in the pair (A, B). */
/* On exit, the updated matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* Q (input/output) COMPLEX*16 array, dimension (LDZ,N) */
/* If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit, */
/* the updated matrix Q. */
/* Not referenced if WANTQ = .FALSE.. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= 1; */
/* If WANTQ = .TRUE., LDQ >= N. */
/* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */
/* If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit, */
/* the updated matrix Z. */
/* Not referenced if WANTZ = .FALSE.. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1; */
/* If WANTZ = .TRUE., LDZ >= N. */
/* J1 (input) INTEGER */
/* The index to the first block (A11, B11). */
/* INFO (output) INTEGER */
/* =0: Successful exit. */
/* =1: The transformed matrix pair (A, B) would be too far */
/* from generalized Schur form; the problem is ill- */
/* conditioned. (A, B) may have been partially reordered, */
/* and ILST points to the first row of the current */
/* position of the block being moved. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* In the current code both weak and strong stability tests are */
/* performed. The user can omit the strong stability test by changing */
/* the internal logical parameter WANDS to .FALSE.. See ref. [2] for */
/* details. */
/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
/* Estimation: Theory, Algorithms and Software, Report UMINF-94.04, */
/* Department of Computing Science, Umea University, S-901 87 Umea, */
/* Sweden, 1994. Also as LAPACK Working Note 87. To appear in */
/* Numerical Algorithms, 1996. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n <= 1) {
return 0;
}
m = 2;
weak = FALSE_;
dtrong = FALSE_;
/* Make a local copy of selected block in (A, B) */
zlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, s, &c__2, (ftnlen)4);
zlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, t, &c__2, (ftnlen)4);
/* Compute the threshold for testing the acceptance of swapping. */
eps = dlamch_("P", (ftnlen)1);
smlnum = dlamch_("S", (ftnlen)1) / eps;
scale = 0.;
sum = 1.;
zlacpy_("Full", &m, &m, s, &c__2, work, &m, (ftnlen)4);
zlacpy_("Full", &m, &m, t, &c__2, &work[m * m], &m, (ftnlen)4);
i__1 = (m << 1) * m;
zlassq_(&i__1, work, &c__1, &scale, &sum);
sa = scale * sqrt(sum);
/* Computing MAX */
d__1 = eps * 10. * sa;
thresh = max(d__1,smlnum);
/* Compute unitary QL and RQ that swap 1-by-1 and 1-by-1 blocks */
/* using Givens rotations and perform the swap tentatively. */
z__2.r = s[3].r * t[0].r - s[3].i * t[0].i, z__2.i = s[3].r * t[0].i + s[
3].i * t[0].r;
z__3.r = t[3].r * s[0].r - t[3].i * s[0].i, z__3.i = t[3].r * s[0].i + t[
3].i * s[0].r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
f.r = z__1.r, f.i = z__1.i;
z__2.r = s[3].r * t[2].r - s[3].i * t[2].i, z__2.i = s[3].r * t[2].i + s[
3].i * t[2].r;
z__3.r = t[3].r * s[2].r - t[3].i * s[2].i, z__3.i = t[3].r * s[2].i + t[
3].i * s[2].r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
g.r = z__1.r, g.i = z__1.i;
sa = z_abs(&s[3]);
sb = z_abs(&t[3]);
zlartg_(&g, &f, &cz, &sz, &cdum);
z__1.r = -sz.r, z__1.i = -sz.i;
sz.r = z__1.r, sz.i = z__1.i;
d_cnjg(&z__1, &sz);
zrot_(&c__2, s, &c__1, &s[2], &c__1, &cz, &z__1);
d_cnjg(&z__1, &sz);
zrot_(&c__2, t, &c__1, &t[2], &c__1, &cz, &z__1);
if (sa >= sb) {
zlartg_(s, &s[1], &cq, &sq, &cdum);
} else {
zlartg_(t, &t[1], &cq, &sq, &cdum);
}
zrot_(&c__2, s, &c__2, &s[1], &c__2, &cq, &sq);
zrot_(&c__2, t, &c__2, &t[1], &c__2, &cq, &sq);
/* Weak stability test: |S21| + |T21| <= O(EPS F-norm((S, T))) */
ws = z_abs(&s[1]) + z_abs(&t[1]);
weak = ws <= thresh;
if (! weak) {
goto L20;
}
if (TRUE_) {
/* Strong stability test: */
/* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A, B))) */
zlacpy_("Full", &m, &m, s, &c__2, work, &m, (ftnlen)4);
zlacpy_("Full", &m, &m, t, &c__2, &work[m * m], &m, (ftnlen)4);
d_cnjg(&z__2, &sz);
z__1.r = -z__2.r, z__1.i = -z__2.i;
zrot_(&c__2, work, &c__1, &work[2], &c__1, &cz, &z__1);
d_cnjg(&z__2, &sz);
z__1.r = -z__2.r, z__1.i = -z__2.i;
zrot_(&c__2, &work[4], &c__1, &work[6], &c__1, &cz, &z__1);
z__1.r = -sq.r, z__1.i = -sq.i;
zrot_(&c__2, work, &c__2, &work[1], &c__2, &cq, &z__1);
z__1.r = -sq.r, z__1.i = -sq.i;
zrot_(&c__2, &work[4], &c__2, &work[5], &c__2, &cq, &z__1);
for (i__ = 1; i__ <= 2; ++i__) {
i__1 = i__ - 1;
i__2 = i__ - 1;
i__3 = *j1 + i__ - 1 + *j1 * a_dim1;
z__1.r = work[i__2].r - a[i__3].r, z__1.i = work[i__2].i - a[i__3]
.i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = i__ + 1;
i__2 = i__ + 1;
i__3 = *j1 + i__ - 1 + (*j1 + 1) * a_dim1;
z__1.r = work[i__2].r - a[i__3].r, z__1.i = work[i__2].i - a[i__3]
.i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = i__ + 3;
i__2 = i__ + 3;
i__3 = *j1 + i__ - 1 + *j1 * b_dim1;
z__1.r = work[i__2].r - b[i__3].r, z__1.i = work[i__2].i - b[i__3]
.i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = i__ + 5;
i__2 = i__ + 5;
i__3 = *j1 + i__ - 1 + (*j1 + 1) * b_dim1;
z__1.r = work[i__2].r - b[i__3].r, z__1.i = work[i__2].i - b[i__3]
.i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
/* L10: */
}
scale = 0.;
sum = 1.;
i__1 = (m << 1) * m;
zlassq_(&i__1, work, &c__1, &scale, &sum);
ss = scale * sqrt(sum);
dtrong = ss <= thresh;
if (! dtrong) {
goto L20;
}
}
/* If the swap is accepted ("weakly" and "strongly"), apply the */
/* equivalence transformations to the original matrix pair (A,B) */
i__1 = *j1 + 1;
d_cnjg(&z__1, &sz);
zrot_(&i__1, &a[*j1 * a_dim1 + 1], &c__1, &a[(*j1 + 1) * a_dim1 + 1], &
c__1, &cz, &z__1);
i__1 = *j1 + 1;
d_cnjg(&z__1, &sz);
zrot_(&i__1, &b[*j1 * b_dim1 + 1], &c__1, &b[(*j1 + 1) * b_dim1 + 1], &
c__1, &cz, &z__1);
i__1 = *n - *j1 + 1;
zrot_(&i__1, &a[*j1 + *j1 * a_dim1], lda, &a[*j1 + 1 + *j1 * a_dim1], lda,
&cq, &sq);
i__1 = *n - *j1 + 1;
zrot_(&i__1, &b[*j1 + *j1 * b_dim1], ldb, &b[*j1 + 1 + *j1 * b_dim1], ldb,
&cq, &sq);
/* Set N1 by N2 (2,1) blocks to 0 */
i__1 = *j1 + 1 + *j1 * a_dim1;
a[i__1].r = 0., a[i__1].i = 0.;
i__1 = *j1 + 1 + *j1 * b_dim1;
b[i__1].r = 0., b[i__1].i = 0.;
/* Accumulate transformations into Q and Z if requested. */
if (*wantz) {
d_cnjg(&z__1, &sz);
zrot_(n, &z__[*j1 * z_dim1 + 1], &c__1, &z__[(*j1 + 1) * z_dim1 + 1],
&c__1, &cz, &z__1);
}
if (*wantq) {
d_cnjg(&z__1, &sq);
zrot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[(*j1 + 1) * q_dim1 + 1], &
c__1, &cq, &z__1);
}
/* Exit with INFO = 0 if swap was successfully performed. */
return 0;
/* Exit with INFO = 1 if swap was rejected. */
L20:
*info = 1;
return 0;
/* End of ZTGEX2 */
} /* ztgex2_ */
doublereal zlangt_(char *norm, integer *n, doublecomplex *dl, doublecomplex *
d, doublecomplex *du)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
ZLANGT 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
===========
ZLANGT returns the value
ZLANGT = ( 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 ZLANGT as described
above.
N (input) INTEGER
The order of the matrix A. N >= 0. When N = 0, ZLANGT is
set to zero.
DL (input) COMPLEX*16 array, dimension (N-1)
The (n-1) sub-diagonal elements of A.
D (input) COMPLEX*16 array, dimension (N)
The diagonal elements of A.
DU (input) COMPLEX*16 array, dimension (N-1)
The (n-1) super-diagonal elements of A.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer i__1;
doublereal ret_val, d__1, d__2;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static integer i;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal anorm;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
static doublereal sum;
#define DU(I) du[(I)-1]
#define D(I) d[(I)-1]
#define DL(I) dl[(I)-1]
if (*n <= 0) {
anorm = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
anorm = z_abs(&D(*n));
i__1 = *n - 1;
for (i = 1; i <= *n-1; ++i) {
/* Computing MAX */
d__1 = anorm, d__2 = z_abs(&DL(i));
anorm = max(d__1,d__2);
/* Computing MAX */
d__1 = anorm, d__2 = z_abs(&D(i));
anorm = max(d__1,d__2);
/* Computing MAX */
d__1 = anorm, d__2 = z_abs(&DU(i));
anorm = max(d__1,d__2);
/* L10: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)norm == '1') {
/* Find norm1(A). */
if (*n == 1) {
anorm = z_abs(&D(1));
} else {
/* Computing MAX */
d__1 = z_abs(&D(1)) + z_abs(&DL(1)), d__2 = z_abs(&D(*n)) + z_abs(
&DU(*n - 1));
anorm = max(d__1,d__2);
i__1 = *n - 1;
for (i = 2; i <= *n-1; ++i) {
/* Computing MAX */
d__1 = anorm, d__2 = z_abs(&D(i)) + z_abs(&DL(i)) + z_abs(&DU(
i - 1));
anorm = max(d__1,d__2);
/* L20: */
}
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
if (*n == 1) {
anorm = z_abs(&D(1));
} else {
/* Computing MAX */
d__1 = z_abs(&D(1)) + z_abs(&DU(1)), d__2 = z_abs(&D(*n)) + z_abs(
&DL(*n - 1));
anorm = max(d__1,d__2);
i__1 = *n - 1;
for (i = 2; i <= *n-1; ++i) {
/* Computing MAX */
d__1 = anorm, d__2 = z_abs(&D(i)) + z_abs(&DU(i)) + z_abs(&DL(
i - 1));
anorm = max(d__1,d__2);
/* L30: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
zlassq_(n, &D(1), &c__1, &scale, &sum);
if (*n > 1) {
i__1 = *n - 1;
zlassq_(&i__1, &DL(1), &c__1, &scale, &sum);
i__1 = *n - 1;
zlassq_(&i__1, &DU(1), &c__1, &scale, &sum);
}
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of ZLANGT */
} /* zlangt_ */
/* ===================================================================== */
doublereal zlansp_(char *norm, char *uplo, integer *n, doublecomplex *ap, doublereal *work)
{
/* System generated locals */
integer i__1, i__2;
doublereal ret_val, d__1;
/* Builtin functions */
double z_abs(doublecomplex *), d_imag(doublecomplex *), sqrt(doublereal);
/* Local variables */
integer i__, j, k;
doublereal sum, absa, scale;
extern logical lsame_(char *, char *);
doublereal value;
extern logical disnan_(doublereal *);
extern /* Subroutine */
int zlassq_(integer *, doublecomplex *, integer *, doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--work;
--ap;
/* Function Body */
if (*n == 0)
{
value = 0.;
}
else if (lsame_(norm, "M"))
{
/* Find max(abs(A(i,j))). */
value = 0.;
if (lsame_(uplo, "U"))
{
k = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = k + j - 1;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum = z_abs(&ap[i__]);
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L10: */
}
k += j;
/* L20: */
}
}
else
{
k = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = k + *n - j;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum = z_abs(&ap[i__]);
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L30: */
}
k = k + *n - j + 1;
/* L40: */
}
}
}
else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1')
{
/* Find normI(A) ( = norm1(A), since A is symmetric). */
value = 0.;
k = 1;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
sum = 0.;
i__2 = j - 1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
absa = z_abs(&ap[k]);
sum += absa;
work[i__] += absa;
++k;
/* L50: */
}
work[j] = sum + z_abs(&ap[k]);
++k;
/* L60: */
}
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
sum = work[i__];
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L70: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.;
/* L80: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
sum = work[j] + z_abs(&ap[k]);
++k;
i__2 = *n;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
absa = z_abs(&ap[k]);
sum += absa;
work[i__] += absa;
++k;
/* L90: */
}
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L100: */
}
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
scale = 0.;
sum = 1.;
k = 2;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 2;
j <= i__1;
++j)
{
i__2 = j - 1;
zlassq_(&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;
zlassq_(&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.)
{
i__2 = k;
absa = (d__1 = ap[i__2].r, abs(d__1));
if (scale < absa)
{
/* Computing 2nd power */
d__1 = scale / absa;
sum = sum * (d__1 * d__1) + 1.;
scale = absa;
}
else
{
/* Computing 2nd power */
d__1 = absa / scale;
sum += d__1 * d__1;
}
}
if (d_imag(&ap[k]) != 0.)
{
absa = (d__1 = d_imag(&ap[k]), abs(d__1));
if (scale < absa)
{
/* Computing 2nd power */
d__1 = scale / absa;
sum = sum * (d__1 * d__1) + 1.;
scale = absa;
}
else
{
/* Computing 2nd power */
d__1 = absa / scale;
sum += d__1 * d__1;
}
}
if (lsame_(uplo, "U"))
{
k = k + i__ + 1;
}
else
{
k = k + *n - i__ + 1;
}
/* L130: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of ZLANSP */
}
doublereal zlangb_(char *norm, integer *n, integer *kl, integer *ku,
doublecomplex *ab, integer *ldab, doublereal *work)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal ret_val, d__1, d__2;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
integer i__, j, k, l;
doublereal sum, scale;
extern logical lsame_(char *, char *);
doublereal value;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLANGB 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 */
/* =========== */
/* ZLANGB returns the value */
/* ZLANGB = ( 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 ZLANGB as described */
/* above. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, ZLANGB 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*16 array, dimension (LDAB,N) */
/* The band matrix A, stored in rows 1 to KL+KU+1. The j-th */
/* column of A is stored in the j-th column of the array AB as */
/* follows: */
/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* ===================================================================== */
/* .. 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.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = *ku + 2 - j;
/* Computing MIN */
i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
i__3 = min(i__4,i__5);
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
value = max(d__1,d__2);
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
/* Computing MAX */
i__3 = *ku + 2 - j;
/* Computing MIN */
i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
i__2 = min(i__4,i__5);
for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
sum += z_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.;
/* 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__] += z_abs(&ab[k + i__ + j * ab_dim1]);
/* L60: */
}
/* L70: */
}
value = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L80: */
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__4 = 1, i__2 = j - *ku;
l = max(i__4,i__2);
k = *ku + 1 - j + l;
/* Computing MIN */
i__2 = *n, i__3 = j + *kl;
i__4 = min(i__2,i__3) - l + 1;
zlassq_(&i__4, &ab[k + j * ab_dim1], &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of ZLANGB */
} /* zlangb_ */
doublereal zlanhb_(char *norm, char *uplo, integer *n, integer *k,
doublecomplex *ab, integer *ldab, doublereal *work)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
doublereal ret_val, d__1, d__2, d__3;
/* Local variables */
integer i__, j, l;
doublereal sum, absa, scale;
doublereal value;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZLANHB 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 */
/* =========== */
/* ZLANHB returns the value */
/* ZLANHB = ( 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 ZLANHB 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, ZLANHB 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*16 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) DOUBLE PRECISION 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.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
value = max(d__1,d__2);
}
/* Computing MAX */
i__3 = *k + 1 + j * ab_dim1;
d__2 = value, d__3 = (d__1 = ab[i__3].r, abs(d__1));
value = max(d__2,d__3);
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__3 = j * ab_dim1 + 1;
d__2 = value, d__3 = (d__1 = ab[i__3].r, abs(d__1));
value = max(d__2,d__3);
/* Computing MIN */
i__2 = *n + 1 - j, i__4 = *k + 1;
i__3 = min(i__2,i__4);
for (i__ = 2; i__ <= i__3; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
value = max(d__1,d__2);
}
}
}
} else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
/* Find normI(A) ( = norm1(A), since A is hermitian). */
value = 0.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
l = *k + 1 - j;
/* Computing MAX */
i__3 = 1, i__2 = j - *k;
i__4 = j - 1;
for (i__ = max(i__3,i__2); i__ <= i__4; ++i__) {
absa = z_abs(&ab[l + i__ + j * ab_dim1]);
sum += absa;
work[i__] += absa;
}
i__4 = *k + 1 + j * ab_dim1;
work[j] = sum + (d__1 = ab[i__4].r, abs(d__1));
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__4 = j * ab_dim1 + 1;
sum = work[j] + (d__1 = ab[i__4].r, abs(d__1));
l = 1 - j;
/* Computing MIN */
i__3 = *n, i__2 = j + *k;
i__4 = min(i__3,i__2);
for (i__ = j + 1; i__ <= i__4; ++i__) {
absa = z_abs(&ab[l + i__ + j * ab_dim1]);
sum += absa;
work[i__] += absa;
}
value = max(value,sum);
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
if (*k > 0) {
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j - 1;
i__4 = min(i__3,*k);
/* Computing MAX */
i__2 = *k + 2 - j;
zlassq_(&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);
zlassq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, &scale, &sum);
}
l = 1;
}
sum *= 2;
} else {
l = 1;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__4 = l + j * ab_dim1;
if (ab[i__4].r != 0.) {
i__4 = l + j * ab_dim1;
absa = (d__1 = ab[i__4].r, abs(d__1));
if (scale < absa) {
/* Computing 2nd power */
d__1 = scale / absa;
sum = sum * (d__1 * d__1) + 1.;
scale = absa;
} else {
/* Computing 2nd power */
d__1 = absa / scale;
sum += d__1 * d__1;
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of ZLANHB */
} /* zlanhb_ */
/* ===================================================================== */
doublereal zlangt_(char *norm, integer *n, doublecomplex *dl, doublecomplex * d__, doublecomplex *du)
{
/* System generated locals */
integer i__1;
doublereal ret_val, d__1;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
integer i__;
doublereal sum, temp, scale;
extern logical lsame_(char *, char *);
doublereal anorm;
extern logical disnan_(doublereal *);
extern /* Subroutine */
int zlassq_(integer *, doublecomplex *, integer *, doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--du;
--d__;
--dl;
/* Function Body */
if (*n <= 0)
{
anorm = 0.;
}
else if (lsame_(norm, "M"))
{
/* Find max(abs(A(i,j))). */
anorm = z_abs(&d__[*n]);
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
d__1 = z_abs(&dl[i__]);
if (anorm < z_abs(&dl[i__]) || disnan_(&d__1))
{
anorm = z_abs(&dl[i__]);
}
d__1 = z_abs(&d__[i__]);
if (anorm < z_abs(&d__[i__]) || disnan_(&d__1))
{
anorm = z_abs(&d__[i__]);
}
d__1 = z_abs(&du[i__]);
if (anorm < z_abs(&du[i__]) || disnan_(&d__1))
{
anorm = z_abs(&du[i__]);
}
/* L10: */
}
}
else if (lsame_(norm, "O") || *(unsigned char *) norm == '1')
{
/* Find norm1(A). */
if (*n == 1)
{
anorm = z_abs(&d__[1]);
}
else
{
anorm = z_abs(&d__[1]) + z_abs(&dl[1]);
temp = z_abs(&d__[*n]) + z_abs(&du[*n - 1]);
if (anorm < temp || disnan_(&temp))
{
anorm = temp;
}
i__1 = *n - 1;
for (i__ = 2;
i__ <= i__1;
++i__)
{
temp = z_abs(&d__[i__]) + z_abs(&dl[i__]) + z_abs(&du[i__ - 1] );
if (anorm < temp || disnan_(&temp))
{
anorm = temp;
}
/* L20: */
}
}
}
else if (lsame_(norm, "I"))
{
/* Find normI(A). */
if (*n == 1)
{
anorm = z_abs(&d__[1]);
}
else
{
anorm = z_abs(&d__[1]) + z_abs(&du[1]);
temp = z_abs(&d__[*n]) + z_abs(&dl[*n - 1]);
if (anorm < temp || disnan_(&temp))
{
anorm = temp;
}
i__1 = *n - 1;
for (i__ = 2;
i__ <= i__1;
++i__)
{
temp = z_abs(&d__[i__]) + z_abs(&du[i__]) + z_abs(&dl[i__ - 1] );
if (anorm < temp || disnan_(&temp))
{
anorm = temp;
}
/* L30: */
}
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
scale = 0.;
sum = 1.;
zlassq_(n, &d__[1], &c__1, &scale, &sum);
if (*n > 1)
{
i__1 = *n - 1;
zlassq_(&i__1, &dl[1], &c__1, &scale, &sum);
i__1 = *n - 1;
zlassq_(&i__1, &du[1], &c__1, &scale, &sum);
}
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of ZLANGT */
}
/*< DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) >*/
doublereal zlanhs_(char *norm, integer *n, doublecomplex *a, integer *lda,
doublereal *work, ftnlen norm_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal ret_val, d__1, d__2;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
integer i__, j;
doublereal sum, scale;
extern logical lsame_(const char *, const char *, ftnlen, ftnlen);
doublereal value=0;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
(void)norm_len;
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/*< CHARACTER NORM >*/
/*< INTEGER LDA, N >*/
/* .. */
/* .. Array Arguments .. */
/*< DOUBLE PRECISION WORK( * ) >*/
/*< COMPLEX*16 A( LDA, * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* ZLANHS 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 */
/* =========== */
/* ZLANHS returns the value */
/* ZLANHS = ( 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 ZLANHS as described */
/* above. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, ZLANHS is */
/* set to zero. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The n by n upper Hessenberg matrix A; the part of A below the */
/* first sub-diagonal is not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(N,1). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), */
/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* ===================================================================== */
/* .. Parameters .. */
/*< DOUBLE PRECISION ONE, ZERO >*/
/*< PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< INTEGER I, J >*/
/*< DOUBLE PRECISION SCALE, SUM, VALUE >*/
/* .. */
/* .. External Functions .. */
/*< LOGICAL LSAME >*/
/*< EXTERNAL LSAME >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL ZLASSQ >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC ABS, MAX, MIN, SQRT >*/
/* .. */
/* .. Executable Statements .. */
/*< IF( N.EQ.0 ) THEN >*/
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
/* Function Body */
if (*n == 0) {
/*< VALUE = ZERO >*/
value = 0.;
/*< ELSE IF( LSAME( NORM, 'M' ) ) THEN >*/
} else if (lsame_(norm, "M", (ftnlen)1, (ftnlen)1)) {
/* Find max(abs(A(i,j))). */
/*< VALUE = ZERO >*/
value = 0.;
/*< DO 20 J = 1, N >*/
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/*< DO 10 I = 1, MIN( N, J+1 ) >*/
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
/*< VALUE = MAX( VALUE, ABS( A( I, J ) ) ) >*/
/* Computing MAX */
d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
value = max(d__1,d__2);
/*< 10 CONTINUE >*/
/* L10: */
}
/*< 20 CONTINUE >*/
/* L20: */
}
/*< ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN >*/
} else if (lsame_(norm, "O", (ftnlen)1, (ftnlen)1) || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
/*< VALUE = ZERO >*/
value = 0.;
/*< DO 40 J = 1, N >*/
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/*< SUM = ZERO >*/
sum = 0.;
/*< DO 30 I = 1, MIN( N, J+1 ) >*/
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
/*< SUM = SUM + ABS( A( I, J ) ) >*/
sum += z_abs(&a[i__ + j * a_dim1]);
/*< 30 CONTINUE >*/
/* L30: */
}
/*< VALUE = MAX( VALUE, SUM ) >*/
value = max(value,sum);
/*< 40 CONTINUE >*/
/* L40: */
}
/*< ELSE IF( LSAME( NORM, 'I' ) ) THEN >*/
} else if (lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) {
/* Find normI(A). */
/*< DO 50 I = 1, N >*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< WORK( I ) = ZERO >*/
work[i__] = 0.;
/*< 50 CONTINUE >*/
/* L50: */
}
/*< DO 70 J = 1, N >*/
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/*< DO 60 I = 1, MIN( N, J+1 ) >*/
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
/*< WORK( I ) = WORK( I ) + ABS( A( I, J ) ) >*/
work[i__] += z_abs(&a[i__ + j * a_dim1]);
/*< 60 CONTINUE >*/
/* L60: */
}
/*< 70 CONTINUE >*/
/* L70: */
}
/*< VALUE = ZERO >*/
value = 0.;
/*< DO 80 I = 1, N >*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< VALUE = MAX( VALUE, WORK( I ) ) >*/
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/*< 80 CONTINUE >*/
/* L80: */
}
/*< ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN >*/
} else if (lsame_(norm, "F", (ftnlen)1, (ftnlen)1) || lsame_(norm, "E", (
ftnlen)1, (ftnlen)1)) {
/* Find normF(A). */
/*< SCALE = ZERO >*/
scale = 0.;
/*< SUM = ONE >*/
sum = 1.;
/*< DO 90 J = 1, N >*/
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/*< CALL ZLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) >*/
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/*< 90 CONTINUE >*/
/* L90: */
}
/*< VALUE = SCALE*SQRT( SUM ) >*/
value = scale * sqrt(sum);
/*< END IF >*/
}
/*< ZLANHS = VALUE >*/
ret_val = value;
/*< RETURN >*/
return ret_val;
/* End of ZLANHS */
/*< END >*/
} /* zlanhs_ */
double zlanht_(char *norm, int *n, double *d__, doublecomplex *e)
{
/* System generated locals */
int i__1;
double ret_val, d__1, d__2, d__3;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(double);
/* Local variables */
int i__;
double sum, scale;
extern int lsame_(char *, char *);
double anorm;
extern int dlassq_(int *, double *, int *,
double *, double *), zlassq_(int *, doublecomplex *,
int *, double *, double *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLANHT returns the value of the one norm, or the Frobenius norm, or */
/* the infinity norm, or the element of largest absolute value of a */
/* complex Hermitian tridiagonal matrix A. */
/* Description */
/* =========== */
/* ZLANHT returns the value */
/* ZLANHT = ( MAX(ABS(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum), */
/* normI denotes the infinity norm of a matrix (maximum row sum) and */
/* normF denotes the Frobenius norm of a matrix (square root of sum of */
/* squares). Note that MAX(ABS(A(i,j))) is not a consistent matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in ZLANHT as described */
/* above. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, ZLANHT is */
/* set to zero. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The diagonal elements of A. */
/* E (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) sub-diagonal or super-diagonal elements of A. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--e;
--d__;
/* Function Body */
if (*n <= 0) {
anorm = 0.;
} else if (lsame_(norm, "M")) {
/* Find MAX(ABS(A(i,j))). */
anorm = (d__1 = d__[*n], ABS(d__1));
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = d__[i__], ABS(d__1));
anorm = MAX(d__2,d__3);
/* Computing MAX */
d__1 = anorm, d__2 = z_abs(&e[i__]);
anorm = MAX(d__1,d__2);
/* L10: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1' || lsame_(norm, "I")) {
/* Find norm1(A). */
if (*n == 1) {
anorm = ABS(d__[1]);
} else {
/* Computing MAX */
d__2 = ABS(d__[1]) + z_abs(&e[1]), d__3 = z_abs(&e[*n - 1]) + (
d__1 = d__[*n], ABS(d__1));
anorm = MAX(d__2,d__3);
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = d__[i__], ABS(d__1)) + z_abs(&e[
i__]) + z_abs(&e[i__ - 1]);
anorm = MAX(d__2,d__3);
/* L20: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
if (*n > 1) {
i__1 = *n - 1;
zlassq_(&i__1, &e[1], &c__1, &scale, &sum);
sum *= 2;
}
dlassq_(n, &d__[1], &c__1, &scale, &sum);
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of ZLANHT */
} /* zlanht_ */
doublereal zlanhb_(char *norm, char *uplo, integer *n, integer *k,
doublecomplex *ab, integer *ldab, doublereal *work)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
ZLANHB 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
===========
ZLANHB returns the value
ZLANHB = ( 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 ZLANHB 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, ZLANHB 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*16 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) DOUBLE PRECISION 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;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static doublereal absa;
static integer i, j, l;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal value;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
static doublereal sum;
#define WORK(I) work[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i = max(*k+2-j,1); i <= *k; ++i) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&AB(i,j));
value = max(d__1,d__2);
/* L10: */
}
/* Computing MAX */
i__3 = *k + 1 + j * ab_dim1;
d__2 = value, d__3 = (d__1 = AB(*k+1,j).r, abs(d__1));
value = max(d__2,d__3);
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
/* Computing MAX */
i__3 = j * ab_dim1 + 1;
d__2 = value, d__3 = (d__1 = AB(1,j).r, abs(d__1));
value = max(d__2,d__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 */
d__1 = value, d__2 = z_abs(&AB(i,j));
value = max(d__1,d__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.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
sum = 0.;
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 = z_abs(&AB(l+i,j));
sum += absa;
WORK(i) += absa;
/* L50: */
}
i__4 = *k + 1 + j * ab_dim1;
WORK(j) = sum + (d__1 = AB(*k+1,j).r, abs(d__1));
/* L60: */
}
i__1 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
d__1 = value, d__2 = WORK(i);
value = max(d__1,d__2);
/* L70: */
}
} else {
i__1 = *n;
for (i = 1; i <= *n; ++i) {
WORK(i) = 0.;
/* L80: */
}
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__4 = j * ab_dim1 + 1;
sum = WORK(j) + (d__1 = AB(1,j).r, abs(d__1));
l = 1 - j;
/* Computing MIN */
i__3 = *n, i__2 = j + *k;
i__4 = min(i__3,i__2);
for (i = j + 1; i <= min(*n,j+*k); ++i) {
absa = z_abs(&AB(l+i,j));
sum += absa;
WORK(i) += absa;
/* L90: */
}
value = max(value,sum);
/* L100: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
if (*k > 0) {
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 2; j <= *n; ++j) {
/* Computing MIN */
i__3 = j - 1;
i__4 = min(i__3,*k);
/* Computing MAX */
i__2 = *k + 2 - j;
zlassq_(&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);
zlassq_(&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.) {
i__4 = l + j * ab_dim1;
absa = (d__1 = AB(l,j).r, abs(d__1));
if (scale < absa) {
/* Computing 2nd power */
d__1 = scale / absa;
sum = sum * (d__1 * d__1) + 1.;
scale = absa;
} else {
/* Computing 2nd power */
d__1 = absa / scale;
sum += d__1 * d__1;
}
}
/* L130: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of ZLANHB */
} /* zlanhb_ */
doublereal zlanhp_(char *norm, char *uplo, integer *n, doublecomplex *ap,
doublereal *work)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
ZLANHP 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
===========
ZLANHP returns the value
ZLANHP = ( 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 ZLANHP 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, ZLANHP is
set to zero.
AP (input) COMPLEX*16 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) DOUBLE PRECISION 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 i__1, i__2;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static doublereal absa;
static integer i, j, k;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal value;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
static doublereal sum;
#define WORK(I) work[(I)-1]
#define AP(I) ap[(I)-1]
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.;
if (lsame_(uplo, "U")) {
k = 0;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = k + j - 1;
for (i = k + 1; i <= k+j-1; ++i) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&AP(i));
value = max(d__1,d__2);
/* L10: */
}
k += j;
/* Computing MAX */
i__2 = k;
d__2 = value, d__3 = (d__1 = AP(k).r, abs(d__1));
value = max(d__2,d__3);
/* L20: */
}
} else {
k = 1;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
/* Computing MAX */
i__2 = k;
d__2 = value, d__3 = (d__1 = AP(k).r, abs(d__1));
value = max(d__2,d__3);
i__2 = k + *n - j;
for (i = k + 1; i <= k+*n-j; ++i) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&AP(i));
value = max(d__1,d__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.;
k = 1;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
sum = 0.;
i__2 = j - 1;
for (i = 1; i <= j-1; ++i) {
absa = z_abs(&AP(k));
sum += absa;
WORK(i) += absa;
++k;
/* L50: */
}
i__2 = k;
WORK(j) = sum + (d__1 = AP(k).r, abs(d__1));
++k;
/* L60: */
}
i__1 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
d__1 = value, d__2 = WORK(i);
value = max(d__1,d__2);
/* L70: */
}
} else {
i__1 = *n;
for (i = 1; i <= *n; ++i) {
WORK(i) = 0.;
/* L80: */
}
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = k;
sum = WORK(j) + (d__1 = AP(k).r, abs(d__1));
++k;
i__2 = *n;
for (i = j + 1; i <= *n; ++i) {
absa = z_abs(&AP(k));
sum += absa;
WORK(i) += absa;
++k;
/* L90: */
}
value = max(value,sum);
/* L100: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
k = 2;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 2; j <= *n; ++j) {
i__2 = j - 1;
zlassq_(&i__2, &AP(k), &c__1, &scale, &sum);
k += j;
/* L110: */
}
} else {
i__1 = *n - 1;
for (j = 1; j <= *n-1; ++j) {
i__2 = *n - j;
zlassq_(&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 <= *n; ++i) {
i__2 = k;
if (AP(k).r != 0.) {
i__2 = k;
absa = (d__1 = AP(k).r, abs(d__1));
if (scale < absa) {
/* Computing 2nd power */
d__1 = scale / absa;
sum = sum * (d__1 * d__1) + 1.;
scale = absa;
} else {
/* Computing 2nd power */
d__1 = absa / scale;
sum += d__1 * d__1;
}
}
if (lsame_(uplo, "U")) {
k = k + i + 1;
} else {
k = k + *n - i + 1;
}
/* L130: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of ZLANHP */
} /* zlanhp_ */
doublereal zlanht_(char *norm, integer *n, doublereal *d__, doublecomplex *e)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1992
Purpose
=======
ZLANHT returns the value of the one norm, or the Frobenius norm, or
the infinity norm, or the element of largest absolute value of a
complex Hermitian tridiagonal matrix A.
Description
===========
ZLANHT returns the value
ZLANHT = ( max(abs(A(i,j))), NORM = 'M' or 'm'
(
( norm1(A), NORM = '1', 'O' or 'o'
(
( normI(A), NORM = 'I' or 'i'
(
( normF(A), NORM = 'F', 'f', 'E' or 'e'
where norm1 denotes the one norm of a matrix (maximum column sum),
normI denotes the infinity norm of a matrix (maximum row sum) and
normF denotes the Frobenius norm of a matrix (square root of sum of
squares). Note that max(abs(A(i,j))) is not a matrix norm.
Arguments
=========
NORM (input) CHARACTER*1
Specifies the value to be returned in ZLANHT as described
above.
N (input) INTEGER
The order of the matrix A. N >= 0. When N = 0, ZLANHT is
set to zero.
D (input) DOUBLE PRECISION array, dimension (N)
The diagonal elements of A.
E (input) COMPLEX*16 array, dimension (N-1)
The (n-1) sub-diagonal or super-diagonal elements of A.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer i__1;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static integer i__;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal anorm;
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *), zlassq_(integer *, doublecomplex *,
integer *, doublereal *, doublereal *);
static doublereal sum;
--e;
--d__;
/* Function Body */
if (*n <= 0) {
anorm = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
anorm = (d__1 = d__[*n], abs(d__1));
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = d__[i__], abs(d__1));
anorm = max(d__2,d__3);
/* Computing MAX */
d__1 = anorm, d__2 = z_abs(&e[i__]);
anorm = max(d__1,d__2);
/* L10: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1' || lsame_(norm, "I")) {
/* Find norm1(A). */
if (*n == 1) {
anorm = abs(d__[1]);
} else {
/* Computing MAX */
d__2 = abs(d__[1]) + z_abs(&e[1]), d__3 = z_abs(&e[*n - 1]) + (
d__1 = d__[*n], abs(d__1));
anorm = max(d__2,d__3);
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = d__[i__], abs(d__1)) + z_abs(&e[
i__]) + z_abs(&e[i__ - 1]);
anorm = max(d__2,d__3);
/* L20: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
if (*n > 1) {
i__1 = *n - 1;
zlassq_(&i__1, &e[1], &c__1, &scale, &sum);
sum *= 2;
}
dlassq_(n, &d__[1], &c__1, &scale, &sum);
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of ZLANHT */
} /* zlanht_ */
double zlantb_(char *norm, char *uplo, char *diag, int *n, int *k,
doublecomplex *ab, int *ldab, double *work)
{
/* System generated locals */
int ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
double ret_val, d__1, d__2;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(double);
/* Local variables */
int i__, j, l;
double sum, scale;
int udiag;
extern int lsame_(char *, char *);
double value;
extern int zlassq_(int *, doublecomplex *, int *,
double *, double *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLANTB 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 */
/* =========== */
/* ZLANTB returns the value */
/* ZLANTB = ( 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 ZLANTB 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, ZLANTB 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*16 array, dimension (LDAB,N) */
/* The upper or lower triangular band matrix A, stored in the */
/* first k+1 rows of AB. The j-th column of A is stored */
/* in the j-th column of the array AB as follows: */
/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for MAX(1,j-k)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=MIN(n,j+k). */
/* Note that when DIAG = 'U', the elements of the array AB */
/* corresponding to the diagonal elements of the matrix A are */
/* not referenced, but are assumed to be one. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= K+1. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* ===================================================================== */
/* .. 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.;
} else if (lsame_(norm, "M")) {
/* Find MAX(ABS(A(i,j))). */
if (lsame_(diag, "U")) {
value = 1.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i__ = MAX(i__2,1); i__ <= i__3; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
value = MAX(d__1,d__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 */
d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
value = MAX(d__1,d__2);
/* L30: */
}
/* L40: */
}
}
} else {
value = 0.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__3 = *k + 2 - j;
i__2 = *k + 1;
for (i__ = MAX(i__3,1); i__ <= i__2; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
value = MAX(d__1,d__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 */
d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
value = MAX(d__1,d__2);
/* L70: */
}
/* L80: */
}
}
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.;
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i__ = MAX(i__2,1); i__ <= i__3; ++i__) {
sum += z_abs(&ab[i__ + j * ab_dim1]);
/* L90: */
}
} else {
sum = 0.;
/* Computing MAX */
i__3 = *k + 2 - j;
i__2 = *k + 1;
for (i__ = MAX(i__3,1); i__ <= i__2; ++i__) {
sum += z_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.;
/* 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 += z_abs(&ab[i__ + j * ab_dim1]);
/* L120: */
}
} else {
sum = 0.;
/* Computing MIN */
i__3 = *n + 1 - j, i__4 = *k + 1;
i__2 = MIN(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
sum += z_abs(&ab[i__ + j * ab_dim1]);
/* L130: */
}
}
value = MAX(value,sum);
/* L140: */
}
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
value = 0.;
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.;
/* L150: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = *k + 1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = MAX(i__2,i__3); i__ <= i__4; ++i__) {
work[i__] += z_abs(&ab[l + i__ + j * ab_dim1]);
/* L160: */
}
/* L170: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L180: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = *k + 1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j;
for (i__ = MAX(i__4,i__2); i__ <= i__3; ++i__) {
work[i__] += z_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.;
/* 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__] += z_abs(&ab[l + i__ + j * ab_dim1]);
/* L220: */
}
/* L230: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L240: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = MIN(i__4,i__2);
for (i__ = j; i__ <= i__3; ++i__) {
work[i__] += z_abs(&ab[l + i__ + j * ab_dim1]);
/* L250: */
}
/* L260: */
}
}
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = MAX(d__1,d__2);
/* L270: */
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
scale = 1.;
sum = (double) (*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;
zlassq_(&i__3, &ab[MAX(i__2, 1)+ j * ab_dim1], &c__1,
&scale, &sum);
/* L280: */
}
}
} else {
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__4 = j, i__2 = *k + 1;
i__3 = MIN(i__4,i__2);
/* Computing MAX */
i__5 = *k + 2 - j;
zlassq_(&i__3, &ab[MAX(i__5, 1)+ j * ab_dim1], &c__1, &
scale, &sum);
/* L290: */
}
}
} else {
if (lsame_(diag, "U")) {
scale = 1.;
sum = (double) (*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);
zlassq_(&i__3, &ab[j * ab_dim1 + 2], &c__1, &scale, &
sum);
/* L300: */
}
}
} else {
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__4 = *n - j + 1, i__2 = *k + 1;
i__3 = MIN(i__4,i__2);
zlassq_(&i__3, &ab[j * ab_dim1 + 1], &c__1, &scale, &sum);
/* L310: */
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of ZLANTB */
} /* zlantb_ */
/* Subroutine */ int zlatdf_(integer *ijob, integer *n, doublecomplex *z__,
integer *ldz, doublecomplex *rhs, doublereal *rdsum, doublereal *
rdscal, integer *ipiv, integer *jpiv)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
void z_sqrt(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, k;
doublecomplex bm, bp, xm[2], xp[2];
integer info;
doublecomplex temp, work[8];
doublereal scale;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
doublecomplex pmone;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
doublereal rtemp, sminu, rwork[2];
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
doublereal splus;
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zgesc2_(
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
integer *, doublereal *), zgecon_(char *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *);
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *), zlaswp_(integer *, doublecomplex *,
integer *, integer *, integer *, integer *, integer *);
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATDF computes the contribution to the reciprocal Dif-estimate */
/* by solving for x in Z * x = b, where b is chosen such that the norm */
/* of x is as large as possible. It is assumed that LU decomposition */
/* of Z has been computed by ZGETC2. On entry RHS = f holds the */
/* contribution from earlier solved sub-systems, and on return RHS = x. */
/* The factorization of Z returned by ZGETC2 has the form */
/* Z = P * L * U * Q, where P and Q are permutation matrices. L is lower */
/* triangular with unit diagonal elements and U is upper triangular. */
/* Arguments */
/* ========= */
/* IJOB (input) INTEGER */
/* IJOB = 2: First compute an approximative null-vector e */
/* of Z using ZGECON, e is normalized and solve for */
/* Zx = +-e - f with the sign giving the greater value of */
/* 2-norm(x). About 5 times as expensive as Default. */
/* IJOB .ne. 2: Local look ahead strategy where */
/* all entries of the r.h.s. b is choosen as either +1 or */
/* -1. Default. */
/* N (input) INTEGER */
/* The number of columns of the matrix Z. */
/* Z (input) DOUBLE PRECISION array, dimension (LDZ, N) */
/* On entry, the LU part of the factorization of the n-by-n */
/* matrix Z computed by ZGETC2: Z = P * L * U * Q */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDA >= max(1, N). */
/* RHS (input/output) DOUBLE PRECISION array, dimension (N). */
/* On entry, RHS contains contributions from other subsystems. */
/* On exit, RHS contains the solution of the subsystem with */
/* entries according to the value of IJOB (see above). */
/* RDSUM (input/output) DOUBLE PRECISION */
/* On entry, the sum of squares of computed contributions to */
/* the Dif-estimate under computation by ZTGSYL, where the */
/* scaling factor RDSCAL (see below) has been factored out. */
/* On exit, the corresponding sum of squares updated with the */
/* contributions from the current sub-system. */
/* If TRANS = 'T' RDSUM is not touched. */
/* NOTE: RDSUM only makes sense when ZTGSY2 is called by CTGSYL. */
/* RDSCAL (input/output) DOUBLE PRECISION */
/* On entry, scaling factor used to prevent overflow in RDSUM. */
/* On exit, RDSCAL is updated w.r.t. the current contributions */
/* in RDSUM. */
/* If TRANS = 'T', RDSCAL is not touched. */
/* NOTE: RDSCAL only makes sense when ZTGSY2 is called by */
/* ZTGSYL. */
/* IPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= i <= N, row i of the */
/* matrix has been interchanged with row IPIV(i). */
/* JPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= j <= N, column j of the */
/* matrix has been interchanged with column JPIV(j). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* This routine is a further developed implementation of algorithm */
/* BSOLVE in [1] using complete pivoting in the LU factorization. */
/* [1] Bo Kagstrom and Lars Westin, */
/* Generalized Schur Methods with Condition Estimators for */
/* Solving the Generalized Sylvester Equation, IEEE Transactions */
/* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. */
/* [2] Peter Poromaa, */
/* On Efficient and Robust Estimators for the Separation */
/* between two Regular Matrix Pairs with Applications in */
/* Condition Estimation. Report UMINF-95.05, Department of */
/* Computing Science, Umea University, S-901 87 Umea, Sweden, */
/* 1995. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--rhs;
--ipiv;
--jpiv;
/* Function Body */
if (*ijob != 2) {
/* Apply permutations IPIV to RHS */
i__1 = *n - 1;
zlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1);
/* Solve for L-part choosing RHS either to +1 or -1. */
z__1.r = -1., z__1.i = -0.;
pmone.r = z__1.r, pmone.i = z__1.i;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__1.r = rhs[i__2].r + 1., z__1.i = rhs[i__2].i + 0.;
bp.r = z__1.r, bp.i = z__1.i;
i__2 = j;
z__1.r = rhs[i__2].r - 1., z__1.i = rhs[i__2].i - 0.;
bm.r = z__1.r, bm.i = z__1.i;
splus = 1.;
/* Lockahead for L- part RHS(1:N-1) = +-1 */
/* SPLUS and SMIN computed more efficiently than in BSOLVE[1]. */
i__2 = *n - j;
zdotc_(&z__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &z__[j + 1
+ j * z_dim1], &c__1);
splus += z__1.r;
i__2 = *n - j;
zdotc_(&z__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
&c__1);
sminu = z__1.r;
i__2 = j;
splus *= rhs[i__2].r;
if (splus > sminu) {
i__2 = j;
rhs[i__2].r = bp.r, rhs[i__2].i = bp.i;
} else if (sminu > splus) {
i__2 = j;
rhs[i__2].r = bm.r, rhs[i__2].i = bm.i;
} else {
/* In this case the updating sums are equal and we can */
/* choose RHS(J) +1 or -1. The first time this happens we */
/* choose -1, thereafter +1. This is a simple way to get */
/* good estimates of matrices like Byers well-known example */
/* (see [1]). (Not done in BSOLVE.) */
i__2 = j;
i__3 = j;
z__1.r = rhs[i__3].r + pmone.r, z__1.i = rhs[i__3].i +
pmone.i;
rhs[i__2].r = z__1.r, rhs[i__2].i = z__1.i;
pmone.r = 1., pmone.i = 0.;
}
/* Compute the remaining r.h.s. */
i__2 = j;
z__1.r = -rhs[i__2].r, z__1.i = -rhs[i__2].i;
temp.r = z__1.r, temp.i = z__1.i;
i__2 = *n - j;
zaxpy_(&i__2, &temp, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
&c__1);
/* L10: */
}
/* Solve for U- part, lockahead for RHS(N) = +-1. This is not done */
/* In BSOLVE and will hopefully give us a better estimate because */
/* any ill-conditioning of the original matrix is transfered to U */
/* and not to L. U(N, N) is an approximation to sigma_min(LU). */
i__1 = *n - 1;
zcopy_(&i__1, &rhs[1], &c__1, work, &c__1);
i__1 = *n - 1;
i__2 = *n;
z__1.r = rhs[i__2].r + 1., z__1.i = rhs[i__2].i + 0.;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = *n;
i__2 = *n;
z__1.r = rhs[i__2].r - 1., z__1.i = rhs[i__2].i - 0.;
rhs[i__1].r = z__1.r, rhs[i__1].i = z__1.i;
splus = 0.;
sminu = 0.;
for (i__ = *n; i__ >= 1; --i__) {
z_div(&z__1, &c_b1, &z__[i__ + i__ * z_dim1]);
temp.r = z__1.r, temp.i = z__1.i;
i__1 = i__ - 1;
i__2 = i__ - 1;
z__1.r = work[i__2].r * temp.r - work[i__2].i * temp.i, z__1.i =
work[i__2].r * temp.i + work[i__2].i * temp.r;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = i__;
i__2 = i__;
z__1.r = rhs[i__2].r * temp.r - rhs[i__2].i * temp.i, z__1.i =
rhs[i__2].r * temp.i + rhs[i__2].i * temp.r;
rhs[i__1].r = z__1.r, rhs[i__1].i = z__1.i;
i__1 = *n;
for (k = i__ + 1; k <= i__1; ++k) {
i__2 = i__ - 1;
i__3 = i__ - 1;
i__4 = k - 1;
i__5 = i__ + k * z_dim1;
z__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, z__3.i =
z__[i__5].r * temp.i + z__[i__5].i * temp.r;
z__2.r = work[i__4].r * z__3.r - work[i__4].i * z__3.i,
z__2.i = work[i__4].r * z__3.i + work[i__4].i *
z__3.r;
z__1.r = work[i__3].r - z__2.r, z__1.i = work[i__3].i -
z__2.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
i__2 = i__;
i__3 = i__;
i__4 = k;
i__5 = i__ + k * z_dim1;
z__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, z__3.i =
z__[i__5].r * temp.i + z__[i__5].i * temp.r;
z__2.r = rhs[i__4].r * z__3.r - rhs[i__4].i * z__3.i, z__2.i =
rhs[i__4].r * z__3.i + rhs[i__4].i * z__3.r;
z__1.r = rhs[i__3].r - z__2.r, z__1.i = rhs[i__3].i - z__2.i;
rhs[i__2].r = z__1.r, rhs[i__2].i = z__1.i;
/* L20: */
}
splus += z_abs(&work[i__ - 1]);
sminu += z_abs(&rhs[i__]);
/* L30: */
}
if (splus > sminu) {
zcopy_(n, work, &c__1, &rhs[1], &c__1);
}
/* Apply the permutations JPIV to the computed solution (RHS) */
i__1 = *n - 1;
zlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1);
/* Compute the sum of squares */
zlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
return 0;
}
/* ENTRY IJOB = 2 */
/* Compute approximate nullvector XM of Z */
zgecon_("I", n, &z__[z_offset], ldz, &c_b24, &rtemp, work, rwork, &info);
zcopy_(n, &work[*n], &c__1, xm, &c__1);
/* Compute RHS */
i__1 = *n - 1;
zlaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1);
zdotc_(&z__3, n, xm, &c__1, xm, &c__1);
z_sqrt(&z__2, &z__3);
z_div(&z__1, &c_b1, &z__2);
temp.r = z__1.r, temp.i = z__1.i;
zscal_(n, &temp, xm, &c__1);
zcopy_(n, xm, &c__1, xp, &c__1);
zaxpy_(n, &c_b1, &rhs[1], &c__1, xp, &c__1);
z__1.r = -1., z__1.i = -0.;
zaxpy_(n, &z__1, xm, &c__1, &rhs[1], &c__1);
zgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &scale);
zgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &scale);
if (dzasum_(n, xp, &c__1) > dzasum_(n, &rhs[1], &c__1)) {
zcopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Compute the sum of squares */
zlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
return 0;
/* End of ZLATDF */
} /* zlatdf_ */
int ztgsen_(int *ijob, int *wantq, int *wantz,
int *select, int *n, doublecomplex *a, int *lda,
doublecomplex *b, int *ldb, doublecomplex *alpha, doublecomplex *
beta, doublecomplex *q, int *ldq, doublecomplex *z__, int *
ldz, int *m, double *pl, double *pr, double *dif,
doublecomplex *work, int *lwork, int *iwork, int *liwork,
int *info)
{
/* System generated locals */
int a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2, i__3;
doublecomplex z__1, z__2;
/* Builtin functions */
double sqrt(double), z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
int i__, k, n1, n2, ks, mn2, ijb, kase, ierr;
double dsum;
int swap;
doublecomplex temp1, temp2;
int isave[3];
extern int zscal_(int *, doublecomplex *,
doublecomplex *, int *);
int wantd;
int lwmin;
int wantp;
extern int zlacn2_(int *, doublecomplex *,
doublecomplex *, double *, int *, int *);
int wantd1, wantd2;
extern double dlamch_(char *);
double dscale, rdscal, safmin;
extern int xerbla_(char *, int *);
int liwmin;
extern int zlacpy_(char *, int *, int *,
doublecomplex *, int *, doublecomplex *, int *),
ztgexc_(int *, int *, int *, doublecomplex *, int
*, doublecomplex *, int *, doublecomplex *, int *,
doublecomplex *, int *, int *, int *, int *),
zlassq_(int *, doublecomplex *, int *, double *,
double *);
int lquery;
extern int ztgsyl_(char *, int *, int *, int
*, doublecomplex *, int *, doublecomplex *, int *,
doublecomplex *, int *, doublecomplex *, int *,
doublecomplex *, int *, doublecomplex *, int *,
double *, double *, doublecomplex *, int *, int *,
int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZTGSEN 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. */
/* ZTGSEN 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) int */
/* 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*16 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*16 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*16 array, dimension (N) */
/* BETA (output) COMPLEX*16 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*16 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*16 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 (output) DOUBLE PRECISION */
/* PR (output) DOUBLE PRECISION */
/* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the */
/* reciprocal of the norm of "projections" onto left and right */
/* 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) DOUBLE PRECISION array, dimension (2). */
/* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. */
/* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on */
/* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based */
/* estimates of Difu and Difl, computed using reversed */
/* communication with ZLACN2. */
/* 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*16 array, dimension (MAX(1,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 array, dimension (MAX(1,LIWORK)) */
/* IF IJOB = 0, IWORK is not referenced. Otherwise, */
/* on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. LIWORK >= 1. */
/* If IJOB = 1, 2 or 4, LIWORK >= N+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 */
/* =============== */
/* ZTGSEN 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 float 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 ZLATDF), then the parameter */
/* IDIFJB (see below) should be changed from 3 to 4 (routine ZLATDF */
/* (IJOB = 2 will be used)). See ZTGSYL for more details. */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* References */
/* ========== */
/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
/* Estimation: Theory, Algorithms and Software, Report */
/* UMINF - 94.04, Department of Computing Science, Umea University, */
/* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. */
/* To appear in Numerical Algorithms, 1996. */
/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
/* for Solving the Generalized Sylvester Equation and Estimating the */
/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
/* Department of Computing Science, Umea University, S-901 87 Umea, */
/* Sweden, December 1993, Revised April 1994, Also as LAPACK working */
/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */
/* 1996. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
--select;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alpha;
--beta;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--dif;
--work;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1 || *liwork == -1;
if (*ijob < 0 || *ijob > 5) {
*info = -1;
} else if (*n < 0) {
*info = -5;
} else if (*lda < MAX(1,*n)) {
*info = -7;
} else if (*ldb < MAX(1,*n)) {
*info = -9;
} else if (*ldq < 1 || *wantq && *ldq < *n) {
*info = -13;
} else if (*ldz < 1 || *wantz && *ldz < *n) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTGSEN", &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 = k + k * a_dim1;
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = k;
i__3 = k + k * b_dim1;
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 = (double) lwmin, work[1].i = 0.;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -21;
} else if (*liwork < liwmin && ! lquery) {
*info = -23;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTGSEN", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible. */
if (*m == *n || *m == 0) {
if (wantp) {
*pl = 1.;
*pr = 1.;
}
if (wantd) {
dscale = 0.;
dsum = 1.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
zlassq_(n, &a[i__ * a_dim1 + 1], &c__1, &dscale, &dsum);
zlassq_(n, &b[i__ * b_dim1 + 1], &c__1, &dscale, &dsum);
/* L20: */
}
dif[1] = dscale * sqrt(dsum);
dif[2] = dif[1];
}
goto L70;
}
/* Get machine constant */
safmin = dlamch_("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) {
ztgexc_(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.;
*pr = 0.;
}
if (wantd) {
dif[1] = 0.;
dif[2] = 0.;
}
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;
zlacpy_("Full", &n1, &n2, &a[i__ * a_dim1 + 1], lda, &work[1], &n1);
zlacpy_("Full", &n1, &n2, &b[i__ * b_dim1 + 1], ldb, &work[n1 * n2 +
1], &n1);
ijb = 0;
i__1 = *lwork - (n1 << 1) * n2;
ztgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * a_dim1]
, lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + i__ *
b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], &
work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr);
/* Estimate the reciprocal of norms of "projections" onto */
/* left and right eigenspaces */
rdscal = 0.;
dsum = 1.;
i__1 = n1 * n2;
zlassq_(&i__1, &work[1], &c__1, &rdscal, &dsum);
*pl = rdscal * sqrt(dsum);
if (*pl == 0.) {
*pl = 1.;
} else {
*pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl));
}
rdscal = 0.;
dsum = 1.;
i__1 = n1 * n2;
zlassq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum);
*pr = rdscal * sqrt(dsum);
if (*pr == 0.) {
*pr = 1.;
} else {
*pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr));
}
}
if (wantd) {
/* Compute estimates 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;
ztgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ *
a_dim1], lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ +
i__ * b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &
dif[1], &work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &
ierr);
/* Frobenius norm-based Difl estimate. */
i__1 = *lwork - (n1 << 1) * n2;
ztgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, &a[
a_offset], lda, &work[1], &n2, &b[i__ + i__ * b_dim1],
ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &dscale,
&dif[2], &work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &
ierr);
} else {
/* Compute 1-norm-based estimates of Difu and Difl using */
/* reversed communication with ZLACN2. 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:
zlacn2_(&mn2, &work[mn2 + 1], &work[1], &dif[1], &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation */
i__1 = *lwork - (n1 << 1) * n2;
ztgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
1], &n1, &dscale, &dif[1], &work[(n1 * n2 << 1) +
1], &i__1, &iwork[1], &ierr);
} else {
/* Solve the transposed variant. */
i__1 = *lwork - (n1 << 1) * n2;
ztgsyl_("C", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
1], &n1, &dscale, &dif[1], &work[(n1 * n2 << 1) +
1], &i__1, &iwork[1], &ierr);
}
goto L40;
}
dif[1] = dscale / dif[1];
/* 1-norm-based estimate of Difl. */
L50:
zlacn2_(&mn2, &work[mn2 + 1], &work[1], &dif[2], &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation */
i__1 = *lwork - (n1 << 1) * n2;
ztgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
&a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
1], &n2, &dscale, &dif[2], &work[(n1 * n2 << 1) +
1], &i__1, &iwork[1], &ierr);
} else {
/* Solve the transposed variant. */
i__1 = *lwork - (n1 << 1) * n2;
ztgsyl_("C", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
&a[a_offset], lda, &work[1], &n2, &b[b_offset],
ldb, &b[i__ + i__ * b_dim1], 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 float 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 = z_abs(&b[k + k * b_dim1]);
if (dscale > safmin) {
i__2 = k + k * b_dim1;
z__2.r = b[i__2].r / dscale, z__2.i = b[i__2].i / dscale;
d_cnjg(&z__1, &z__2);
temp1.r = z__1.r, temp1.i = z__1.i;
i__2 = k + k * b_dim1;
z__1.r = b[i__2].r / dscale, z__1.i = b[i__2].i / dscale;
temp2.r = z__1.r, temp2.i = z__1.i;
i__2 = k + k * b_dim1;
b[i__2].r = dscale, b[i__2].i = 0.;
i__2 = *n - k;
zscal_(&i__2, &temp1, &b[k + (k + 1) * b_dim1], ldb);
i__2 = *n - k + 1;
zscal_(&i__2, &temp1, &a[k + k * a_dim1], lda);
if (*wantq) {
zscal_(n, &temp2, &q[k * q_dim1 + 1], &c__1);
}
} else {
i__2 = k + k * b_dim1;
b[i__2].r = 0., b[i__2].i = 0.;
}
i__2 = k;
i__3 = k + k * a_dim1;
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = k;
i__3 = k + k * b_dim1;
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
/* L60: */
}
L70:
work[1].r = (double) lwmin, work[1].i = 0.;
iwork[1] = liwmin;
return 0;
/* End of ZTGSEN */
} /* ztgsen_ */
doublereal zlanhe_(char *norm, char *uplo, integer *n, doublecomplex *a,
integer *lda, doublereal *work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
integer i__, j;
doublereal sum, absa, scale;
extern logical lsame_(char *, char *);
doublereal value;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLANHE 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 */
/* =========== */
/* ZLANHE returns the value */
/* ZLANHE = ( 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 ZLANHE 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, ZLANHE is */
/* set to zero. */
/* A (input) COMPLEX*16 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) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
/* WORK is not referenced. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External 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.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
value = max(d__1,d__2);
/* L10: */
}
/* Computing MAX */
i__2 = j + j * a_dim1;
d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
value = max(d__2,d__3);
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j + j * a_dim1;
d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
value = max(d__2,d__3);
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
value = max(d__1,d__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.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
absa = z_abs(&a[i__ + j * a_dim1]);
sum += absa;
work[i__] += absa;
/* L50: */
}
i__2 = j + j * a_dim1;
work[j] = sum + (d__1 = a[i__2].r, abs(d__1));
/* L60: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L70: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L80: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * a_dim1;
sum = work[j] + (d__1 = a[i__2].r, abs(d__1));
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
absa = z_abs(&a[i__ + j * a_dim1]);
sum += absa;
work[i__] += absa;
/* L90: */
}
value = max(value,sum);
/* L100: */
}
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
zlassq_(&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;
zlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum);
/* L120: */
}
}
sum *= 2;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
if (a[i__2].r != 0.) {
i__2 = i__ + i__ * a_dim1;
absa = (d__1 = a[i__2].r, abs(d__1));
if (scale < absa) {
/* Computing 2nd power */
d__1 = scale / absa;
sum = sum * (d__1 * d__1) + 1.;
scale = absa;
} else {
/* Computing 2nd power */
d__1 = absa / scale;
sum += d__1 * d__1;
}
}
/* L130: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of ZLANHE */
} /* zlanhe_ */
doublereal zlangb_(char *norm, integer *n, integer *kl, integer *ku,
doublecomplex *ab, integer *ldab, doublereal *work)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
ZLANGB 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
===========
ZLANGB returns the value
ZLANGB = ( 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 ZLANGB as described
above.
N (input) INTEGER
The order of the matrix A. N >= 0. When N = 0, ZLANGB 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*16 array, dimension (LDAB,N)
The band matrix A, stored in rows 1 to KL+KU+1. The j-th
column of A is stored in the j-th column of the array AB as
follows:
AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KL+KU+1.
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK),
where LWORK >= N when NORM = 'I'; otherwise, WORK is not
referenced.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal ret_val, d__1, d__2;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static integer i__, j, k, l;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal value;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
static doublereal 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.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = *ku + 2 - j;
/* Computing MIN */
i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
i__3 = min(i__4,i__5);
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&ab_ref(i__, j));
value = max(d__1,d__2);
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
/* Computing MAX */
i__3 = *ku + 2 - j;
/* Computing MIN */
i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
i__2 = min(i__4,i__5);
for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
sum += z_abs(&ab_ref(i__, j));
/* L30: */
}
value = max(value,sum);
/* L40: */
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L50: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
k = *ku + 1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *ku;
/* Computing MIN */
i__5 = *n, i__6 = j + *kl;
i__4 = min(i__5,i__6);
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
work[i__] += z_abs(&ab_ref(k + i__, j));
/* L60: */
}
/* L70: */
}
value = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L80: */
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__4 = 1, i__2 = j - *ku;
l = max(i__4,i__2);
k = *ku + 1 - j + l;
/* Computing MIN */
i__2 = *n, i__3 = j + *kl;
i__4 = min(i__2,i__3) - l + 1;
zlassq_(&i__4, &ab_ref(k, j), &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of ZLANGB */
} /* zlangb_ */
/* ===================================================================== */
doublereal zlantb_(char *norm, char *uplo, char *diag, integer *n, integer *k, doublecomplex *ab, integer *ldab, doublereal *work)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
doublereal ret_val;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
integer i__, j, l;
doublereal sum, scale;
logical udiag;
extern logical lsame_(char *, char *);
doublereal value;
extern logical disnan_(doublereal *);
extern /* Subroutine */
int zlassq_(integer *, doublecomplex *, integer *, doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External 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.;
}
else if (lsame_(norm, "M"))
{
/* Find max(f2c_abs(A(i,j))). */
if (lsame_(diag, "U"))
{
value = 1.;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i__ = max(i__2,1);
i__ <= i__3;
++i__)
{
sum = z_abs(&ab[i__ + j * ab_dim1]);
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L10: */
}
/* L20: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
i__2 = *n + 1 - j;
i__4 = *k + 1; // , expr subst
i__3 = min(i__2,i__4);
for (i__ = 2;
i__ <= i__3;
++i__)
{
sum = z_abs(&ab[i__ + j * ab_dim1]);
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L30: */
}
/* L40: */
}
}
}
else
{
value = 0.;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MAX */
i__3 = *k + 2 - j;
i__2 = *k + 1;
for (i__ = max(i__3,1);
i__ <= i__2;
++i__)
{
sum = z_abs(&ab[i__ + j * ab_dim1]);
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L50: */
}
/* L60: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
i__3 = *n + 1 - j;
i__4 = *k + 1; // , expr subst
i__2 = min(i__3,i__4);
for (i__ = 1;
i__ <= i__2;
++i__)
{
sum = z_abs(&ab[i__ + j * ab_dim1]);
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L70: */
}
/* L80: */
}
}
}
}
else if (lsame_(norm, "O") || *(unsigned char *) norm == '1')
{
/* Find norm1(A). */
value = 0.;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (udiag)
{
sum = 1.;
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i__ = max(i__2,1);
i__ <= i__3;
++i__)
{
sum += z_abs(&ab[i__ + j * ab_dim1]);
/* L90: */
}
}
else
{
sum = 0.;
/* Computing MAX */
i__3 = *k + 2 - j;
i__2 = *k + 1;
for (i__ = max(i__3,1);
i__ <= i__2;
++i__)
{
sum += z_abs(&ab[i__ + j * ab_dim1]);
/* L100: */
}
}
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L110: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (udiag)
{
sum = 1.;
/* Computing MIN */
i__3 = *n + 1 - j;
i__4 = *k + 1; // , expr subst
i__2 = min(i__3,i__4);
for (i__ = 2;
i__ <= i__2;
++i__)
{
sum += z_abs(&ab[i__ + j * ab_dim1]);
/* L120: */
}
}
else
{
sum = 0.;
/* Computing MIN */
i__3 = *n + 1 - j;
i__4 = *k + 1; // , expr subst
i__2 = min(i__3,i__4);
for (i__ = 1;
i__ <= i__2;
++i__)
{
sum += z_abs(&ab[i__ + j * ab_dim1]);
/* L130: */
}
}
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L140: */
}
}
}
else if (lsame_(norm, "I"))
{
/* Find normI(A). */
value = 0.;
if (lsame_(uplo, "U"))
{
if (lsame_(diag, "U"))
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 1.;
/* L150: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
l = *k + 1 - j;
/* Computing MAX */
i__2 = 1;
i__3 = j - *k; // , expr subst
i__4 = j - 1;
for (i__ = max(i__2,i__3);
i__ <= i__4;
++i__)
{
work[i__] += z_abs(&ab[l + i__ + j * ab_dim1]);
/* L160: */
}
/* L170: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.;
/* L180: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
l = *k + 1 - j;
/* Computing MAX */
i__4 = 1;
i__2 = j - *k; // , expr subst
i__3 = j;
for (i__ = max(i__4,i__2);
i__ <= i__3;
++i__)
{
work[i__] += z_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.;
/* L210: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
l = 1 - j;
/* Computing MIN */
i__4 = *n;
i__2 = j + *k; // , expr subst
i__3 = min(i__4,i__2);
for (i__ = j + 1;
i__ <= i__3;
++i__)
{
work[i__] += z_abs(&ab[l + i__ + j * ab_dim1]);
/* L220: */
}
/* L230: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.;
/* L240: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
l = 1 - j;
/* Computing MIN */
i__4 = *n;
i__2 = j + *k; // , expr subst
i__3 = min(i__4,i__2);
for (i__ = j;
i__ <= i__3;
++i__)
{
work[i__] += z_abs(&ab[l + i__ + j * ab_dim1]);
/* L250: */
}
/* L260: */
}
}
}
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
sum = work[i__];
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L270: */
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
if (lsame_(uplo, "U"))
{
if (lsame_(diag, "U"))
{
scale = 1.;
sum = (doublereal) (*n);
if (*k > 0)
{
i__1 = *n;
for (j = 2;
j <= i__1;
++j)
{
/* Computing MIN */
i__4 = j - 1;
i__3 = min(i__4,*k);
/* Computing MAX */
i__2 = *k + 2 - j;
zlassq_(&i__3, &ab[max(i__2,1) + j * ab_dim1], &c__1, &scale, &sum);
/* L280: */
}
}
}
else
{
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
i__4 = j;
i__2 = *k + 1; // , expr subst
i__3 = min(i__4,i__2);
/* Computing MAX */
i__5 = *k + 2 - j;
zlassq_(&i__3, &ab[max(i__5,1) + j * ab_dim1], &c__1, & scale, &sum);
/* L290: */
}
}
}
else
{
if (lsame_(diag, "U"))
{
scale = 1.;
sum = (doublereal) (*n);
if (*k > 0)
{
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
i__4 = *n - j;
i__3 = min(i__4,*k);
zlassq_(&i__3, &ab[j * ab_dim1 + 2], &c__1, &scale, & sum);
/* L300: */
}
}
}
else
{
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
i__4 = *n - j + 1;
i__2 = *k + 1; // , expr subst
i__3 = min(i__4,i__2);
zlassq_(&i__3, &ab[j * ab_dim1 + 1], &c__1, &scale, &sum);
/* L310: */
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of ZLANTB */
}
doublereal zlanhs_(char *norm, integer *n, doublecomplex *a, integer *lda,
doublereal *work, ftnlen norm_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal ret_val, d__1, d__2;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static integer i__, j;
static doublereal sum, scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static doublereal value;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLANHS 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 */
/* =========== */
/* ZLANHS returns the value */
/* ZLANHS = ( 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 ZLANHS as described */
/* above. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, ZLANHS is */
/* set to zero. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The n by n upper Hessenberg matrix A; the part of A below the */
/* first sub-diagonal is not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(N,1). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), */
/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External 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.;
} else if (lsame_(norm, "M", (ftnlen)1, (ftnlen)1)) {
/* Find max(abs(A(i,j))). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
value = max(d__1,d__2);
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, "O", (ftnlen)1, (ftnlen)1) || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
sum += z_abs(&a[i__ + j * a_dim1]);
/* L30: */
}
value = max(value,sum);
/* L40: */
}
} else if (lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) {
/* Find normI(A). */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L50: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += z_abs(&a[i__ + j * a_dim1]);
/* L60: */
}
/* L70: */
}
value = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L80: */
}
} else if (lsame_(norm, "F", (ftnlen)1, (ftnlen)1) || lsame_(norm, "E", (
ftnlen)1, (ftnlen)1)) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of ZLANHS */
} /* zlanhs_ */
/* Subroutine */ int zsyequb_(char *uplo, integer *n, doublecomplex *a,
integer *lda, doublereal *s, doublereal *scond, doublereal *amax,
doublecomplex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag(doublecomplex *), sqrt(doublereal), log(doublereal), pow_di(
doublereal *, integer *);
/* Local variables */
doublereal d__;
integer i__, j;
doublereal t, u, c0, c1, c2, si;
logical up;
doublereal avg, std, tol, base;
integer iter;
doublereal smin, smax, scale;
extern logical lsame_(char *, char *);
doublereal sumsq;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal bignum, smlnum;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
/* -- 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 */
/* ======= */
/* ZSYEQUB 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*16 array, dimension (LDA,N) */
/* The N-by-N symmetric matrix whose scaling */
/* factors are to be computed. Only the diagonal elements of A */
/* are referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* S (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, S contains the scale factors for A. */
/* SCOND (output) DOUBLE PRECISION */
/* If INFO = 0, S contains the ratio of the smallest S(i) to */
/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
/* large nor too small, it is not worth scaling by S. */
/* AMAX (output) DOUBLE PRECISION */
/* Absolute value of largest matrix element. If AMAX is very */
/* close to overflow or very close to underflow, the matrix */
/* should be scaled. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
/* Further Details */
/* ======= ======= */
/* Reference: Livne, O.E. and Golub, G.H., "Scaling by Binormalization", */
/* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. */
/* DOI 10.1023/B:NUMA.0000016606.32820.69 */
/* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. 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_("ZSYEQUB", &i__1);
return 0;
}
up = lsame_(uplo, "U");
*amax = 0.;
/* Quick return if possible. */
if (*n == 0) {
*scond = 1.;
return 0;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
s[i__] = 0.;
}
*amax = 0.;
if (up) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = s[i__], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + j * a_dim1]), abs(d__2));
s[i__] = max(d__3,d__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = s[j], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + j * a_dim1]), abs(d__2));
s[j] = max(d__3,d__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = *amax, d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + j * a_dim1]), abs(d__2));
*amax = max(d__3,d__4);
}
/* Computing MAX */
i__2 = j + j * a_dim1;
d__3 = s[j], d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 =
d_imag(&a[j + j * a_dim1]), abs(d__2));
s[j] = max(d__3,d__4);
/* Computing MAX */
i__2 = j + j * a_dim1;
d__3 = *amax, d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 =
d_imag(&a[j + j * a_dim1]), abs(d__2));
*amax = max(d__3,d__4);
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j + j * a_dim1;
d__3 = s[j], d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 =
d_imag(&a[j + j * a_dim1]), abs(d__2));
s[j] = max(d__3,d__4);
/* Computing MAX */
i__2 = j + j * a_dim1;
d__3 = *amax, d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 =
d_imag(&a[j + j * a_dim1]), abs(d__2));
*amax = max(d__3,d__4);
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = s[i__], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + j * a_dim1]), abs(d__2));
s[i__] = max(d__3,d__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = s[j], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + j * a_dim1]), abs(d__2));
s[j] = max(d__3,d__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
d__3 = *amax, d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + j * a_dim1]), abs(d__2));
*amax = max(d__3,d__4);
}
}
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
s[j] = 1. / s[j];
}
tol = 1. / sqrt(*n * 2.);
for (iter = 1; iter <= 100; ++iter) {
scale = 0.;
sumsq = 0.;
/* beta = |A|s */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
work[i__2].r = 0., work[i__2].i = 0.;
}
if (up) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ j * a_dim1]), abs(d__2));
i__3 = i__;
i__4 = i__;
i__5 = i__ + j * a_dim1;
d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[
i__ + j * a_dim1]), abs(d__2))) * s[j];
z__1.r = work[i__4].r + d__3, z__1.i = work[i__4].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
i__3 = j;
i__4 = j;
i__5 = i__ + j * a_dim1;
d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[
i__ + j * a_dim1]), abs(d__2))) * s[i__];
z__1.r = work[i__4].r + d__3, z__1.i = work[i__4].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
}
i__2 = j;
i__3 = j;
i__4 = j + j * a_dim1;
d__3 = ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[j +
j * a_dim1]), abs(d__2))) * s[j];
z__1.r = work[i__3].r + d__3, z__1.i = work[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__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;
d__3 = ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[j +
j * a_dim1]), abs(d__2))) * s[j];
z__1.r = work[i__3].r + d__3, z__1.i = work[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ j * a_dim1]), abs(d__2));
i__3 = i__;
i__4 = i__;
i__5 = i__ + j * a_dim1;
d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[
i__ + j * a_dim1]), abs(d__2))) * s[j];
z__1.r = work[i__4].r + d__3, z__1.i = work[i__4].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
i__3 = j;
i__4 = j;
i__5 = i__ + j * a_dim1;
d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[
i__ + j * a_dim1]), abs(d__2))) * s[i__];
z__1.r = work[i__4].r + d__3, z__1.i = work[i__4].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
}
}
}
/* avg = s^T beta / n */
avg = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
z__2.r = s[i__2] * work[i__3].r, z__2.i = s[i__2] * work[i__3].i;
z__1.r = avg + z__2.r, z__1.i = z__2.i;
avg = z__1.r;
}
avg /= *n;
std = 0.;
i__1 = *n << 1;
for (i__ = *n + 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__ - *n;
i__4 = i__ - *n;
z__2.r = s[i__3] * work[i__4].r, z__2.i = s[i__3] * work[i__4].i;
z__1.r = z__2.r - avg, z__1.i = z__2.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
zlassq_(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 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + i__ *
a_dim1]), abs(d__2));
si = s[i__];
c2 = (*n - 1) * t;
i__2 = *n - 2;
i__3 = i__;
d__1 = t * si;
z__2.r = work[i__3].r - d__1, z__2.i = work[i__3].i;
d__2 = (doublereal) i__2;
z__1.r = d__2 * z__2.r, z__1.i = d__2 * z__2.i;
c1 = z__1.r;
d__1 = -(t * si) * si;
i__2 = i__;
d__2 = 2.;
z__4.r = d__2 * work[i__2].r, z__4.i = d__2 * work[i__2].i;
z__3.r = si * z__4.r, z__3.i = si * z__4.i;
z__2.r = d__1 + z__3.r, z__2.i = z__3.i;
d__3 = *n * avg;
z__1.r = z__2.r - d__3, z__1.i = z__2.i;
c0 = z__1.r;
d__ = c1 * c1 - c0 * 4 * c2;
if (d__ <= 0.) {
*info = -1;
return 0;
}
si = c0 * -2 / (c1 + sqrt(d__));
d__ = si - s[i__];
u = 0.;
if (up) {
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j +
i__ * a_dim1]), abs(d__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
d__1 = d__ * t;
z__1.r = work[i__4].r + d__1, z__1.i = work[i__4].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ j * a_dim1]), abs(d__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
d__1 = d__ * t;
z__1.r = work[i__4].r + d__1, z__1.i = work[i__4].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
}
} else {
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ j * a_dim1]), abs(d__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
d__1 = d__ * t;
z__1.r = work[i__4].r + d__1, z__1.i = work[i__4].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j +
i__ * a_dim1]), abs(d__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
d__1 = d__ * t;
z__1.r = work[i__4].r + d__1, z__1.i = work[i__4].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
}
}
i__2 = i__;
z__4.r = u + work[i__2].r, z__4.i = work[i__2].i;
z__3.r = d__ * z__4.r, z__3.i = d__ * z__4.i;
d__1 = (doublereal) (*n);
z__2.r = z__3.r / d__1, z__2.i = z__3.i / d__1;
z__1.r = avg + z__2.r, z__1.i = z__2.i;
avg = z__1.r;
s[i__] = si;
}
}
L999:
smlnum = dlamch_("SAFEMIN");
bignum = 1. / smlnum;
smin = bignum;
smax = 0.;
t = 1. / sqrt(avg);
base = dlamch_("B");
u = 1. / log(base);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = (integer) (u * log(s[i__] * t));
s[i__] = pow_di(&base, &i__2);
/* Computing MIN */
d__1 = smin, d__2 = s[i__];
smin = min(d__1,d__2);
/* Computing MAX */
d__1 = smax, d__2 = s[i__];
smax = max(d__1,d__2);
}
*scond = max(smin,smlnum) / min(smax,bignum);
return 0;
} /* zsyequb_ */
doublereal zlanhs_(char *norm, integer *n, doublecomplex *a, integer *lda,
doublereal *work)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
ZLANHS 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
===========
ZLANHS returns the value
ZLANHS = ( 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 ZLANHS as described
above.
N (input) INTEGER
The order of the matrix A. N >= 0. When N = 0, ZLANHS is
set to zero.
A (input) COMPLEX*16 array, dimension (LDA,N)
The n by n upper Hessenberg matrix A; the part of A below the
first sub-diagonal is not referenced.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(N,1).
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK),
where LWORK >= N when NORM = 'I'; otherwise, WORK is not
referenced.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal ret_val, d__1, d__2;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static integer i, j;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal value;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
static doublereal sum;
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
value = 0.;
i__1 = *n;
for (j = 1; j <= *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 */
d__1 = value, d__2 = z_abs(&A(i,j));
value = max(d__1,d__2);
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, "O") || *(unsigned char *)norm == '1') {
/* Find norm1(A). */
value = 0.;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
sum = 0.;
/* 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 += z_abs(&A(i,j));
/* L30: */
}
value = max(value,sum);
/* L40: */
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
i__1 = *n;
for (i = 1; i <= *n; ++i) {
WORK(i) = 0.;
/* 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) += z_abs(&A(i,j));
/* L60: */
}
/* L70: */
}
value = 0.;
i__1 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
d__1 = value, d__2 = WORK(i);
value = max(d__1,d__2);
/* L80: */
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
zlassq_(&i__2, &A(1,j), &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of ZLANHS */
} /* zlanhs_ */
doublereal zlantb_(char *norm, char *uplo, char *diag, integer *n, integer *k,
doublecomplex *ab, integer *ldab, doublereal *work)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
ZLANTB 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
===========
ZLANTB returns the value
ZLANTB = ( 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 ZLANTB 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, ZLANTB 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*16 array, dimension (LDAB,N)
The upper or lower triangular band matrix A, stored in the
first k+1 rows of AB. The j-th column of A is stored
in the j-th column of the array AB as follows:
if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).
Note that when DIAG = 'U', the elements of the array AB
corresponding to the diagonal elements of the matrix A are
not referenced, but are assumed to be one.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= K+1.
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK),
where LWORK >= N when NORM = 'I'; otherwise, WORK is not
referenced.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
doublereal ret_val, d__1, d__2;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static integer i__, j, l;
static doublereal scale;
static logical udiag;
extern logical lsame_(char *, char *);
static doublereal value;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
static doublereal 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.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
if (lsame_(diag, "U")) {
value = 1.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&ab_ref(i__, j));
value = max(d__1,d__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 */
d__1 = value, d__2 = z_abs(&ab_ref(i__, j));
value = max(d__1,d__2);
/* L30: */
}
/* L40: */
}
}
} else {
value = 0.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__3 = *k + 2 - j;
i__2 = *k + 1;
for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&ab_ref(i__, j));
value = max(d__1,d__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 */
d__1 = value, d__2 = z_abs(&ab_ref(i__, j));
value = max(d__1,d__2);
/* L70: */
}
/* L80: */
}
}
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.;
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
sum += z_abs(&ab_ref(i__, j));
/* L90: */
}
} else {
sum = 0.;
/* Computing MAX */
i__3 = *k + 2 - j;
i__2 = *k + 1;
for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
sum += z_abs(&ab_ref(i__, j));
/* L100: */
}
}
value = max(value,sum);
/* L110: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.;
/* Computing MIN */
i__3 = *n + 1 - j, i__4 = *k + 1;
i__2 = min(i__3,i__4);
for (i__ = 2; i__ <= i__2; ++i__) {
sum += z_abs(&ab_ref(i__, j));
/* L120: */
}
} else {
sum = 0.;
/* Computing MIN */
i__3 = *n + 1 - j, i__4 = *k + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
sum += z_abs(&ab_ref(i__, j));
/* L130: */
}
}
value = max(value,sum);
/* L140: */
}
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
value = 0.;
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.;
/* L150: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = *k + 1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
work[i__] += z_abs(&ab_ref(l + i__, j));
/* L160: */
}
/* L170: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L180: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = *k + 1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
work[i__] += z_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.;
/* 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__] += z_abs(&ab_ref(l + i__, j));
/* L220: */
}
/* L230: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L240: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2);
for (i__ = j; i__ <= i__3; ++i__) {
work[i__] += z_abs(&ab_ref(l + i__, j));
/* L250: */
}
/* L260: */
}
}
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L270: */
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
scale = 1.;
sum = (doublereal) (*n);
if (*k > 0) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing MAX */
i__3 = *k + 2 - j;
/* Computing MIN */
i__2 = j - 1;
i__4 = min(i__2,*k);
zlassq_(&i__4, &ab_ref(max(i__3,1), j), &c__1, &scale,
&sum);
/* L280: */
}
}
} else {
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__3 = *k + 2 - j;
/* Computing MIN */
i__2 = j, i__5 = *k + 1;
i__4 = min(i__2,i__5);
zlassq_(&i__4, &ab_ref(max(i__3,1), j), &c__1, &scale, &
sum);
/* L290: */
}
}
} else {
if (lsame_(diag, "U")) {
scale = 1.;
sum = (doublereal) (*n);
if (*k > 0) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__4 = *n - j;
i__3 = min(i__4,*k);
zlassq_(&i__3, &ab_ref(2, j), &c__1, &scale, &sum);
/* L300: */
}
}
} else {
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__4 = *n - j + 1, i__2 = *k + 1;
i__3 = min(i__4,i__2);
zlassq_(&i__3, &ab_ref(1, j), &c__1, &scale, &sum);
/* L310: */
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of ZLANTB */
} /* zlantb_ */
doublereal zlantp_(char *norm, char *uplo, char *diag, integer *n,
doublecomplex *ap, doublereal *work)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
ZLANTP 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
===========
ZLANTP returns the value
ZLANTP = ( 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 ZLANTP 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, ZLANTP is
set to zero.
AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
The upper or lower triangular matrix A, packed columnwise in
a linear array. The j-th column of A is stored in the array
AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
Note that when DIAG = 'U', the elements of the array AP
corresponding to the diagonal elements of the matrix A are
not referenced, but are assumed to be one.
WORK (workspace) DOUBLE PRECISION array, dimension (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 i__1, i__2;
doublereal ret_val, d__1, d__2;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
static integer i__, j, k;
static doublereal scale;
static logical udiag;
extern logical lsame_(char *, char *);
static doublereal value;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
static doublereal sum;
--work;
--ap;
/* Function Body */
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
k = 1;
if (lsame_(diag, "U")) {
value = 1.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j - 2;
for (i__ = k; i__ <= i__2; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&ap[i__]);
value = max(d__1,d__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 */
d__1 = value, d__2 = z_abs(&ap[i__]);
value = max(d__1,d__2);
/* L30: */
}
k = k + *n - j + 1;
/* L40: */
}
}
} else {
value = 0.;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j - 1;
for (i__ = k; i__ <= i__2; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = z_abs(&ap[i__]);
value = max(d__1,d__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 */
d__1 = value, d__2 = z_abs(&ap[i__]);
value = max(d__1,d__2);
/* L70: */
}
k = k + *n - j + 1;
/* L80: */
}
}
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.;
k = 1;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.;
i__2 = k + j - 2;
for (i__ = k; i__ <= i__2; ++i__) {
sum += z_abs(&ap[i__]);
/* L90: */
}
} else {
sum = 0.;
i__2 = k + j - 1;
for (i__ = k; i__ <= i__2; ++i__) {
sum += z_abs(&ap[i__]);
/* L100: */
}
}
k += j;
value = max(value,sum);
/* L110: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.;
i__2 = k + *n - j;
for (i__ = k + 1; i__ <= i__2; ++i__) {
sum += z_abs(&ap[i__]);
/* L120: */
}
} else {
sum = 0.;
i__2 = k + *n - j;
for (i__ = k; i__ <= i__2; ++i__) {
sum += z_abs(&ap[i__]);
/* L130: */
}
}
k = k + *n - j + 1;
value = max(value,sum);
/* L140: */
}
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
k = 1;
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.;
/* L150: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += z_abs(&ap[k]);
++k;
/* L160: */
}
++k;
/* L170: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L180: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += z_abs(&ap[k]);
++k;
/* L190: */
}
/* L200: */
}
}
} else {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.;
/* L210: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
++k;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work[i__] += z_abs(&ap[k]);
++k;
/* L220: */
}
/* L230: */
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L240: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
work[i__] += z_abs(&ap[k]);
++k;
/* L250: */
}
/* L260: */
}
}
}
value = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L270: */
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
scale = 1.;
sum = (doublereal) (*n);
k = 2;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
zlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k += j;
/* L280: */
}
} else {
scale = 0.;
sum = 1.;
k = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
zlassq_(&j, &ap[k], &c__1, &scale, &sum);
k += j;
/* L290: */
}
}
} else {
if (lsame_(diag, "U")) {
scale = 1.;
sum = (doublereal) (*n);
k = 2;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
zlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k = k + *n - j + 1;
/* L300: */
}
} else {
scale = 0.;
sum = 1.;
k = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
zlassq_(&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 ZLANTP */
} /* zlantp_ */