/* Subroutine */ int zzlgin_(real *xt, real *pwrten, integer *nlog)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
double r_lg10(real *), pow_ri(real *, integer *);
/* Local variables */
static integer nl;
static real xl;
/* Return PWRTEN and NTEN such that */
/* PWRTEN .LE. XT .LT. 10*PWRTEN AND PWRTEN = 10**NLOG */
/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*/
xl = r_lg10(xt) + 1e-5f;
/* Computing MAX */
i__1 = (integer) xl;
nl = max(i__1,-36);
if (xl < 0.f) {
--nl;
}
*pwrten = pow_ri(&c_b2, &nl);
*nlog = nl;
return 0;
} /* zzlgin_ */
/* Subroutine */ int slabad_(real *small, real *large)
{
/* -- 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
=======
SLABAD takes as input the values computed by SLAMCH for underflow and
overflow, and returns the square root of each of these values if the
log of LARGE is sufficiently large. This subroutine is intended to
identify machines with a large exponent range, such as the Crays, and
redefine the underflow and overflow limits to be the square roots of
the values computed by SLAMCH. This subroutine is needed because
SLAMCH does not compensate for poor arithmetic in the upper half of
the exponent range, as is found on a Cray.
Arguments
=========
SMALL (input/output) REAL
On entry, the underflow threshold as computed by SLAMCH.
On exit, if LOG10(LARGE) is sufficiently large, the square
root of SMALL, otherwise unchanged.
LARGE (input/output) REAL
On entry, the overflow threshold as computed by SLAMCH.
On exit, if LOG10(LARGE) is sufficiently large, the square
root of LARGE, otherwise unchanged.
=====================================================================
If it looks like we're on a Cray, take the square root of
SMALL and LARGE to avoid overflow and underflow problems. */
/* Builtin functions */
double r_lg10(real *), sqrt(doublereal);
if (r_lg10(large) > 2e3f) {
*small = sqrt(*small);
*large = sqrt(*large);
}
return 0;
/* End of SLABAD */
} /* slabad_ */
int slabad_(float *small, float *large)
{
/* Builtin functions */
double r_lg10(float *), sqrt(double);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLABAD takes as input the values computed by SLAMCH for underflow and */
/* overflow, and returns the square root of each of these values if the */
/* log of LARGE is sufficiently large. This subroutine is intended to */
/* identify machines with a large exponent range, such as the Crays, and */
/* redefine the underflow and overflow limits to be the square roots of */
/* the values computed by SLAMCH. This subroutine is needed because */
/* SLAMCH does not compensate for poor arithmetic in the upper half of */
/* the exponent range, as is found on a Cray. */
/* Arguments */
/* ========= */
/* SMALL (input/output) REAL */
/* On entry, the underflow threshold as computed by SLAMCH. */
/* On exit, if LOG10(LARGE) is sufficiently large, the square */
/* root of SMALL, otherwise unchanged. */
/* LARGE (input/output) REAL */
/* On entry, the overflow threshold as computed by SLAMCH. */
/* On exit, if LOG10(LARGE) is sufficiently large, the square */
/* root of LARGE, otherwise unchanged. */
/* ===================================================================== */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* If it looks like we're on a Cray, take the square root of */
/* SMALL and LARGE to avoid overflow and underflow problems. */
if (r_lg10(large) > 2e3f) {
*small = sqrt(*small);
*large = sqrt(*large);
}
return 0;
/* End of SLABAD */
} /* slabad_ */
int cggbal_(char *job, int *n, complex *a, int *lda,
complex *b, int *ldb, int *ilo, int *ihi, float *lscale,
float *rscale, float *work, int *info)
{
/* System generated locals */
int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
float r__1, r__2, r__3;
/* Builtin functions */
double r_lg10(float *), r_imag(complex *), c_abs(complex *), r_sign(float *,
float *), pow_ri(float *, int *);
/* Local variables */
int i__, j, k, l, m;
float t;
int jc;
float ta, tb, tc;
int ir;
float ew;
int it, nr, ip1, jp1, lm1;
float cab, rab, ewc, cor, sum;
int nrp2, icab, lcab;
float beta, coef;
int irab, lrab;
float basl, cmax;
extern double sdot_(int *, float *, int *, float *, int *);
float coef2, coef5, gamma, alpha;
extern int lsame_(char *, char *);
extern int sscal_(int *, float *, float *, int *);
float sfmin;
extern int cswap_(int *, complex *, int *,
complex *, int *);
float sfmax;
int iflow, kount;
extern int saxpy_(int *, float *, float *, int *,
float *, int *);
float pgamma;
extern int icamax_(int *, complex *, int *);
extern double slamch_(char *);
extern int csscal_(int *, float *, complex *, int
*), xerbla_(char *, int *);
int lsfmin, lsfmax;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGGBAL balances a pair of general complex matrices (A,B). This */
/* involves, first, permuting A and B by similarity transformations to */
/* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N */
/* elements on the diagonal; and second, applying a diagonal similarity */
/* transformation to rows and columns ILO to IHI to make the rows */
/* and columns as close in norm as possible. Both steps are optional. */
/* Balancing may reduce the 1-norm of the matrices, and improve the */
/* accuracy of the computed eigenvalues and/or eigenvectors in the */
/* generalized eigenvalue problem A*x = lambda*B*x. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the operations to be performed on A and B: */
/* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 */
/* and RSCALE(I) = 1.0 for i=1,...,N; */
/* = 'P': permute only; */
/* = 'S': scale only; */
/* = 'B': both permute and scale. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the input matrix A. */
/* On exit, A is overwritten by the balanced matrix. */
/* If JOB = 'N', A is not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* B (input/output) COMPLEX array, dimension (LDB,N) */
/* On entry, the input matrix B. */
/* On exit, B is overwritten by the balanced matrix. */
/* If JOB = 'N', B is not referenced. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are set to ints such that on exit */
/* A(i,j) = 0 and B(i,j) = 0 if i > j and */
/* j = 1,...,ILO-1 or i = IHI+1,...,N. */
/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */
/* LSCALE (output) REAL array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* to the left side of A and B. If P(j) is the index of the */
/* row interchanged with row j, and D(j) is the scaling factor */
/* applied to row j, then */
/* LSCALE(j) = P(j) for J = 1,...,ILO-1 */
/* = D(j) for J = ILO,...,IHI */
/* = P(j) for J = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* RSCALE (output) REAL array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* to the right side of A and B. If P(j) is the index of the */
/* column interchanged with column j, and D(j) is the scaling */
/* factor applied to column j, then */
/* RSCALE(j) = P(j) for J = 1,...,ILO-1 */
/* = D(j) for J = ILO,...,IHI */
/* = P(j) for J = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* WORK (workspace) REAL array, dimension (lwork) */
/* lwork must be at least MAX(1,6*N) when JOB = 'S' or 'B', and */
/* at least 1 when JOB = 'N' or 'P'. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* See R.C. WARD, Balancing the generalized eigenvalue problem, */
/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--lscale;
--rscale;
--work;
/* Function Body */
*info = 0;
if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
&& ! lsame_(job, "B")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < MAX(1,*n)) {
*info = -4;
} else if (*ldb < MAX(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGGBAL", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*ilo = 1;
*ihi = *n;
return 0;
}
if (*n == 1) {
*ilo = 1;
*ihi = *n;
lscale[1] = 1.f;
rscale[1] = 1.f;
return 0;
}
if (lsame_(job, "N")) {
*ilo = 1;
*ihi = *n;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
lscale[i__] = 1.f;
rscale[i__] = 1.f;
/* L10: */
}
return 0;
}
k = 1;
l = *n;
if (lsame_(job, "S")) {
goto L190;
}
goto L30;
/* Permute the matrices A and B to isolate the eigenvalues. */
/* Find row with one nonzero in columns 1 through L */
L20:
l = lm1;
if (l != 1) {
goto L30;
}
rscale[1] = 1.f;
lscale[1] = 1.f;
goto L190;
L30:
lm1 = l - 1;
for (i__ = l; i__ >= 1; --i__) {
i__1 = lm1;
for (j = 1; j <= i__1; ++j) {
jp1 = j + 1;
i__2 = i__ + j * a_dim1;
i__3 = i__ + j * b_dim1;
if (a[i__2].r != 0.f || a[i__2].i != 0.f || (b[i__3].r != 0.f ||
b[i__3].i != 0.f)) {
goto L50;
}
/* L40: */
}
j = l;
goto L70;
L50:
i__1 = l;
for (j = jp1; j <= i__1; ++j) {
i__2 = i__ + j * a_dim1;
i__3 = i__ + j * b_dim1;
if (a[i__2].r != 0.f || a[i__2].i != 0.f || (b[i__3].r != 0.f ||
b[i__3].i != 0.f)) {
goto L80;
}
/* L60: */
}
j = jp1 - 1;
L70:
m = l;
iflow = 1;
goto L160;
L80:
;
}
goto L100;
/* Find column with one nonzero in rows K through N */
L90:
++k;
L100:
i__1 = l;
for (j = k; j <= i__1; ++j) {
i__2 = lm1;
for (i__ = k; i__ <= i__2; ++i__) {
ip1 = i__ + 1;
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * b_dim1;
if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r != 0.f ||
b[i__4].i != 0.f)) {
goto L120;
}
/* L110: */
}
i__ = l;
goto L140;
L120:
i__2 = l;
for (i__ = ip1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * b_dim1;
if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r != 0.f ||
b[i__4].i != 0.f)) {
goto L150;
}
/* L130: */
}
i__ = ip1 - 1;
L140:
m = k;
iflow = 2;
goto L160;
L150:
;
}
goto L190;
/* Permute rows M and I */
L160:
lscale[m] = (float) i__;
if (i__ == m) {
goto L170;
}
i__1 = *n - k + 1;
cswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[m + k * a_dim1], lda);
i__1 = *n - k + 1;
cswap_(&i__1, &b[i__ + k * b_dim1], ldb, &b[m + k * b_dim1], ldb);
/* Permute columns M and J */
L170:
rscale[m] = (float) j;
if (j == m) {
goto L180;
}
cswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
cswap_(&l, &b[j * b_dim1 + 1], &c__1, &b[m * b_dim1 + 1], &c__1);
L180:
switch (iflow) {
case 1: goto L20;
case 2: goto L90;
}
L190:
*ilo = k;
*ihi = l;
if (lsame_(job, "P")) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
lscale[i__] = 1.f;
rscale[i__] = 1.f;
/* L195: */
}
return 0;
}
if (*ilo == *ihi) {
return 0;
}
/* Balance the submatrix in rows ILO to IHI. */
nr = *ihi - *ilo + 1;
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
rscale[i__] = 0.f;
lscale[i__] = 0.f;
work[i__] = 0.f;
work[i__ + *n] = 0.f;
work[i__ + (*n << 1)] = 0.f;
work[i__ + *n * 3] = 0.f;
work[i__ + (*n << 2)] = 0.f;
work[i__ + *n * 5] = 0.f;
/* L200: */
}
/* Compute right side vector in resulting linear equations */
basl = r_lg10(&c_b36);
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *ihi;
for (j = *ilo; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
if (a[i__3].r == 0.f && a[i__3].i == 0.f) {
ta = 0.f;
goto L210;
}
i__3 = i__ + j * a_dim1;
r__3 = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 = r_imag(&a[i__ + j
* a_dim1]), ABS(r__2));
ta = r_lg10(&r__3) / basl;
L210:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0.f && b[i__3].i == 0.f) {
tb = 0.f;
goto L220;
}
i__3 = i__ + j * b_dim1;
r__3 = (r__1 = b[i__3].r, ABS(r__1)) + (r__2 = r_imag(&b[i__ + j
* b_dim1]), ABS(r__2));
tb = r_lg10(&r__3) / basl;
L220:
work[i__ + (*n << 2)] = work[i__ + (*n << 2)] - ta - tb;
work[j + *n * 5] = work[j + *n * 5] - ta - tb;
/* L230: */
}
/* L240: */
}
coef = 1.f / (float) (nr << 1);
coef2 = coef * coef;
coef5 = coef2 * .5f;
nrp2 = nr + 2;
beta = 0.f;
it = 1;
/* Start generalized conjugate gradient iteration */
L250:
gamma = sdot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)]
, &c__1) + sdot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + *
n * 5], &c__1);
ew = 0.f;
ewc = 0.f;
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
ew += work[i__ + (*n << 2)];
ewc += work[i__ + *n * 5];
/* L260: */
}
/* Computing 2nd power */
r__1 = ew;
/* Computing 2nd power */
r__2 = ewc;
/* Computing 2nd power */
r__3 = ew - ewc;
gamma = coef * gamma - coef2 * (r__1 * r__1 + r__2 * r__2) - coef5 * (
r__3 * r__3);
if (gamma == 0.f) {
goto L350;
}
if (it != 1) {
beta = gamma / pgamma;
}
t = coef5 * (ewc - ew * 3.f);
tc = coef5 * (ew - ewc * 3.f);
sscal_(&nr, &beta, &work[*ilo], &c__1);
sscal_(&nr, &beta, &work[*ilo + *n], &c__1);
saxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], &
c__1);
saxpy_(&nr, &coef, &work[*ilo + *n * 5], &c__1, &work[*ilo], &c__1);
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
work[i__] += tc;
work[i__ + *n] += t;
/* L270: */
}
/* Apply matrix to vector */
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
kount = 0;
sum = 0.f;
i__2 = *ihi;
for (j = *ilo; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
if (a[i__3].r == 0.f && a[i__3].i == 0.f) {
goto L280;
}
++kount;
sum += work[j];
L280:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0.f && b[i__3].i == 0.f) {
goto L290;
}
++kount;
sum += work[j];
L290:
;
}
work[i__ + (*n << 1)] = (float) kount * work[i__ + *n] + sum;
/* L300: */
}
i__1 = *ihi;
for (j = *ilo; j <= i__1; ++j) {
kount = 0;
sum = 0.f;
i__2 = *ihi;
for (i__ = *ilo; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
if (a[i__3].r == 0.f && a[i__3].i == 0.f) {
goto L310;
}
++kount;
sum += work[i__ + *n];
L310:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0.f && b[i__3].i == 0.f) {
goto L320;
}
++kount;
sum += work[i__ + *n];
L320:
;
}
work[j + *n * 3] = (float) kount * work[j] + sum;
/* L330: */
}
sum = sdot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1)
+ sdot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1);
alpha = gamma / sum;
/* Determine correction to current iteration */
cmax = 0.f;
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
cor = alpha * work[i__ + *n];
if (ABS(cor) > cmax) {
cmax = ABS(cor);
}
lscale[i__] += cor;
cor = alpha * work[i__];
if (ABS(cor) > cmax) {
cmax = ABS(cor);
}
rscale[i__] += cor;
/* L340: */
}
if (cmax < .5f) {
goto L350;
}
r__1 = -alpha;
saxpy_(&nr, &r__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)]
, &c__1);
r__1 = -alpha;
saxpy_(&nr, &r__1, &work[*ilo + *n * 3], &c__1, &work[*ilo + *n * 5], &
c__1);
pgamma = gamma;
++it;
if (it <= nrp2) {
goto L250;
}
/* End generalized conjugate gradient iteration */
L350:
sfmin = slamch_("S");
sfmax = 1.f / sfmin;
lsfmin = (int) (r_lg10(&sfmin) / basl + 1.f);
lsfmax = (int) (r_lg10(&sfmax) / basl);
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *n - *ilo + 1;
irab = icamax_(&i__2, &a[i__ + *ilo * a_dim1], lda);
rab = c_abs(&a[i__ + (irab + *ilo - 1) * a_dim1]);
i__2 = *n - *ilo + 1;
irab = icamax_(&i__2, &b[i__ + *ilo * b_dim1], ldb);
/* Computing MAX */
r__1 = rab, r__2 = c_abs(&b[i__ + (irab + *ilo - 1) * b_dim1]);
rab = MAX(r__1,r__2);
r__1 = rab + sfmin;
lrab = (int) (r_lg10(&r__1) / basl + 1.f);
ir = lscale[i__] + r_sign(&c_b72, &lscale[i__]);
/* Computing MIN */
i__2 = MAX(ir,lsfmin), i__2 = MIN(i__2,lsfmax), i__3 = lsfmax - lrab;
ir = MIN(i__2,i__3);
lscale[i__] = pow_ri(&c_b36, &ir);
icab = icamax_(ihi, &a[i__ * a_dim1 + 1], &c__1);
cab = c_abs(&a[icab + i__ * a_dim1]);
icab = icamax_(ihi, &b[i__ * b_dim1 + 1], &c__1);
/* Computing MAX */
r__1 = cab, r__2 = c_abs(&b[icab + i__ * b_dim1]);
cab = MAX(r__1,r__2);
r__1 = cab + sfmin;
lcab = (int) (r_lg10(&r__1) / basl + 1.f);
jc = rscale[i__] + r_sign(&c_b72, &rscale[i__]);
/* Computing MIN */
i__2 = MAX(jc,lsfmin), i__2 = MIN(i__2,lsfmax), i__3 = lsfmax - lcab;
jc = MIN(i__2,i__3);
rscale[i__] = pow_ri(&c_b36, &jc);
/* L360: */
}
/* Row scaling of matrices A and B */
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *n - *ilo + 1;
csscal_(&i__2, &lscale[i__], &a[i__ + *ilo * a_dim1], lda);
i__2 = *n - *ilo + 1;
csscal_(&i__2, &lscale[i__], &b[i__ + *ilo * b_dim1], ldb);
/* L370: */
}
/* Column scaling of matrices A and B */
i__1 = *ihi;
for (j = *ilo; j <= i__1; ++j) {
csscal_(ihi, &rscale[j], &a[j * a_dim1 + 1], &c__1);
csscal_(ihi, &rscale[j], &b[j * b_dim1 + 1], &c__1);
/* L380: */
}
return 0;
/* End of CGGBAL */
} /* cggbal_ */
/* DECK SGEIR */
/* Subroutine */ int sgeir_(real *a, integer *lda, integer *n, real *v,
integer *itask, integer *ind, real *work, integer *iwork)
{
/* System generated locals */
address a__1[4], a__2[3];
integer a_dim1, a_offset, work_dim1, work_offset, i__1[4], i__2[3], i__3;
real r__1, r__2, r__3;
char ch__1[40], ch__2[27], ch__3[31];
/* Local variables */
static integer j, info;
static char xern1[8], xern2[8];
extern /* Subroutine */ int sgefa_(real *, integer *, integer *, integer *
, integer *), sgesl_(real *, integer *, integer *, integer *,
real *, integer *);
static real dnorm;
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static real xnorm;
extern doublereal r1mach_(integer *), sdsdot_(integer *, real *, real *,
integer *, real *, integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static icilist io___2 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___4 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___5 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___6 = { 0, xern1, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE SGEIR */
/* ***PURPOSE Solve a general system of linear equations. Iterative */
/* refinement is used to obtain an error estimate. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY D2A1 */
/* ***TYPE SINGLE PRECISION (SGEIR-S, CGEIR-C) */
/* ***KEYWORDS COMPLEX LINEAR EQUATIONS, GENERAL MATRIX, */
/* GENERAL SYSTEM OF LINEAR EQUATIONS */
/* ***AUTHOR Voorhees, E. A., (LANL) */
/* ***DESCRIPTION */
/* Subroutine SGEIR solves a general NxN system of single */
/* precision linear equations using LINPACK subroutines SGEFA and */
/* SGESL. One pass of iterative refinement is used only to obtain */
/* an estimate of the accuracy. That is, if A is an NxN real */
/* matrix and if X and B are real N-vectors, then SGEIR solves */
/* the equation */
/* A*X=B. */
/* The matrix A is first factored into upper and lower tri- */
/* angular matrices U and L using partial pivoting. These */
/* factors and the pivoting information are used to calculate */
/* the solution, X. Then the residual vector is found and */
/* used to calculate an estimate of the relative error, IND. */
/* IND estimates the accuracy of the solution only when the */
/* input matrix and the right hand side are represented */
/* exactly in the computer and does not take into account */
/* any errors in the input data. */
/* If the equation A*X=B is to be solved for more than one vector */
/* B, the factoring of A does not need to be performed again and */
/* the option to solve only (ITASK .GT. 1) will be faster for */
/* the succeeding solutions. In this case, the contents of A, */
/* LDA, N, WORK, and IWORK must not have been altered by the */
/* user following factorization (ITASK=1). IND will not be */
/* changed by SGEIR in this case. */
/* Argument Description *** */
/* A REAL(LDA,N) */
/* the doubly subscripted array with dimension (LDA,N) */
/* which contains the coefficient matrix. A is not */
/* altered by the routine. */
/* LDA INTEGER */
/* the leading dimension of the array A. LDA must be great- */
/* er than or equal to N. (terminal error message IND=-1) */
/* N INTEGER */
/* the order of the matrix A. The first N elements of */
/* the array A are the elements of the first column of */
/* matrix A. N must be greater than or equal to 1. */
/* (terminal error message IND=-2) */
/* V REAL(N) */
/* on entry, the singly subscripted array(vector) of di- */
/* mension N which contains the right hand side B of a */
/* system of simultaneous linear equations A*X=B. */
/* on return, V contains the solution vector, X . */
/* ITASK INTEGER */
/* If ITASK=1, the matrix A is factored and then the */
/* linear equation is solved. */
/* If ITASK .GT. 1, the equation is solved using the existing */
/* factored matrix A (stored in WORK). */
/* If ITASK .LT. 1, then terminal error message IND=-3 is */
/* printed. */
/* IND INTEGER */
/* GT. 0 IND is a rough estimate of the number of digits */
/* of accuracy in the solution, X. IND=75 means */
/* that the solution vector X is zero. */
/* LT. 0 see error message corresponding to IND below. */
/* WORK REAL(N*(N+1)) */
/* a singly subscripted array of dimension at least N*(N+1). */
/* IWORK INTEGER(N) */
/* a singly subscripted array of dimension at least N. */
/* Error Messages Printed *** */
/* IND=-1 terminal N is greater than LDA. */
/* IND=-2 terminal N is less than one. */
/* IND=-3 terminal ITASK is less than one. */
/* IND=-4 terminal The matrix A is computationally singular. */
/* A solution has not been computed. */
/* IND=-10 warning The solution has no apparent significance. */
/* The solution may be inaccurate or the matrix */
/* A may be poorly scaled. */
/* Note- The above terminal(*fatal*) error messages are */
/* designed to be handled by XERMSG in which */
/* LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 */
/* for warning error messages from XERMSG. Unless */
/* the user provides otherwise, an error message */
/* will be printed followed by an abort. */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED R1MACH, SASUM, SCOPY, SDSDOT, SGEFA, SGESL, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 800430 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 890831 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE SGEIR */
/* ***FIRST EXECUTABLE STATEMENT SGEIR */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
work_dim1 = *n;
work_offset = 1 + work_dim1;
work -= work_offset;
--v;
--iwork;
/* Function Body */
if (*lda < *n) {
*ind = -1;
s_wsfi(&io___2);
do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___4);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 6, a__1[0] = "LDA = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " IS LESS THAN N = ";
i__1[3] = 8, a__1[3] = xern2;
s_cat(ch__1, a__1, i__1, &c__4, (ftnlen)40);
xermsg_("SLATEC", "SGEIR", ch__1, &c_n1, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)40);
return 0;
}
if (*n <= 0) {
*ind = -2;
s_wsfi(&io___5);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 4, a__2[0] = "N = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__2, a__2, i__2, &c__3, (ftnlen)27);
xermsg_("SLATEC", "SGEIR", ch__2, &c_n2, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)27);
return 0;
}
if (*itask < 1) {
*ind = -3;
s_wsfi(&io___6);
do_fio(&c__1, (char *)&(*itask), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 8, a__2[0] = "ITASK = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__3, a__2, i__2, &c__3, (ftnlen)31);
xermsg_("SLATEC", "SGEIR", ch__3, &c_n3, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)31);
return 0;
}
if (*itask == 1) {
/* MOVE MATRIX A TO WORK */
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
scopy_(n, &a[j * a_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &
c__1);
/* L10: */
}
/* FACTOR MATRIX A INTO LU */
sgefa_(&work[work_offset], n, n, &iwork[1], &info);
/* CHECK FOR COMPUTATIONALLY SINGULAR MATRIX */
if (info != 0) {
*ind = -4;
xermsg_("SLATEC", "SGEIR", "SINGULAR MATRIX A - NO SOLUTION", &
c_n4, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)31);
return 0;
}
}
/* SOLVE WHEN FACTORING COMPLETE */
/* MOVE VECTOR B TO WORK */
scopy_(n, &v[1], &c__1, &work[(*n + 1) * work_dim1 + 1], &c__1);
sgesl_(&work[work_offset], n, n, &iwork[1], &v[1], &c__0);
/* FORM NORM OF X0 */
xnorm = sasum_(n, &v[1], &c__1);
if (xnorm == 0.f) {
*ind = 75;
return 0;
}
/* COMPUTE RESIDUAL */
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
r__1 = -work[j + (*n + 1) * work_dim1];
work[j + (*n + 1) * work_dim1] = sdsdot_(n, &r__1, &a[j + a_dim1],
lda, &v[1], &c__1);
/* L40: */
}
/* SOLVE A*DELTA=R */
sgesl_(&work[work_offset], n, n, &iwork[1], &work[(*n + 1) * work_dim1 +
1], &c__0);
/* FORM NORM OF DELTA */
dnorm = sasum_(n, &work[(*n + 1) * work_dim1 + 1], &c__1);
/* COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) */
/* AND CHECK FOR IND GREATER THAN ZERO */
/* Computing MAX */
r__2 = r1mach_(&c__4), r__3 = dnorm / xnorm;
r__1 = dmax(r__2,r__3);
*ind = -r_lg10(&r__1);
if (*ind <= 0) {
*ind = -10;
xermsg_("SLATEC", "SGEIR", "SOLUTION MAY HAVE NO SIGNIFICANCE", &
c_n10, &c__0, (ftnlen)6, (ftnlen)5, (ftnlen)33);
}
return 0;
} /* sgeir_ */
/* DECK CNBIR */
/* Subroutine */ int cnbir_(complex *abe, integer *lda, integer *n, integer *
ml, integer *mu, complex *v, integer *itask, integer *ind, complex *
work, integer *iwork)
{
/* System generated locals */
address a__1[4], a__2[3];
integer abe_dim1, abe_offset, work_dim1, work_offset, i__1[4], i__2[3],
i__3, i__4, i__5;
real r__1, r__2, r__3;
complex q__1, q__2;
char ch__1[40], ch__2[27], ch__3[31], ch__4[29];
/* Local variables */
static integer j, k, l, m, nc, kk, info;
static char xern1[8], xern2[8];
extern /* Subroutine */ int cnbfa_(complex *, integer *, integer *,
integer *, integer *, integer *, integer *), cnbsl_(complex *,
integer *, integer *, integer *, integer *, integer *, complex *,
integer *), ccopy_(integer *, complex *, integer *, complex *,
integer *);
static real dnorm, xnorm;
extern doublereal r1mach_(integer *);
extern /* Complex */ void cdcdot_(complex *, integer *, complex *,
complex *, integer *, complex *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static icilist io___2 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___4 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___5 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___6 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___7 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___8 = { 0, xern1, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE CNBIR */
/* ***PURPOSE Solve a general nonsymmetric banded system of linear */
/* equations. Iterative refinement is used to obtain an error */
/* estimate. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY D2C2 */
/* ***TYPE COMPLEX (SNBIR-S, CNBIR-C) */
/* ***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC */
/* ***AUTHOR Voorhees, E. A., (LANL) */
/* ***DESCRIPTION */
/* Subroutine CNBIR solves a general nonsymmetric banded NxN */
/* system of single precision complex linear equations using */
/* SLATEC subroutines CNBFA and CNBSL. These are adaptations */
/* of the LINPACK subroutines CGBFA and CGBSL which require */
/* a different format for storing the matrix elements. */
/* One pass of iterative refinement is used only to obtain an */
/* estimate of the accuracy. If A is an NxN complex banded */
/* matrix and if X and B are complex N-vectors, then CNBIR */
/* solves the equation */
/* A*X=B. */
/* A band matrix is a matrix whose nonzero elements are all */
/* fairly near the main diagonal, specifically A(I,J) = 0 */
/* if I-J is greater than ML or J-I is greater than */
/* MU . The integers ML and MU are called the lower and upper */
/* band widths and M = ML+MU+1 is the total band width. */
/* CNBIR uses less time and storage than the corresponding */
/* program for general matrices (CGEIR) if 2*ML+MU .LT. N . */
/* The matrix A is first factored into upper and lower tri- */
/* angular matrices U and L using partial pivoting. These */
/* factors and the pivoting information are used to find the */
/* solution vector X . Then the residual vector is found and used */
/* to calculate an estimate of the relative error, IND . IND esti- */
/* mates the accuracy of the solution only when the input matrix */
/* and the right hand side are represented exactly in the computer */
/* and does not take into account any errors in the input data. */
/* If the equation A*X=B is to be solved for more than one vector */
/* B, the factoring of A does not need to be performed again and */
/* the option to only solve (ITASK .GT. 1) will be faster for */
/* the succeeding solutions. In this case, the contents of A, LDA, */
/* N, WORK and IWORK must not have been altered by the user follow- */
/* ing factorization (ITASK=1). IND will not be changed by CNBIR */
/* in this case. */
/* Band Storage */
/* If A is a band matrix, the following program segment */
/* will set up the input. */
/* ML = (band width below the diagonal) */
/* MU = (band width above the diagonal) */
/* DO 20 I = 1, N */
/* J1 = MAX(1, I-ML) */
/* J2 = MIN(N, I+MU) */
/* DO 10 J = J1, J2 */
/* K = J - I + ML + 1 */
/* ABE(I,K) = A(I,J) */
/* 10 CONTINUE */
/* 20 CONTINUE */
/* This uses columns 1 through ML+MU+1 of ABE . */
/* Example: If the original matrix is */
/* 11 12 13 0 0 0 */
/* 21 22 23 24 0 0 */
/* 0 32 33 34 35 0 */
/* 0 0 43 44 45 46 */
/* 0 0 0 54 55 56 */
/* 0 0 0 0 65 66 */
/* then N = 6, ML = 1, MU = 2, LDA .GE. 5 and ABE should contain */
/* * 11 12 13 , * = not used */
/* 21 22 23 24 */
/* 32 33 34 35 */
/* 43 44 45 46 */
/* 54 55 56 * */
/* 65 66 * * */
/* Argument Description *** */
/* ABE COMPLEX(LDA,MM) */
/* on entry, contains the matrix in band storage as */
/* described above. MM must not be less than M = */
/* ML+MU+1 . The user is cautioned to dimension ABE */
/* with care since MM is not an argument and cannot */
/* be checked by CNBIR. The rows of the original */
/* matrix are stored in the rows of ABE and the */
/* diagonals of the original matrix are stored in */
/* columns 1 through ML+MU+1 of ABE . ABE is */
/* not altered by the program. */
/* LDA INTEGER */
/* the leading dimension of array ABE. LDA must be great- */
/* er than or equal to N. (terminal error message IND=-1) */
/* N INTEGER */
/* the order of the matrix A. N must be greater */
/* than or equal to 1 . (terminal error message IND=-2) */
/* ML INTEGER */
/* the number of diagonals below the main diagonal. */
/* ML must not be less than zero nor greater than or */
/* equal to N . (terminal error message IND=-5) */
/* MU INTEGER */
/* the number of diagonals above the main diagonal. */
/* MU must not be less than zero nor greater than or */
/* equal to N . (terminal error message IND=-6) */
/* V COMPLEX(N) */
/* on entry, the singly subscripted array(vector) of di- */
/* mension N which contains the right hand side B of a */
/* system of simultaneous linear equations A*X=B. */
/* on return, V contains the solution vector, X . */
/* ITASK INTEGER */
/* if ITASK=1, the matrix A is factored and then the */
/* linear equation is solved. */
/* if ITASK .GT. 1, the equation is solved using the existing */
/* factored matrix A and IWORK. */
/* if ITASK .LT. 1, then terminal error message IND=-3 is */
/* printed. */
/* IND INTEGER */
/* GT. 0 IND is a rough estimate of the number of digits */
/* of accuracy in the solution, X . IND=75 means */
/* that the solution vector X is zero. */
/* LT. 0 see error message corresponding to IND below. */
/* WORK COMPLEX(N*(NC+1)) */
/* a singly subscripted array of dimension at least */
/* N*(NC+1) where NC = 2*ML+MU+1 . */
/* IWORK INTEGER(N) */
/* a singly subscripted array of dimension at least N. */
/* Error Messages Printed *** */
/* IND=-1 terminal N is greater than LDA. */
/* IND=-2 terminal N is less than 1. */
/* IND=-3 terminal ITASK is less than 1. */
/* IND=-4 terminal The matrix A is computationally singular. */
/* A solution has not been computed. */
/* IND=-5 terminal ML is less than zero or is greater than */
/* or equal to N . */
/* IND=-6 terminal MU is less than zero or is greater than */
/* or equal to N . */
/* IND=-10 warning The solution has no apparent significance. */
/* The solution may be inaccurate or the matrix */
/* A may be poorly scaled. */
/* NOTE- The above terminal(*fatal*) error messages are */
/* designed to be handled by XERMSG in which */
/* LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 */
/* for warning error messages from XERMSG. Unless */
/* the user provides otherwise, an error message */
/* will be printed followed by an abort. */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED CCOPY, CDCDOT, CNBFA, CNBSL, R1MACH, SCASUM, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 800819 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 890831 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900510 Convert XERRWV calls to XERMSG calls, cvt GOTO's to */
/* IF-THEN-ELSE. (RWC) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE CNBIR */
/* ***FIRST EXECUTABLE STATEMENT CNBIR */
/* Parameter adjustments */
abe_dim1 = *lda;
abe_offset = 1 + abe_dim1;
abe -= abe_offset;
work_dim1 = *n;
work_offset = 1 + work_dim1;
work -= work_offset;
--v;
--iwork;
/* Function Body */
if (*lda < *n) {
*ind = -1;
s_wsfi(&io___2);
do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___4);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 6, a__1[0] = "LDA = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " IS LESS THAN N = ";
i__1[3] = 8, a__1[3] = xern2;
s_cat(ch__1, a__1, i__1, &c__4, (ftnlen)40);
xermsg_("SLATEC", "CNBIR", ch__1, &c_n1, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)40);
return 0;
}
if (*n <= 0) {
*ind = -2;
s_wsfi(&io___5);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 4, a__2[0] = "N = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__2, a__2, i__2, &c__3, (ftnlen)27);
xermsg_("SLATEC", "CNBIR", ch__2, &c_n2, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)27);
return 0;
}
if (*itask < 1) {
*ind = -3;
s_wsfi(&io___6);
do_fio(&c__1, (char *)&(*itask), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 8, a__2[0] = "ITASK = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__3, a__2, i__2, &c__3, (ftnlen)31);
xermsg_("SLATEC", "CNBIR", ch__3, &c_n3, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)31);
return 0;
}
if (*ml < 0 || *ml >= *n) {
*ind = -5;
s_wsfi(&io___7);
do_fio(&c__1, (char *)&(*ml), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 5, a__2[0] = "ML = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 16, a__2[2] = " IS OUT OF RANGE";
s_cat(ch__4, a__2, i__2, &c__3, (ftnlen)29);
xermsg_("SLATEC", "CNBIR", ch__4, &c_n5, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)29);
return 0;
}
if (*mu < 0 || *mu >= *n) {
*ind = -6;
s_wsfi(&io___8);
do_fio(&c__1, (char *)&(*mu), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 5, a__2[0] = "MU = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 16, a__2[2] = " IS OUT OF RANGE";
s_cat(ch__4, a__2, i__2, &c__3, (ftnlen)29);
xermsg_("SLATEC", "CNBIR", ch__4, &c_n6, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)29);
return 0;
}
nc = (*ml << 1) + *mu + 1;
if (*itask == 1) {
/* MOVE MATRIX ABE TO WORK */
m = *ml + *mu + 1;
i__3 = m;
for (j = 1; j <= i__3; ++j) {
ccopy_(n, &abe[j * abe_dim1 + 1], &c__1, &work[j * work_dim1 + 1],
&c__1);
/* L10: */
}
/* FACTOR MATRIX A INTO LU */
cnbfa_(&work[work_offset], n, n, ml, mu, &iwork[1], &info);
/* CHECK FOR COMPUTATIONALLY SINGULAR MATRIX */
if (info != 0) {
*ind = -4;
xermsg_("SLATEC", "CNBIR", "SINGULAR MATRIX A - NO SOLUTION", &
c_n4, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)31);
return 0;
}
}
/* SOLVE WHEN FACTORING COMPLETE */
/* MOVE VECTOR B TO WORK */
ccopy_(n, &v[1], &c__1, &work[(nc + 1) * work_dim1 + 1], &c__1);
cnbsl_(&work[work_offset], n, n, ml, mu, &iwork[1], &v[1], &c__0);
/* FORM NORM OF X0 */
xnorm = scasum_(n, &v[1], &c__1);
if (xnorm == 0.f) {
*ind = 75;
return 0;
}
/* COMPUTE RESIDUAL */
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
i__4 = 1, i__5 = *ml + 2 - j;
k = max(i__4,i__5);
/* Computing MAX */
i__4 = 1, i__5 = j - *ml;
kk = max(i__4,i__5);
/* Computing MIN */
i__4 = j - 1;
/* Computing MIN */
i__5 = *n - j;
l = min(i__4,*ml) + min(i__5,*mu) + 1;
i__4 = j + (nc + 1) * work_dim1;
i__5 = j + (nc + 1) * work_dim1;
q__2.r = -work[i__5].r, q__2.i = -work[i__5].i;
cdcdot_(&q__1, &l, &q__2, &abe[j + k * abe_dim1], lda, &v[kk], &c__1);
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
/* L40: */
}
/* SOLVE A*DELTA=R */
cnbsl_(&work[work_offset], n, n, ml, mu, &iwork[1], &work[(nc + 1) *
work_dim1 + 1], &c__0);
/* FORM NORM OF DELTA */
dnorm = scasum_(n, &work[(nc + 1) * work_dim1 + 1], &c__1);
/* COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) */
/* AND CHECK FOR IND GREATER THAN ZERO */
/* Computing MAX */
r__2 = r1mach_(&c__4), r__3 = dnorm / xnorm;
r__1 = dmax(r__2,r__3);
*ind = -r_lg10(&r__1);
if (*ind <= 0) {
*ind = -10;
xermsg_("SLATEC", "CNBIR", "SOLUTION MAY HAVE NO SIGNIFICANCE", &
c_n10, &c__0, (ftnlen)6, (ftnlen)5, (ftnlen)33);
}
return 0;
} /* cnbir_ */
/* Subroutine */ int set_(real *xobj1, real *xobj2, real *yobj1, real *yobj2,
real *xsub1, real *xsub2, real *ysub1, real *ysub2, integer *ltype)
{
/* Initialized data */
static shortint ixc[4] = { 1,1,-1,-1 };
static shortint iyc[4] = { 1,-1,1,-1 };
/* Format strings */
static char fmt_9001[] = "(//\002 ********** Illegal parameters in SET *"
"*********\002/4(1x,1pg12.5)/4(1x,1pg12.5),i6)";
/* Builtin functions */
double r_lg10(real *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static real sxmin, sxmax, symin, symax;
/* Fortran I/O blocks */
static cilist io___7 = { 0, 6, 0, fmt_9001, 0 };
/* Set the relationship between the physical space and the user space. */
/* .......................................................................
*/
/* Internal Data for PLOTPAK */
/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*/
/* Check entry values for reasonableness. */
if (*xobj1 < zzzplt_1.xpgmin || *xobj1 >= *xobj2 || *xobj2 >
zzzplt_1.xpgmax || *xsub1 == *xsub2 || *yobj1 < zzzplt_1.ypgmin ||
*yobj1 >= *yobj2 || *yobj2 > zzzplt_1.ypgmax || *ysub1 == *ysub2
|| *ltype <= 0 || *ltype > 4) {
goto L9000;
}
/* .......................................................................
*/
zzzplt_1.xbot = *xobj1;
zzzplt_1.ybot = *yobj1;
zzzplt_1.xtop = *xobj2;
zzzplt_1.ytop = *yobj2;
zzzplt_1.xmin = *xsub1;
zzzplt_1.xmax = *xsub2;
zzzplt_1.ymin = *ysub1;
zzzplt_1.ymax = *ysub2;
zzzplt_1.ixcoor = ixc[*ltype - 1];
zzzplt_1.iycoor = iyc[*ltype - 1];
if (zzzplt_1.ixcoor >= 0) {
sxmin = *xsub1;
sxmax = *xsub2;
} else {
if (*xsub1 <= 0.f || *xsub2 <= 0.f) {
goto L9000;
}
sxmin = r_lg10(xsub1);
sxmax = r_lg10(xsub2);
}
if (zzzplt_1.iycoor >= 0) {
symin = *ysub1;
symax = *ysub2;
} else {
if (*ysub1 <= 0.f || *ysub2 <= 0.f) {
goto L9000;
}
symin = r_lg10(ysub1);
symax = r_lg10(ysub2);
}
/* Calculate the alpha and beta scaling factors to map user space */
/* into physical space. */
zzzplt_1.alphxx = (zzzplt_1.xtop - zzzplt_1.xbot) / (sxmax - sxmin);
zzzplt_1.betaxx = zzzplt_1.xbot - zzzplt_1.alphxx * sxmin;
zzzplt_1.alphyy = (zzzplt_1.ytop - zzzplt_1.ybot) / (symax - symin);
zzzplt_1.betayy = zzzplt_1.ybot - zzzplt_1.alphyy * symin;
return 0;
/* .......................................................................
*/
L9000:
/* CC OPEN( 98 , FILE='PLOTPAK.ERR' , STATUS='NEW' ) */
/* CC WRITE(98,9001) XOBJ1,XOBJ2 , YOBJ1,YOBJ2 , */
/* CC X XSUB1,XSUB2 , YSUB1,YSUB2 , LTYPE */
/* L9001: */
/* cc CLOSE( 98 ) */
s_wsfe(&io___7);
do_fio(&c__1, (char *)&(*xobj1), (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*xobj2), (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*yobj1), (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*yobj2), (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*xsub1), (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*xsub2), (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*ysub1), (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*ysub2), (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*ltype), (ftnlen)sizeof(integer));
e_wsfe();
exit(0) ;
return 0;
} /* set_ */
/* Subroutine */ int sggbal_(char *job, integer *n, real *a, integer *lda,
real *b, integer *ldb, integer *ilo, integer *ihi, real *lscale, real
*rscale, real *work, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SGGBAL balances a pair of general real matrices (A,B). This
involves, first, permuting A and B by similarity transformations to
isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
elements on the diagonal; and second, applying a diagonal similarity
transformation to rows and columns ILO to IHI to make the rows
and columns as close in norm as possible. Both steps are optional.
Balancing may reduce the 1-norm of the matrices, and improve the
accuracy of the computed eigenvalues and/or eigenvectors in the
generalized eigenvalue problem A*x = lambda*B*x.
Arguments
=========
JOB (input) CHARACTER*1
Specifies the operations to be performed on A and B:
= 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
and RSCALE(I) = 1.0 for i = 1,...,N.
= 'P': permute only;
= 'S': scale only;
= 'B': both permute and scale.
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) REAL array, dimension (LDA,N)
On entry, the input matrix A.
On exit, A is overwritten by the balanced matrix.
If JOB = 'N', A is not referenced.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) REAL array, dimension (LDB,N)
On entry, the input matrix B.
On exit, B is overwritten by the balanced matrix.
If JOB = 'N', B is not referenced.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
ILO (output) INTEGER
IHI (output) INTEGER
ILO and IHI are set to integers such that on exit
A(i,j) = 0 and B(i,j) = 0 if i > j and
j = 1,...,ILO-1 or i = IHI+1,...,N.
If JOB = 'N' or 'S', ILO = 1 and IHI = N.
LSCALE (output) REAL array, dimension (N)
Details of the permutations and scaling factors applied
to the left side of A and B. If P(j) is the index of the
row interchanged with row j, and D(j)
is the scaling factor applied to row j, then
LSCALE(j) = P(j) for J = 1,...,ILO-1
= D(j) for J = ILO,...,IHI
= P(j) for J = IHI+1,...,N.
The order in which the interchanges are made is N to IHI+1,
then 1 to ILO-1.
RSCALE (output) REAL array, dimension (N)
Details of the permutations and scaling factors applied
to the right side of A and B. If P(j) is the index of the
column interchanged with column j, and D(j)
is the scaling factor applied to column j, then
LSCALE(j) = P(j) for J = 1,...,ILO-1
= D(j) for J = ILO,...,IHI
= P(j) for J = IHI+1,...,N.
The order in which the interchanges are made is N to IHI+1,
then 1 to ILO-1.
WORK (workspace) REAL array, dimension (6*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
See R.C. WARD, Balancing the generalized eigenvalue problem,
SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
=====================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static real c_b34 = 10.f;
static real c_b70 = .5f;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
real r__1, r__2, r__3;
/* Builtin functions */
double r_lg10(real *), r_sign(real *, real *), pow_ri(real *, integer *);
/* Local variables */
static integer lcab;
static real beta, coef;
static integer irab, lrab;
static real basl, cmax;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
static real coef2, coef5;
static integer i__, j, k, l, m;
static real gamma, t, alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real sfmin, sfmax;
static integer iflow;
extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
integer *);
static integer kount;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *);
static integer jc;
static real ta, tb, tc;
static integer ir, it;
static real ew;
static integer nr;
static real pgamma;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
static integer lsfmin, lsfmax, ip1, jp1, lm1;
static real cab, rab, ewc, cor, sum;
static integer nrp2, icab;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--lscale;
--rscale;
--work;
/* Function Body */
*info = 0;
if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
&& ! lsame_(job, "B")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*ldb < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGGBAL", &i__1);
return 0;
}
k = 1;
l = *n;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (lsame_(job, "N")) {
*ilo = 1;
*ihi = *n;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
lscale[i__] = 1.f;
rscale[i__] = 1.f;
/* L10: */
}
return 0;
}
if (k == l) {
*ilo = 1;
*ihi = 1;
lscale[1] = 1.f;
rscale[1] = 1.f;
return 0;
}
if (lsame_(job, "S")) {
goto L190;
}
goto L30;
/* Permute the matrices A and B to isolate the eigenvalues.
Find row with one nonzero in columns 1 through L */
L20:
l = lm1;
if (l != 1) {
goto L30;
}
rscale[1] = 1.f;
lscale[1] = 1.f;
goto L190;
L30:
lm1 = l - 1;
for (i__ = l; i__ >= 1; --i__) {
i__1 = lm1;
for (j = 1; j <= i__1; ++j) {
jp1 = j + 1;
if (a_ref(i__, j) != 0.f || b_ref(i__, j) != 0.f) {
goto L50;
}
/* L40: */
}
j = l;
goto L70;
L50:
i__1 = l;
for (j = jp1; j <= i__1; ++j) {
if (a_ref(i__, j) != 0.f || b_ref(i__, j) != 0.f) {
goto L80;
}
/* L60: */
}
j = jp1 - 1;
L70:
m = l;
iflow = 1;
goto L160;
L80:
;
}
goto L100;
/* Find column with one nonzero in rows K through N */
L90:
++k;
L100:
i__1 = l;
for (j = k; j <= i__1; ++j) {
i__2 = lm1;
for (i__ = k; i__ <= i__2; ++i__) {
ip1 = i__ + 1;
if (a_ref(i__, j) != 0.f || b_ref(i__, j) != 0.f) {
goto L120;
}
/* L110: */
}
i__ = l;
goto L140;
L120:
i__2 = l;
for (i__ = ip1; i__ <= i__2; ++i__) {
if (a_ref(i__, j) != 0.f || b_ref(i__, j) != 0.f) {
goto L150;
}
/* L130: */
}
i__ = ip1 - 1;
L140:
m = k;
iflow = 2;
goto L160;
L150:
;
}
goto L190;
/* Permute rows M and I */
L160:
lscale[m] = (real) i__;
if (i__ == m) {
goto L170;
}
i__1 = *n - k + 1;
sswap_(&i__1, &a_ref(i__, k), lda, &a_ref(m, k), lda);
i__1 = *n - k + 1;
sswap_(&i__1, &b_ref(i__, k), ldb, &b_ref(m, k), ldb);
/* Permute columns M and J */
L170:
rscale[m] = (real) j;
if (j == m) {
goto L180;
}
sswap_(&l, &a_ref(1, j), &c__1, &a_ref(1, m), &c__1);
sswap_(&l, &b_ref(1, j), &c__1, &b_ref(1, m), &c__1);
L180:
switch (iflow) {
case 1: goto L20;
case 2: goto L90;
}
L190:
*ilo = k;
*ihi = l;
if (*ilo == *ihi) {
return 0;
}
if (lsame_(job, "P")) {
return 0;
}
/* Balance the submatrix in rows ILO to IHI. */
nr = *ihi - *ilo + 1;
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
rscale[i__] = 0.f;
lscale[i__] = 0.f;
work[i__] = 0.f;
work[i__ + *n] = 0.f;
work[i__ + (*n << 1)] = 0.f;
work[i__ + *n * 3] = 0.f;
work[i__ + (*n << 2)] = 0.f;
work[i__ + *n * 5] = 0.f;
/* L200: */
}
/* Compute right side vector in resulting linear equations */
basl = r_lg10(&c_b34);
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *ihi;
for (j = *ilo; j <= i__2; ++j) {
tb = b_ref(i__, j);
ta = a_ref(i__, j);
if (ta == 0.f) {
goto L210;
}
r__1 = dabs(ta);
ta = r_lg10(&r__1) / basl;
L210:
if (tb == 0.f) {
goto L220;
}
r__1 = dabs(tb);
tb = r_lg10(&r__1) / basl;
L220:
work[i__ + (*n << 2)] = work[i__ + (*n << 2)] - ta - tb;
work[j + *n * 5] = work[j + *n * 5] - ta - tb;
/* L230: */
}
/* L240: */
}
coef = 1.f / (real) (nr << 1);
coef2 = coef * coef;
coef5 = coef2 * .5f;
nrp2 = nr + 2;
beta = 0.f;
it = 1;
/* Start generalized conjugate gradient iteration */
L250:
gamma = sdot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)]
, &c__1) + sdot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + *
n * 5], &c__1);
ew = 0.f;
ewc = 0.f;
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
ew += work[i__ + (*n << 2)];
ewc += work[i__ + *n * 5];
/* L260: */
}
/* Computing 2nd power */
r__1 = ew;
/* Computing 2nd power */
r__2 = ewc;
/* Computing 2nd power */
r__3 = ew - ewc;
gamma = coef * gamma - coef2 * (r__1 * r__1 + r__2 * r__2) - coef5 * (
r__3 * r__3);
if (gamma == 0.f) {
goto L350;
}
if (it != 1) {
beta = gamma / pgamma;
}
t = coef5 * (ewc - ew * 3.f);
tc = coef5 * (ew - ewc * 3.f);
sscal_(&nr, &beta, &work[*ilo], &c__1);
sscal_(&nr, &beta, &work[*ilo + *n], &c__1);
saxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], &
c__1);
saxpy_(&nr, &coef, &work[*ilo + *n * 5], &c__1, &work[*ilo], &c__1);
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
work[i__] += tc;
work[i__ + *n] += t;
/* L270: */
}
/* Apply matrix to vector */
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
kount = 0;
sum = 0.f;
i__2 = *ihi;
for (j = *ilo; j <= i__2; ++j) {
if (a_ref(i__, j) == 0.f) {
goto L280;
}
++kount;
sum += work[j];
L280:
if (b_ref(i__, j) == 0.f) {
goto L290;
}
++kount;
sum += work[j];
L290:
;
}
work[i__ + (*n << 1)] = (real) kount * work[i__ + *n] + sum;
/* L300: */
}
i__1 = *ihi;
for (j = *ilo; j <= i__1; ++j) {
kount = 0;
sum = 0.f;
i__2 = *ihi;
for (i__ = *ilo; i__ <= i__2; ++i__) {
if (a_ref(i__, j) == 0.f) {
goto L310;
}
++kount;
sum += work[i__ + *n];
L310:
if (b_ref(i__, j) == 0.f) {
goto L320;
}
++kount;
sum += work[i__ + *n];
L320:
;
}
work[j + *n * 3] = (real) kount * work[j] + sum;
/* L330: */
}
sum = sdot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1)
+ sdot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1);
alpha = gamma / sum;
/* Determine correction to current iteration */
cmax = 0.f;
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
cor = alpha * work[i__ + *n];
if (dabs(cor) > cmax) {
cmax = dabs(cor);
}
lscale[i__] += cor;
cor = alpha * work[i__];
if (dabs(cor) > cmax) {
cmax = dabs(cor);
}
rscale[i__] += cor;
/* L340: */
}
if (cmax < .5f) {
goto L350;
}
r__1 = -alpha;
saxpy_(&nr, &r__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)]
, &c__1);
r__1 = -alpha;
saxpy_(&nr, &r__1, &work[*ilo + *n * 3], &c__1, &work[*ilo + *n * 5], &
c__1);
pgamma = gamma;
++it;
if (it <= nrp2) {
goto L250;
}
/* End generalized conjugate gradient iteration */
L350:
sfmin = slamch_("S");
sfmax = 1.f / sfmin;
lsfmin = (integer) (r_lg10(&sfmin) / basl + 1.f);
lsfmax = (integer) (r_lg10(&sfmax) / basl);
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *n - *ilo + 1;
irab = isamax_(&i__2, &a_ref(i__, *ilo), lda);
rab = (r__1 = a_ref(i__, irab + *ilo - 1), dabs(r__1));
i__2 = *n - *ilo + 1;
irab = isamax_(&i__2, &b_ref(i__, *ilo), lda);
/* Computing MAX */
r__2 = rab, r__3 = (r__1 = b_ref(i__, irab + *ilo - 1), dabs(r__1));
rab = dmax(r__2,r__3);
r__1 = rab + sfmin;
lrab = (integer) (r_lg10(&r__1) / basl + 1.f);
ir = lscale[i__] + r_sign(&c_b70, &lscale[i__]);
/* Computing MIN */
i__2 = max(ir,lsfmin), i__2 = min(i__2,lsfmax), i__3 = lsfmax - lrab;
ir = min(i__2,i__3);
lscale[i__] = pow_ri(&c_b34, &ir);
icab = isamax_(ihi, &a_ref(1, i__), &c__1);
cab = (r__1 = a_ref(icab, i__), dabs(r__1));
icab = isamax_(ihi, &b_ref(1, i__), &c__1);
/* Computing MAX */
r__2 = cab, r__3 = (r__1 = b_ref(icab, i__), dabs(r__1));
cab = dmax(r__2,r__3);
r__1 = cab + sfmin;
lcab = (integer) (r_lg10(&r__1) / basl + 1.f);
jc = rscale[i__] + r_sign(&c_b70, &rscale[i__]);
/* Computing MIN */
i__2 = max(jc,lsfmin), i__2 = min(i__2,lsfmax), i__3 = lsfmax - lcab;
jc = min(i__2,i__3);
rscale[i__] = pow_ri(&c_b34, &jc);
/* L360: */
}
/* Row scaling of matrices A and B */
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *n - *ilo + 1;
sscal_(&i__2, &lscale[i__], &a_ref(i__, *ilo), lda);
i__2 = *n - *ilo + 1;
sscal_(&i__2, &lscale[i__], &b_ref(i__, *ilo), ldb);
/* L370: */
}
/* Column scaling of matrices A and B */
i__1 = *ihi;
for (j = *ilo; j <= i__1; ++j) {
sscal_(ihi, &rscale[j], &a_ref(1, j), &c__1);
sscal_(ihi, &rscale[j], &b_ref(1, j), &c__1);
/* L380: */
}
return 0;
/* End of SGGBAL */
} /* sggbal_ */
