/* Subroutine */ int dlabad_(doublereal *small, doublereal *large)
{
/* Builtin functions */
double d_lg10(doublereal *), sqrt(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 .. */
/* .. */
/* Purpose */
/* ======= */
/* DLABAD 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 DLAMCH. This subroutine is needed because */
/* DLAMCH does not compensate for poor arithmetic in the upper half of */
/* the exponent range, as is found on a Cray. */
/* Arguments */
/* ========= */
/* SMALL (input/output) DOUBLE PRECISION */
/* On entry, the underflow threshold as computed by DLAMCH. */
/* On exit, if LOG10(LARGE) is sufficiently large, the square */
/* root of SMALL, otherwise unchanged. */
/* LARGE (input/output) DOUBLE PRECISION */
/* On entry, the overflow threshold as computed by DLAMCH. */
/* 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 (d_lg10(large) > 2e3) {
*small = sqrt(*small);
*large = sqrt(*large);
}
return 0;
/* End of DLABAD */
} /* dlabad_ */
int dlabad_(doublereal *small, doublereal *large)
{
/* -- 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
=======
DLABAD takes as input the values computed by DLAMCH 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 DLAMCH. This subroutine is needed because
DLAMCH does not compensate for poor arithmetic in the upper half of
the exponent range, as is found on a Cray.
Arguments
=========
SMALL (input/output) DOUBLE PRECISION
On entry, the underflow threshold as computed by DLAMCH.
On exit, if LOG10(LARGE) is sufficiently large, the square
root of SMALL, otherwise unchanged.
LARGE (input/output) DOUBLE PRECISION
On entry, the overflow threshold as computed by DLAMCH.
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 */
doublereal d_lg10(doublereal *);
doublereal d_sqrt(doublereal *);
if (d_lg10(large) > 2e3)
{
*small = d_sqrt(small); // YC: *small avant
*large = d_sqrt(large); // YC: *large avant
}
return 0;
/* End of DLABAD */
} /* dlabad_ */
/* Subroutine */ int dlabad_(doublereal *small, doublereal *large)
{
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DLABAD takes as input the values computed by DLAMCH 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 DLAMCH. This subroutine is needed because */
/* DLAMCH does not compensate for poor arithmetic in the upper half of */
/* the exponent range, as is found on a Cray. */
/* Arguments */
/* ========= */
/* SMALL (input/output) DOUBLE PRECISION */
/* On entry, the underflow threshold as computed by DLAMCH. */
/* On exit, if LOG10(LARGE) is sufficiently large, the square */
/* root of SMALL, otherwise unchanged. */
/* LARGE (input/output) DOUBLE PRECISION */
/* On entry, the overflow threshold as computed by DLAMCH. */
/* 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. */
if (d_lg10(large) > 2e3) {
*small = sqrt(*small);
*large = sqrt(*large);
}
return 0;
/* End of DLABAD */
} /* dlabad_ */
/* Subroutine */ int zggbal_(char *job, integer *n, doublecomplex *a, integer
*lda, doublecomplex *b, integer *ldb, integer *ilo, integer *ihi,
doublereal *lscale, doublereal *rscale, doublereal *work, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double d_lg10(doublereal *), d_imag(doublecomplex *), z_abs(doublecomplex
*), d_sign(doublereal *, doublereal *), pow_di(doublereal *,
integer *);
/* Local variables */
integer i__, j, k, l, m;
doublereal t;
integer jc;
doublereal ta, tb, tc;
integer ir;
doublereal ew;
integer it, nr, ip1, jp1, lm1;
doublereal cab, rab, ewc, cor, sum;
integer nrp2, icab, lcab;
doublereal beta, coef;
integer irab, lrab;
doublereal basl, cmax;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
doublereal coef2, coef5, gamma, alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
doublereal sfmin, sfmax;
integer iflow;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
integer kount;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
doublereal pgamma;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
integer lsfmin;
extern integer izamax_(integer *, doublecomplex *, integer *);
integer lsfmax;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGGBAL 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*16 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*16 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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_("ZGGBAL", &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.;
rscale[1] = 1.;
return 0;
}
if (lsame_(job, "N")) {
*ilo = 1;
*ihi = *n;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
lscale[i__] = 1.;
rscale[i__] = 1.;
/* 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.;
lscale[1] = 1.;
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. || a[i__2].i != 0. || (b[i__3].r != 0. || b[
i__3].i != 0.)) {
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. || a[i__2].i != 0. || (b[i__3].r != 0. || b[
i__3].i != 0.)) {
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. || a[i__3].i != 0. || (b[i__4].r != 0. || b[
i__4].i != 0.)) {
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. || a[i__3].i != 0. || (b[i__4].r != 0. || b[
i__4].i != 0.)) {
goto L150;
}
/* L130: */
}
i__ = ip1 - 1;
L140:
m = k;
iflow = 2;
goto L160;
L150:
;
}
goto L190;
/* Permute rows M and I */
L160:
lscale[m] = (doublereal) i__;
if (i__ == m) {
goto L170;
}
i__1 = *n - k + 1;
zswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[m + k * a_dim1], lda);
i__1 = *n - k + 1;
zswap_(&i__1, &b[i__ + k * b_dim1], ldb, &b[m + k * b_dim1], ldb);
/* Permute columns M and J */
L170:
rscale[m] = (doublereal) j;
if (j == m) {
goto L180;
}
zswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
zswap_(&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.;
rscale[i__] = 1.;
/* 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.;
lscale[i__] = 0.;
work[i__] = 0.;
work[i__ + *n] = 0.;
work[i__ + (*n << 1)] = 0.;
work[i__ + *n * 3] = 0.;
work[i__ + (*n << 2)] = 0.;
work[i__ + *n * 5] = 0.;
/* L200: */
}
/* Compute right side vector in resulting linear equations */
basl = d_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. && a[i__3].i == 0.) {
ta = 0.;
goto L210;
}
i__3 = i__ + j * a_dim1;
d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j *
a_dim1]), abs(d__2));
ta = d_lg10(&d__3) / basl;
L210:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0. && b[i__3].i == 0.) {
tb = 0.;
goto L220;
}
i__3 = i__ + j * b_dim1;
d__3 = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + j *
b_dim1]), abs(d__2));
tb = d_lg10(&d__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. / (doublereal) (nr << 1);
coef2 = coef * coef;
coef5 = coef2 * .5;
nrp2 = nr + 2;
beta = 0.;
it = 1;
/* Start generalized conjugate gradient iteration */
L250:
gamma = ddot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)]
, &c__1) + ddot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + *
n * 5], &c__1);
ew = 0.;
ewc = 0.;
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
ew += work[i__ + (*n << 2)];
ewc += work[i__ + *n * 5];
/* L260: */
}
/* Computing 2nd power */
d__1 = ew;
/* Computing 2nd power */
d__2 = ewc;
/* Computing 2nd power */
d__3 = ew - ewc;
gamma = coef * gamma - coef2 * (d__1 * d__1 + d__2 * d__2) - coef5 * (
d__3 * d__3);
if (gamma == 0.) {
goto L350;
}
if (it != 1) {
beta = gamma / pgamma;
}
t = coef5 * (ewc - ew * 3.);
tc = coef5 * (ew - ewc * 3.);
dscal_(&nr, &beta, &work[*ilo], &c__1);
dscal_(&nr, &beta, &work[*ilo + *n], &c__1);
daxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], &
c__1);
daxpy_(&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.;
i__2 = *ihi;
for (j = *ilo; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
if (a[i__3].r == 0. && a[i__3].i == 0.) {
goto L280;
}
++kount;
sum += work[j];
L280:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0. && b[i__3].i == 0.) {
goto L290;
}
++kount;
sum += work[j];
L290:
;
}
work[i__ + (*n << 1)] = (doublereal) kount * work[i__ + *n] + sum;
/* L300: */
}
i__1 = *ihi;
for (j = *ilo; j <= i__1; ++j) {
kount = 0;
sum = 0.;
i__2 = *ihi;
for (i__ = *ilo; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
if (a[i__3].r == 0. && a[i__3].i == 0.) {
goto L310;
}
++kount;
sum += work[i__ + *n];
L310:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0. && b[i__3].i == 0.) {
goto L320;
}
++kount;
sum += work[i__ + *n];
L320:
;
}
work[j + *n * 3] = (doublereal) kount * work[j] + sum;
/* L330: */
}
sum = ddot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1)
+ ddot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1);
alpha = gamma / sum;
/* Determine correction to current iteration */
cmax = 0.;
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 < .5) {
goto L350;
}
d__1 = -alpha;
daxpy_(&nr, &d__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)]
, &c__1);
d__1 = -alpha;
daxpy_(&nr, &d__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 = dlamch_("S");
sfmax = 1. / sfmin;
lsfmin = (integer) (d_lg10(&sfmin) / basl + 1.);
lsfmax = (integer) (d_lg10(&sfmax) / basl);
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *n - *ilo + 1;
irab = izamax_(&i__2, &a[i__ + *ilo * a_dim1], lda);
rab = z_abs(&a[i__ + (irab + *ilo - 1) * a_dim1]);
i__2 = *n - *ilo + 1;
irab = izamax_(&i__2, &b[i__ + *ilo * b_dim1], ldb);
/* Computing MAX */
d__1 = rab, d__2 = z_abs(&b[i__ + (irab + *ilo - 1) * b_dim1]);
rab = max(d__1,d__2);
d__1 = rab + sfmin;
lrab = (integer) (d_lg10(&d__1) / basl + 1.);
ir = (integer) (lscale[i__] + d_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_di(&c_b36, &ir);
icab = izamax_(ihi, &a[i__ * a_dim1 + 1], &c__1);
cab = z_abs(&a[icab + i__ * a_dim1]);
icab = izamax_(ihi, &b[i__ * b_dim1 + 1], &c__1);
/* Computing MAX */
d__1 = cab, d__2 = z_abs(&b[icab + i__ * b_dim1]);
cab = max(d__1,d__2);
d__1 = cab + sfmin;
lcab = (integer) (d_lg10(&d__1) / basl + 1.);
jc = (integer) (rscale[i__] + d_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_di(&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;
zdscal_(&i__2, &lscale[i__], &a[i__ + *ilo * a_dim1], lda);
i__2 = *n - *ilo + 1;
zdscal_(&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) {
zdscal_(ihi, &rscale[j], &a[j * a_dim1 + 1], &c__1);
zdscal_(ihi, &rscale[j], &b[j * b_dim1 + 1], &c__1);
/* L380: */
}
return 0;
/* End of ZGGBAL */
} /* zggbal_ */
/* ----------------------------------------------------------------------| */
/* Subroutine */ int zgexpv(integer *n, integer *m, doublereal *t,
doublecomplex *v, doublecomplex *w, doublereal *tol, doublereal *
anorm, doublecomplex *wsp, integer *lwsp, integer *iwsp, integer *
liwsp, S_fp matvec, void *matvecdata, integer *itrace, integer *iflag)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
complex q__1;
doublecomplex z__1;
/* Builtin functions */
/* Subroutine */ int s_stop(char *, ftnlen);
double sqrt(doublereal), d_sign(doublereal *, doublereal *), pow_di(
doublereal *, integer *), pow_dd(doublereal *, doublereal *),
d_lg10(doublereal *);
integer i_dnnt(doublereal *);
double d_int(doublereal *);
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle();
double z_abs(doublecomplex *);
/* Local variables */
static integer ibrkflag;
static doublereal step_min__, step_max__;
static integer i__, j;
static doublereal break_tol__;
static integer k1;
static doublereal p1, p2, p3;
static integer ih, mh, iv, ns, mx;
static doublereal xm;
static integer j1v;
static doublecomplex hij;
static doublereal sgn, eps, hj1j, sqr1, beta, hump;
static integer ifree, lfree;
static doublereal t_old__;
static integer iexph;
static doublereal t_new__;
static integer nexph;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal t_now__;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, ftnlen);
static integer nstep;
static doublereal t_out__;
static integer nmult;
static doublereal vnorm;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static integer nscale;
static doublereal rndoff;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), zgpadm_(integer *, integer *,
doublereal *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, integer *, integer *, integer *), znchbv_(
integer *, doublereal *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *);
static doublereal t_step__, avnorm;
static integer ireject;
static doublereal err_loc__;
static integer nreject, mbrkdwn;
static doublereal tbrkdwn, s_error__, x_error__;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 6, 0, 0, 0 };
static cilist io___48 = { 0, 6, 0, 0, 0 };
static cilist io___49 = { 0, 6, 0, 0, 0 };
static cilist io___50 = { 0, 6, 0, 0, 0 };
static cilist io___51 = { 0, 6, 0, 0, 0 };
static cilist io___52 = { 0, 6, 0, 0, 0 };
static cilist io___53 = { 0, 6, 0, 0, 0 };
static cilist io___54 = { 0, 6, 0, 0, 0 };
static cilist io___55 = { 0, 6, 0, 0, 0 };
static cilist io___56 = { 0, 6, 0, 0, 0 };
static cilist io___57 = { 0, 6, 0, 0, 0 };
static cilist io___58 = { 0, 6, 0, 0, 0 };
static cilist io___59 = { 0, 6, 0, 0, 0 };
/* -----Purpose----------------------------------------------------------| */
/* --- ZGEXPV computes w = exp(t*A)*v */
/* for a Zomplex (i.e., complex double precision) matrix A */
/* It does not compute the matrix exponential in isolation but */
/* instead, it computes directly the action of the exponential */
/* operator on the operand vector. This way of doing so allows */
/* for addressing large sparse problems. */
/* The method used is based on Krylov subspace projection */
/* techniques and the matrix under consideration interacts only */
/* via the external routine `matvec' performing the matrix-vector */
/* product (matrix-free method). */
/* -----Arguments--------------------------------------------------------| */
/* n : (input) order of the principal matrix A. */
/* m : (input) maximum size for the Krylov basis. */
/* t : (input) time at wich the solution is needed (can be < 0). */
/* v(n) : (input) given operand vector. */
/* w(n) : (output) computed approximation of exp(t*A)*v. */
/* tol : (input/output) the requested accuracy tolerance on w. */
/* If on input tol=0.0d0 or tol is too small (tol.le.eps) */
/* the internal value sqrt(eps) is used, and tol is set to */
/* sqrt(eps) on output (`eps' denotes the machine epsilon). */
/* (`Happy breakdown' is assumed if h(j+1,j) .le. anorm*tol) */
/* anorm : (input) an approximation of some norm of A. */
/* wsp(lwsp): (workspace) lwsp .ge. n*(m+1)+n+(m+2)^2+4*(m+2)^2+ideg+1 */
/* +---------+-------+---------------+ */
/* (actually, ideg=6) V H wsp for PADE */
/* iwsp(liwsp): (workspace) liwsp .ge. m+2 */
/* matvec : external subroutine for matrix-vector multiplication. */
/* synopsis: matvec( x, y ) */
/* complex*16 x(*), y(*) */
/* computes: y(1:n) <- A*x(1:n) */
/* where A is the principal matrix. */
/* itrace : (input) running mode. 0=silent, 1=print step-by-step info */
/* iflag : (output) exit flag. */
/* <0 - bad input arguments */
/* 0 - no problem */
/* 1 - maximum number of steps reached without convergence */
/* 2 - requested tolerance was too high */
/* -----Accounts on the computation--------------------------------------| */
/* Upon exit, an interested user may retrieve accounts on the */
/* computations. They are located in the workspace arrays wsp and */
/* iwsp as indicated below: */
/* location mnemonic description */
/* -----------------------------------------------------------------| */
/* iwsp(1) = nmult, number of matrix-vector multiplications used */
/* iwsp(2) = nexph, number of Hessenberg matrix exponential evaluated */
/* iwsp(3) = nscale, number of repeated squaring involved in Pade */
/* iwsp(4) = nstep, number of integration steps used up to completion */
/* iwsp(5) = nreject, number of rejected step-sizes */
/* iwsp(6) = ibrkflag, set to 1 if `happy breakdown' and 0 otherwise */
/* iwsp(7) = mbrkdwn, if `happy brkdown', basis-size when it occured */
/* -----------------------------------------------------------------| */
/* wsp(1) = step_min, minimum step-size used during integration */
/* wsp(2) = step_max, maximum step-size used during integration */
/* wsp(3) = x_round, maximum among all roundoff errors (lower bound) */
/* wsp(4) = s_round, sum of roundoff errors (lower bound) */
/* wsp(5) = x_error, maximum among all local truncation errors */
/* wsp(6) = s_error, global sum of local truncation errors */
/* wsp(7) = tbrkdwn, if `happy breakdown', time when it occured */
/* wsp(8) = t_now, integration domain successfully covered */
/* wsp(9) = hump, i.e., max||exp(sA)||, s in [0,t] (or [t,0] if t<0) */
/* wsp(10) = ||w||/||v||, scaled norm of the solution w. */
/* -----------------------------------------------------------------| */
/* The `hump' is a measure of the conditioning of the problem. The */
/* matrix exponential is well-conditioned if hump = 1, whereas it is */
/* poorly-conditioned if hump >> 1. However the solution can still be */
/* relatively fairly accurate even when the hump is large (the hump */
/* is an upper bound), especially when the hump and the scaled norm */
/* of w [this is also computed and returned in wsp(10)] are of the */
/* same order of magnitude (further details in reference below). */
/* ----------------------------------------------------------------------| */
/* -----The following parameters may also be adjusted herein-------------| */
/* mxstep : maximum allowable number of integration steps. */
/* The value 0 means an infinite number of steps. */
/* mxreject: maximum allowable number of rejections at each step. */
/* The value 0 means an infinite number of rejections. */
/* ideg : the Pade approximation of type (ideg,ideg) is used as */
/* an approximation to exp(H). The value 0 switches to the */
/* uniform rational Chebyshev approximation of type (14,14) */
/* delta : local truncation error `safety factor' */
/* gamma : stepsize `shrinking factor' */
/* ----------------------------------------------------------------------| */
/* Roger B. Sidje ([email protected]) */
/* EXPOKIT: Software Package for Computing Matrix Exponentials. */
/* ACM - Transactions On Mathematical Software, 24(1):130-156, 1998 */
/* ----------------------------------------------------------------------| */
/* --- check restrictions on input parameters ... */
/* Parameter adjustments */
--w;
--v;
--wsp;
--iwsp;
/* Function Body */
*iflag = 0;
/* Computing 2nd power */
i__1 = *m + 2;
if (*lwsp < *n * (*m + 2) + i__1 * i__1 * 5 + 7) {
*iflag = -1;
}
if (*liwsp < *m + 2) {
*iflag = -2;
}
if (*m >= *n || *m <= 0) {
*iflag = -3;
}
if (*iflag != 0) {
s_stop("bad sizes (in input of ZGEXPV)", (ftnlen)30);
}
/* --- initialisations ... */
k1 = 2;
mh = *m + 2;
iv = 1;
ih = iv + *n * (*m + 1) + *n;
ifree = ih + mh * mh;
lfree = *lwsp - ifree + 1;
ibrkflag = 0;
mbrkdwn = *m;
nmult = 0;
nreject = 0;
nexph = 0;
nscale = 0;
t_out__ = abs(*t);
tbrkdwn = 0.;
step_min__ = t_out__;
step_max__ = 0.;
nstep = 0;
s_error__ = 0.;
x_error__ = 0.;
t_now__ = 0.;
t_new__ = 0.;
p1 = 1.3333333333333333;
L1:
p2 = p1 - 1.;
p3 = p2 + p2 + p2;
eps = (d__1 = p3 - 1., abs(d__1));
if (eps == 0.) {
goto L1;
}
if (*tol <= eps) {
*tol = sqrt(eps);
}
rndoff = eps * *anorm;
break_tol__ = 1e-7;
/* >>> break_tol = tol */
/* >>> break_tol = anorm*tol */
sgn = d_sign(&c_b6, t);
zcopy_(n, &v[1], &c__1, &w[1], &c__1);
beta = dznrm2_(n, &w[1], &c__1);
vnorm = beta;
hump = beta;
/* --- obtain the very first stepsize ... */
sqr1 = sqrt(.1);
xm = 1. / (doublereal) (*m);
d__1 = (*m + 1) / 2.72;
i__1 = *m + 1;
p2 = *tol * pow_di(&d__1, &i__1) * sqrt((*m + 1) * 6.2800000000000002);
d__1 = p2 / (beta * 4. * *anorm);
t_new__ = 1. / *anorm * pow_dd(&d__1, &xm);
d__1 = d_lg10(&t_new__) - sqr1;
i__1 = i_dnnt(&d__1) - 1;
p1 = pow_di(&c_b10, &i__1);
d__1 = t_new__ / p1 + .55;
t_new__ = d_int(&d__1) * p1;
/* --- step-by-step integration ... */
L100:
if (t_now__ >= t_out__) {
goto L500;
}
++nstep;
/* Computing MIN */
d__1 = t_out__ - t_now__;
t_step__ = min(d__1,t_new__);
p1 = 1. / beta;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iv + i__ - 1;
i__3 = i__;
z__1.r = p1 * w[i__3].r, z__1.i = p1 * w[i__3].i;
wsp[i__2].r = z__1.r, wsp[i__2].i = z__1.i;
}
i__1 = mh * mh;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = ih + i__ - 1;
wsp[i__2].r = 0., wsp[i__2].i = 0.;
}
/* --- Arnoldi loop ... */
j1v = iv + *n;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
++nmult;
(*matvec)(matvecdata, &wsp[j1v - *n], &wsp[j1v]);
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
zdotc_(&z__1, n, &wsp[iv + (i__ - 1) * *n], &c__1, &wsp[j1v], &
c__1);
hij.r = z__1.r, hij.i = z__1.i;
z__1.r = -hij.r, z__1.i = -hij.i;
zaxpy_(n, &z__1, &wsp[iv + (i__ - 1) * *n], &c__1, &wsp[j1v], &
c__1);
i__3 = ih + (j - 1) * mh + i__ - 1;
wsp[i__3].r = hij.r, wsp[i__3].i = hij.i;
}
hj1j = dznrm2_(n, &wsp[j1v], &c__1);
/* --- if `happy breakdown' go straightforward at the end ... */
if (hj1j <= break_tol__) {
s_wsle(&io___40);
do_lio(&c__9, &c__1, "happy breakdown: mbrkdwn =", (ftnlen)26);
do_lio(&c__3, &c__1, (char *)&j, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, " h =", (ftnlen)4);
do_lio(&c__5, &c__1, (char *)&hj1j, (ftnlen)sizeof(doublereal));
e_wsle();
k1 = 0;
ibrkflag = 1;
mbrkdwn = j;
tbrkdwn = t_now__;
t_step__ = t_out__ - t_now__;
goto L300;
}
i__2 = ih + (j - 1) * mh + j;
q__1.r = hj1j, q__1.i = (float)0.;
wsp[i__2].r = q__1.r, wsp[i__2].i = q__1.i;
d__1 = 1. / hj1j;
zdscal_(n, &d__1, &wsp[j1v], &c__1);
j1v += *n;
/* L200: */
}
++nmult;
(*matvec)(matvecdata, &wsp[j1v - *n], &wsp[j1v]);
avnorm = dznrm2_(n, &wsp[j1v], &c__1);
/* --- set 1 for the 2-corrected scheme ... */
L300:
i__1 = ih + *m * mh + *m + 1;
wsp[i__1].r = 1., wsp[i__1].i = 0.;
/* --- loop while ireject<mxreject until the tolerance is reached ... */
ireject = 0;
L401:
/* --- compute w = beta*V*exp(t_step*H)*e1 ... */
++nexph;
mx = mbrkdwn + k1;
if (TRUE_) {
/* --- irreducible rational Pade approximation ... */
d__1 = sgn * t_step__;
zgpadm_(&c__6, &mx, &d__1, &wsp[ih], &mh, &wsp[ifree], &lfree, &iwsp[
1], &iexph, &ns, iflag);
iexph = ifree + iexph - 1;
nscale += ns;
} else {
/* --- uniform rational Chebyshev approximation ... */
iexph = ifree;
i__1 = mx;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iexph + i__ - 1;
wsp[i__2].r = 0., wsp[i__2].i = 0.;
}
i__1 = iexph;
wsp[i__1].r = 1., wsp[i__1].i = 0.;
d__1 = sgn * t_step__;
znchbv_(&mx, &d__1, &wsp[ih], &mh, &wsp[iexph], &wsp[ifree + mx]);
}
/* L402: */
/* --- error estimate ... */
if (k1 == 0) {
err_loc__ = *tol;
} else {
p1 = z_abs(&wsp[iexph + *m]) * beta;
p2 = z_abs(&wsp[iexph + *m + 1]) * beta * avnorm;
if (p1 > p2 * 10.) {
err_loc__ = p2;
xm = 1. / (doublereal) (*m);
} else if (p1 > p2) {
err_loc__ = p1 * p2 / (p1 - p2);
xm = 1. / (doublereal) (*m);
} else {
err_loc__ = p1;
xm = 1. / (doublereal) (*m - 1);
}
}
/* --- reject the step-size if the error is not acceptable ... */
if (k1 != 0 && err_loc__ > t_step__ * 1.2 * *tol) {
t_old__ = t_step__;
d__1 = t_step__ * *tol / err_loc__;
t_step__ = t_step__ * .9 * pow_dd(&d__1, &xm);
d__1 = d_lg10(&t_step__) - sqr1;
i__1 = i_dnnt(&d__1) - 1;
p1 = pow_di(&c_b10, &i__1);
d__1 = t_step__ / p1 + .55;
t_step__ = d_int(&d__1) * p1;
if (*itrace != 0) {
s_wsle(&io___48);
do_lio(&c__9, &c__1, "t_step =", (ftnlen)8);
do_lio(&c__5, &c__1, (char *)&t_old__, (ftnlen)sizeof(doublereal))
;
e_wsle();
s_wsle(&io___49);
do_lio(&c__9, &c__1, "err_loc =", (ftnlen)9);
do_lio(&c__5, &c__1, (char *)&err_loc__, (ftnlen)sizeof(
doublereal));
e_wsle();
s_wsle(&io___50);
do_lio(&c__9, &c__1, "err_required =", (ftnlen)14);
d__1 = t_old__ * 1.2 * *tol;
do_lio(&c__5, &c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsle();
s_wsle(&io___51);
do_lio(&c__9, &c__1, "stepsize rejected, stepping down to:", (
ftnlen)36);
do_lio(&c__5, &c__1, (char *)&t_step__, (ftnlen)sizeof(doublereal)
);
e_wsle();
}
++ireject;
++nreject;
if (FALSE_) {
s_wsle(&io___52);
do_lio(&c__9, &c__1, "Failure in ZGEXPV: ---", (ftnlen)22);
e_wsle();
s_wsle(&io___53);
do_lio(&c__9, &c__1, "The requested tolerance is too high.", (
ftnlen)36);
e_wsle();
s_wsle(&io___54);
do_lio(&c__9, &c__1, "Rerun with a smaller value.", (ftnlen)27);
e_wsle();
*iflag = 2;
return 0;
}
goto L401;
}
/* --- now update w = beta*V*exp(t_step*H)*e1 and the hump ... */
/* Computing MAX */
i__1 = 0, i__2 = k1 - 1;
mx = mbrkdwn + max(i__1,i__2);
q__1.r = beta, q__1.i = (float)0.;
hij.r = q__1.r, hij.i = q__1.i;
zgemv_("n", n, &mx, &hij, &wsp[iv], n, &wsp[iexph], &c__1, &c_b1, &w[1], &
c__1, (ftnlen)1);
beta = dznrm2_(n, &w[1], &c__1);
hump = max(hump,beta);
/* --- suggested value for the next stepsize ... */
d__1 = t_step__ * *tol / err_loc__;
t_new__ = t_step__ * .9 * pow_dd(&d__1, &xm);
d__1 = d_lg10(&t_new__) - sqr1;
i__1 = i_dnnt(&d__1) - 1;
p1 = pow_di(&c_b10, &i__1);
d__1 = t_new__ / p1 + .55;
t_new__ = d_int(&d__1) * p1;
err_loc__ = max(err_loc__,rndoff);
/* --- update the time covered ... */
t_now__ += t_step__;
/* --- display and keep some information ... */
if (*itrace != 0) {
s_wsle(&io___55);
do_lio(&c__9, &c__1, "integration", (ftnlen)11);
do_lio(&c__3, &c__1, (char *)&nstep, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, "---------------------------------", (ftnlen)33);
e_wsle();
s_wsle(&io___56);
do_lio(&c__9, &c__1, "scale-square =", (ftnlen)14);
do_lio(&c__3, &c__1, (char *)&ns, (ftnlen)sizeof(integer));
e_wsle();
s_wsle(&io___57);
do_lio(&c__9, &c__1, "step_size =", (ftnlen)11);
do_lio(&c__5, &c__1, (char *)&t_step__, (ftnlen)sizeof(doublereal));
e_wsle();
s_wsle(&io___58);
do_lio(&c__9, &c__1, "err_loc =", (ftnlen)11);
do_lio(&c__5, &c__1, (char *)&err_loc__, (ftnlen)sizeof(doublereal));
e_wsle();
s_wsle(&io___59);
do_lio(&c__9, &c__1, "next_step =", (ftnlen)11);
do_lio(&c__5, &c__1, (char *)&t_new__, (ftnlen)sizeof(doublereal));
e_wsle();
}
step_min__ = min(step_min__,t_step__);
step_max__ = max(step_max__,t_step__);
s_error__ += err_loc__;
x_error__ = max(x_error__,err_loc__);
if (nstep < 500) {
goto L100;
}
*iflag = 1;
L500:
iwsp[1] = nmult;
iwsp[2] = nexph;
iwsp[3] = nscale;
iwsp[4] = nstep;
iwsp[5] = nreject;
iwsp[6] = ibrkflag;
iwsp[7] = mbrkdwn;
q__1.r = step_min__, q__1.i = (float)0.;
wsp[1].r = q__1.r, wsp[1].i = q__1.i;
q__1.r = step_max__, q__1.i = (float)0.;
wsp[2].r = q__1.r, wsp[2].i = q__1.i;
wsp[3].r = (float)0., wsp[3].i = (float)0.;
wsp[4].r = (float)0., wsp[4].i = (float)0.;
q__1.r = x_error__, q__1.i = (float)0.;
wsp[5].r = q__1.r, wsp[5].i = q__1.i;
q__1.r = s_error__, q__1.i = (float)0.;
wsp[6].r = q__1.r, wsp[6].i = q__1.i;
q__1.r = tbrkdwn, q__1.i = (float)0.;
wsp[7].r = q__1.r, wsp[7].i = q__1.i;
d__1 = sgn * t_now__;
q__1.r = d__1, q__1.i = (float)0.;
wsp[8].r = q__1.r, wsp[8].i = q__1.i;
d__1 = hump / vnorm;
q__1.r = d__1, q__1.i = (float)0.;
wsp[9].r = q__1.r, wsp[9].i = q__1.i;
d__1 = beta / vnorm;
q__1.r = d__1, q__1.i = (float)0.;
wsp[10].r = q__1.r, wsp[10].i = q__1.i;
return 0;
} /* zgexpv_ */
/* DECK DCOEF */
/* Subroutine */ int dcoef_(doublereal *yh, doublereal *yp, integer *ncomp,
integer *nrowb, integer *nfc, integer *nic, doublereal *b, doublereal
*beta, doublereal *coef, integer *inhomo, doublereal *re, doublereal *
ae, doublereal *by, doublereal *cvec, doublereal *work, integer *
iwork, integer *iflag, integer *nfcc)
{
/* System generated locals */
integer b_dim1, b_offset, by_dim1, by_offset, yh_dim1, yh_offset, i__1,
i__2;
doublereal d__1, d__2, d__3;
/* Local variables */
static integer i__, j, k, l;
static doublereal bn;
static integer ki, nf;
static doublereal un, bbn, gam, brn, bys, ypn;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal bykl, cons;
static integer mlso, kflag;
extern /* Subroutine */ int xgetf_(integer *), dsuds_(doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *,
integer *, integer *, doublereal *, integer *), xsetf_(integer *);
static integer nfccm1, ncomp2;
/* ***BEGIN PROLOGUE DCOEF */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DBVSUP */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (SCOEF-S, DCOEF-D) */
/* ***AUTHOR Watts, H. A., (SNLA) */
/* ***DESCRIPTION */
/* ********************************************************************** */
/* INPUT to DCOEF */
/* ********************************************************************** */
/* YH = matrix of homogeneous solutions. */
/* YP = vector containing particular solution. */
/* NCOMP = number of components per solution vector. */
/* NROWB = first dimension of B in calling program. */
/* NFC = number of base solution vectors. */
/* NFCC = 2*NFC for the special treatment of COMPLEX*16 valued */
/* equations. Otherwise, NFCC=NFC. */
/* NIC = number of specified initial conditions. */
/* B = boundary condition matrix at X = XFINAL. */
/* BETA = vector of nonhomogeneous boundary conditions at X = XFINAL. */
/* 1 - nonzero particular solution */
/* INHOMO = 2 - zero particular solution */
/* 3 - eigenvalue problem */
/* RE = relative error tolerance. */
/* AE = absolute error tolerance. */
/* BY = storage space for the matrix B*YH */
/* CVEC = storage space for the vector BETA-B*YP */
/* WORK = double precision array of internal storage. Dimension must */
/* be GE */
/* NFCC*(NFCC+4) */
/* IWORK = integer array of internal storage. Dimension must be GE */
/* 3+NFCC */
/* ********************************************************************** */
/* OUTPUT from DCOEF */
/* ********************************************************************** */
/* COEF = array containing superposition constants. */
/* IFLAG = indicator of success from DSUDS in solving the */
/* boundary equations. */
/* = 0 boundary equations are solved. */
/* = 1 boundary equations appear to have many solutions. */
/* = 2 boundary equations appear to be inconsistent. */
/* = 3 for this value of an eigenparameter, the boundary */
/* equations have only the zero solution. */
/* ********************************************************************** */
/* Subroutine DCOEF solves for the superposition constants from the */
/* linear equations defined by the boundary conditions at X = XFINAL. */
/* B*YP + B*YH*COEF = BETA */
/* ********************************************************************** */
/* ***SEE ALSO DBVSUP */
/* ***ROUTINES CALLED DDOT, DSUDS, XGETF, XSETF */
/* ***COMMON BLOCKS DML5MC */
/* ***REVISION HISTORY (YYMMDD) */
/* 750601 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 890921 Realigned order of variables in certain COMMON blocks. */
/* (WRB) */
/* 890921 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* 910722 Updated AUTHOR section. (ALS) */
/* ***END PROLOGUE DCOEF */
/* ***FIRST EXECUTABLE STATEMENT DCOEF */
/* SET UP MATRIX B*YH AND VECTOR BETA - B*YP */
/* Parameter adjustments */
--yp;
yh_dim1 = *ncomp;
yh_offset = 1 + yh_dim1;
yh -= yh_offset;
b_dim1 = *nrowb;
b_offset = 1 + b_dim1;
b -= b_offset;
--beta;
--coef;
--cvec;
--work;
--iwork;
by_dim1 = *nfcc;
by_offset = 1 + by_dim1;
by -= by_offset;
/* Function Body */
ncomp2 = *ncomp / 2;
i__1 = *nfcc;
for (k = 1; k <= i__1; ++k) {
i__2 = *nfc;
for (j = 1; j <= i__2; ++j) {
l = j;
if (*nfc != *nfcc) {
l = (j << 1) - 1;
}
by[k + l * by_dim1] = ddot_(ncomp, &b[k + b_dim1], nrowb, &yh[j *
yh_dim1 + 1], &c__1);
/* L10: */
}
if (*nfc == *nfcc) {
goto L30;
}
i__2 = *nfc;
for (j = 1; j <= i__2; ++j) {
l = j << 1;
bykl = ddot_(&ncomp2, &b[k + b_dim1], nrowb, &yh[ncomp2 + 1 + j *
yh_dim1], &c__1);
by[k + l * by_dim1] = ddot_(&ncomp2, &b[k + (ncomp2 + 1) * b_dim1]
, nrowb, &yh[j * yh_dim1 + 1], &c__1) - bykl;
/* L20: */
}
L30:
switch (*inhomo) {
case 1: goto L40;
case 2: goto L50;
case 3: goto L60;
}
/* CASE 1 */
L40:
cvec[k] = beta[k] - ddot_(ncomp, &b[k + b_dim1], nrowb, &yp[1], &c__1)
;
goto L70;
/* CASE 2 */
L50:
cvec[k] = beta[k];
goto L70;
/* CASE 3 */
L60:
cvec[k] = 0.;
L70:
/* L80: */
;
}
cons = abs(cvec[1]);
bys = (d__1 = by[by_dim1 + 1], abs(d__1));
/* ****************************************************************** */
/* SOLVE LINEAR SYSTEM */
*iflag = 0;
mlso = 0;
if (*inhomo == 3) {
mlso = 1;
}
kflag = (integer) (d_lg10(&dml5mc_1.eps) * .5);
xgetf_(&nf);
xsetf_(&c__0);
L90:
dsuds_(&by[by_offset], &coef[1], &cvec[1], nfcc, nfcc, nfcc, &kflag, &
mlso, &work[1], &iwork[1]);
if (kflag != 3) {
goto L100;
}
kflag = 1;
*iflag = 1;
goto L90;
L100:
if (kflag == 4) {
*iflag = 2;
}
xsetf_(&nf);
if (*nfcc == 1) {
goto L180;
}
if (*inhomo != 3) {
goto L170;
}
if (iwork[1] < *nfcc) {
goto L140;
}
*iflag = 3;
i__1 = *nfcc;
for (k = 1; k <= i__1; ++k) {
coef[k] = 0.;
/* L110: */
}
coef[*nfcc] = 1.;
nfccm1 = *nfcc - 1;
i__1 = nfccm1;
for (k = 1; k <= i__1; ++k) {
j = *nfcc - k;
l = *nfcc - j + 1;
gam = ddot_(&l, &by[j + j * by_dim1], nfcc, &coef[j], &c__1) / (work[
j] * by[j + j * by_dim1]);
i__2 = *nfcc;
for (i__ = j; i__ <= i__2; ++i__) {
coef[i__] += gam * by[j + i__ * by_dim1];
/* L120: */
}
/* L130: */
}
goto L160;
L140:
i__1 = *nfcc;
for (k = 1; k <= i__1; ++k) {
ki = (*nfcc << 2) + k;
coef[k] = work[ki];
/* L150: */
}
L160:
L170:
goto L220;
L180:
/* *************************************************************** */
/* TESTING FOR EXISTENCE AND UNIQUENESS OF BOUNDARY-VALUE */
/* PROBLEM SOLUTION IN A SCALAR CASE */
bn = 0.;
un = 0.;
ypn = 0.;
i__1 = *ncomp;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__2 = un, d__3 = (d__1 = yh[k + yh_dim1], abs(d__1));
un = max(d__2,d__3);
/* Computing MAX */
d__2 = ypn, d__3 = (d__1 = yp[k], abs(d__1));
ypn = max(d__2,d__3);
/* Computing MAX */
d__2 = bn, d__3 = (d__1 = b[k * b_dim1 + 1], abs(d__1));
bn = max(d__2,d__3);
/* L190: */
}
/* Computing MAX */
d__1 = bn, d__2 = abs(beta[1]);
bbn = max(d__1,d__2);
if (bys > (*re * un + *ae) * 10. * bn) {
goto L200;
}
brn = bbn / bn * bys;
if (cons >= brn * .1 && cons <= brn * 10.) {
*iflag = 1;
}
if (cons > brn * 10.) {
*iflag = 2;
}
if (cons <= *re * abs(beta[1]) + *ae + (*re * ypn + *ae) * bn) {
*iflag = 1;
}
if (*inhomo == 3) {
coef[1] = 1.;
}
goto L210;
L200:
if (*inhomo != 3) {
goto L210;
}
*iflag = 3;
coef[1] = 1.;
L210:
L220:
return 0;
} /* dcoef_ */
/* Subroutine */ int ok_odex_odxcor_(integer *n, S_fp fcn, doublereal *x, doublereal *
y, doublereal *xend, doublereal *hmax, doublereal *h__, doublereal *
rtol, doublereal *atol, integer *itol, integer *km,
integer *iout, integer *idid, integer *nmax, doublereal *uround,
doublereal *dy, doublereal *yh1, doublereal *yh2, doublereal *dz,
doublereal *scal, doublereal *fsafe, doublereal *ysafe, doublereal *t,
doublereal *hh, doublereal *w, doublereal *a, doublereal *dens,
integer *ncom, integer *icomp, integer *nj, integer *ipoint, integer *
nsequ, integer *mstab, integer *jstab, integer *lfsafe, doublereal *
safe1, doublereal *safe2, doublereal *safe3, doublereal *fac1,
doublereal *fac2, doublereal *fac3, doublereal *fac4, integer *iderr,
doublereal *errfac, integer *mudif, integer *nrd, integer *nfcn, integer *nstep, integer *naccpt,
integer *nrejct, void* params)
{
/* Format strings */
static char fmt_979[] = "(\002 EXIT OF ODEX AT X=\002,d14.7,\002 H="
"\002,d14.7)";
/* System generated locals */
integer t_dim1, t_offset, fsafe_dim1, fsafe_offset, ysafe_dim1,
ysafe_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double d_sign(doublereal *, doublereal *), d_lg10(doublereal *), sqrt(
doublereal), pow_di(doublereal *, integer *), pow_dd(doublereal *,
doublereal *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, k, l, kc, kk, mu;
doublereal fac;
real hhh;
integer kmi, kln;
doublereal err;
integer krn, ipt, kbeg, lbeg, lend;
logical last;
integer kmit;
doublereal prod;
logical atov;
doublereal xold;
integer kopt;
doublereal errx;
integer njadd;
doublereal facnj;
real xoldd;
integer irtrn;
doublereal dblenj;
logical reject;
doublereal factor, hoptde, errold, posneg;
doublereal errint;
/* Fortran I/O blocks */
static cilist io___91 = { 0, 6, 0, fmt_979, 0 };
/* ---------------------------------------------------------- */
/* CORE INTEGRATOR FOR ODEX */
/* PARAMETERS SAME AS IN ODEX WITH WORKSPACE ADDED */
/* ---------------------------------------------------------- */
/* DECLARATIONS */
/* ---------------------------------------------------------- */
/* --- DEFINE THE STEP SIZE SEQUENCE */
/* Parameter adjustments */
--scal;
--dz;
--yh2;
--yh1;
--dy;
--y;
--rtol;
--atol;
--errfac;
--ipoint;
--nj;
--a;
--w;
--hh;
t_dim1 = *km;
t_offset = 1 + t_dim1;
t -= t_offset;
--dens;
--icomp;
ysafe_dim1 = *km;
ysafe_offset = 1 + ysafe_dim1;
ysafe -= ysafe_offset;
fsafe_dim1 = *lfsafe;
fsafe_offset = 1 + fsafe_dim1;
fsafe -= fsafe_offset;
/* Function Body */
if (*nsequ == 1) {
i__1 = *km;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L1: */
nj[i__] = i__ << 1;
}
}
if (*nsequ == 2) {
nj[1] = 2;
i__1 = *km;
for (i__ = 2; i__ <= i__1; ++i__) {
/* L2: */
nj[i__] = (i__ << 2) - 4;
}
}
if (*nsequ == 3) {
nj[1] = 2;
nj[2] = 4;
nj[3] = 6;
i__1 = *km;
for (i__ = 4; i__ <= i__1; ++i__) {
/* L11: */
nj[i__] = nj[i__ - 2] << 1;
}
}
if (*nsequ == 4) {
i__1 = *km;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L3: */
nj[i__] = (i__ << 2) - 2;
}
}
if (*nsequ == 5) {
i__1 = *km;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L6: */
nj[i__] = i__ << 2;
}
}
/* --- DEFINE THE A(I) FOR ORDER SELECTION */
a[1] = nj[1] + 1.;
i__1 = *km;
for (i__ = 2; i__ <= i__1; ++i__) {
/* L4: */
a[i__] = a[i__ - 1] + nj[i__];
}
/* --- INITIAL SCALING */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*itol == 0) {
scal[i__] = atol[1] + rtol[1] * (d__1 = y[i__], abs(d__1));
} else {
scal[i__] = atol[i__] + rtol[i__] * (d__1 = y[i__], abs(d__1));
}
/* L8: */
}
/* --- INITIAL PREPARATIONS */
d__1 = *xend - *x;
posneg = d_sign(&c_b67, &d__1);
/* Computing MAX */
/* Computing MIN */
d__1 = rtol[1] + 1e-40;
i__3 = *km - 1, i__4 = (integer) (-d_lg10(&d__1) * .6 + 1.5);
i__1 = 2, i__2 = min(i__3,i__4);
k = max(i__1,i__2);
*hmax = abs(*hmax);
/* Computing MAX */
d__1 = abs(*h__);
*h__ = max(d__1,1e-4);
/* Computing MIN */
d__2 = min(*h__,*hmax), d__3 = (d__1 = *xend - *x, abs(d__1)) / 2.;
*h__ = posneg * min(d__2,d__3);
if (*iout >= 1) {
if (*iout >= 2) {
ipoint[1] = 0;
i__1 = *km;
for (i__ = 1; i__ <= i__1; ++i__) {
njadd = (i__ << 2) - 2;
if (nj[i__] > njadd) {
++njadd;
}
/* L5: */
ipoint[i__ + 1] = ipoint[i__] + njadd;
}
i__1 = *km << 1;
for (mu = 1; mu <= i__1; ++mu) {
errx = sqrt(mu / (mu + 4.)) * .5;
/* Computing 2nd power */
d__1 = mu + 4.;
prod = 1. / (d__1 * d__1);
i__2 = mu;
for (j = 1; j <= i__2; ++j) {
/* L7: */
prod = prod * errx / j;
}
/* L9: */
errfac[mu] = prod;
}
ipt = 0;
}
irtrn = 0;
xold = *x;
i__1 = *naccpt + 1;
if (irtrn < 0) {
goto L120;
}
}
err = 0.;
errold = 1e10;
hoptde = posneg * *hmax;
w[1] = 0.;
reject = FALSE_;
last = FALSE_;
L10:
atov = FALSE_;
/* --- IS XEND REACHED IN THE NEXT STEP? */
if ((d__1 = *xend - *x, abs(d__1)) * .1 <= abs(*x) * *uround) {
goto L110;
}
/* Computing MIN */
d__2 = abs(*h__), d__3 = (d__1 = *xend - *x, abs(d__1)), d__2 = min(d__2,
d__3), d__2 = min(d__2,*hmax), d__3 = abs(hoptde);
*h__ = posneg * min(d__2,d__3);
if ((*x + *h__ * 1.01 - *xend) * posneg > 0.) {
*h__ = *xend - *x;
last = TRUE_;
}
if (*nstep == 0 || *iout != 2) {
(*fcn)(*x, &y[1], &dz[1], params);
}
++(*nfcn);
/* --- THE FIRST AND LAST STEP */
if (*nstep == 0 || last) {
ipt = 0;
++(*nstep);
i__1 = k;
for (j = 1; j <= i__1; ++j) {
kc = j;
ok_odex_midex_(&j, x, &y[1], h__, hmax, n, (S_fp)fcn, &dy[1], &yh1[1], &
yh2[1], &dz[1], &t[t_offset], &nj[1], &hh[1], &w[1], &err,
&fac, &a[1], safe1, uround, fac1, fac2, safe2, &scal[1],
&atov, safe3, &reject, km, &rtol[1], &atol[1], itol,
mstab, jstab, &errold, &fsafe[fsafe_offset], lfsafe, iout,
&ipt, &ysafe[ysafe_offset], &icomp[1], nrd, nfcn, params);
if (atov) {
goto L10;
}
/* L20: */
if (j > 1 && err <= 1.) {
goto L60;
}
}
goto L55;
}
/* --- BASIC INTEGRATION STEP */
L30:
ipt = 0;
++(*nstep);
if (*nstep >= *nmax) {
goto L120;
}
kc = k - 1;
i__1 = kc;
for (j = 1; j <= i__1; ++j) {
ok_odex_midex_(&j, x, &y[1], h__, hmax, n, (S_fp)fcn, &dy[1], &yh1[1], &yh2[1]
, &dz[1], &t[t_offset], &nj[1], &hh[1], &w[1], &err, &fac, &a[
1], safe1, uround, fac1, fac2, safe2, &scal[1], &atov, safe3,
&reject, km, &rtol[1], &atol[1], itol, mstab, jstab, &errold,
&fsafe[fsafe_offset], lfsafe, iout, &ipt, &ysafe[ysafe_offset]
, &icomp[1], nrd, nfcn, params);
if (atov) {
goto L10;
}
/* L40: */
}
/* --- CONVERGENCE MONITOR */
if (k == 2 || reject) {
goto L50;
}
if (err <= 1.) {
goto L60;
}
/* Computing 2nd power */
d__1 = nj[k + 1] * nj[k] / 4.;
if (err > d__1 * d__1) {
goto L100;
}
L50:
ok_odex_midex_(&k, x, &y[1], h__, hmax, n, (S_fp)fcn, &dy[1], &yh1[1], &yh2[1], &
dz[1], &t[t_offset], &nj[1], &hh[1], &w[1], &err, &fac, &a[1],
safe1, uround, fac1, fac2, safe2, &scal[1], &atov, safe3, &reject,
km, &rtol[1], &atol[1], itol, mstab, jstab, &errold, &fsafe[
fsafe_offset], lfsafe, iout, &ipt, &ysafe[ysafe_offset], &icomp[1]
, nrd, nfcn, params);
if (atov) {
goto L10;
}
kc = k;
if (err <= 1.) {
goto L60;
}
/* --- HOPE FOR CONVERGENCE IN LINE K+1 */
L55:
/* Computing 2nd power */
d__1 = nj[k + 1] / 2.;
if (err > d__1 * d__1) {
goto L100;
}
kc = k + 1;
ok_odex_midex_(&kc, x, &y[1], h__, hmax, n, (S_fp)fcn, &dy[1], &yh1[1], &yh2[1], &
dz[1], &t[t_offset], &nj[1], &hh[1], &w[1], &err, &fac, &a[1],
safe1, uround, fac1, fac2, safe2, &scal[1], &atov, safe3, &reject,
km, &rtol[1], &atol[1], itol, mstab, jstab, &errold, &fsafe[
fsafe_offset], lfsafe, iout, &ipt, &ysafe[ysafe_offset], &icomp[1]
, nrd, nfcn, params);
if (atov) {
goto L10;
}
if (err > 1.) {
goto L100;
}
/* --- STEP IS ACCEPTED */
L60:
xold = *x;
*x += *h__;
if (*iout >= 2) {
/* --- KMIT = MU OF THE PAPER */
kmit = (kc << 1) - *mudif + 1;
i__1 = *nrd;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L69: */
dens[i__] = y[icomp[i__]];
}
xoldd = xold;
hhh = *h__;
i__1 = *nrd;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L76: */
dens[*nrd + i__] = *h__ * dz[icomp[i__]];
}
kln = *nrd << 1;
i__1 = *nrd;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L176: */
dens[kln + i__] = t[icomp[i__] * t_dim1 + 1];
}
/* --- COMPUTE SOLUTION AT MID-POINT ---- */
i__1 = kc;
for (j = 2; j <= i__1; ++j) {
dblenj = (doublereal) nj[j];
for (l = j; l >= 2; --l) {
/* Computing 2nd power */
d__1 = dblenj / nj[l - 1];
factor = d__1 * d__1 - 1.;
i__2 = *nrd;
for (i__ = 1; i__ <= i__2; ++i__) {
ysafe[l - 1 + i__ * ysafe_dim1] = ysafe[l + i__ *
ysafe_dim1] + (ysafe[l + i__ * ysafe_dim1] -
ysafe[l - 1 + i__ * ysafe_dim1]) / factor;
/* L473: */
}
}
}
krn = *nrd << 2;
i__2 = *nrd;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L474: */
dens[krn + i__] = ysafe[i__ * ysafe_dim1 + 1];
}
/* --- COMPUTE FIRST DERIVATIVE AT RIGHT END ---- */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L478: */
yh1[i__] = t[i__ * t_dim1 + 1];
}
(*fcn)(*x, &yh1[1], &yh2[1], params);
krn = *nrd * 3;
i__2 = *nrd;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L274: */
dens[krn + i__] = yh2[icomp[i__]] * *h__;
}
/* --- THE LOOP --- */
i__2 = kmit;
for (kmi = 1; kmi <= i__2; ++kmi) {
/* --- COMPUTE KMI-TH DERIVATIVE AT MID-POINT ---- */
kbeg = (kmi + 1) / 2;
i__1 = kc;
for (kk = kbeg; kk <= i__1; ++kk) {
d__1 = nj[kk] / 2.;
i__3 = kmi - 1;
facnj = pow_di(&d__1, &i__3);
ipt = ipoint[kk + 1] - (kk << 1) + kmi;
i__3 = *nrd;
for (i__ = 1; i__ <= i__3; ++i__) {
/* L371: */
ysafe[kk + i__ * ysafe_dim1] = fsafe[ipt + i__ *
fsafe_dim1] * facnj;
}
/* L375: */
}
i__1 = kc;
for (j = kbeg + 1; j <= i__1; ++j) {
dblenj = (doublereal) nj[j];
i__3 = kbeg + 1;
for (l = j; l >= i__3; --l) {
/* Computing 2nd power */
d__1 = dblenj / nj[l - 1];
factor = d__1 * d__1 - 1.;
i__4 = *nrd;
for (i__ = 1; i__ <= i__4; ++i__) {
ysafe[l - 1 + i__ * ysafe_dim1] = ysafe[l + i__ *
ysafe_dim1] + (ysafe[l + i__ * ysafe_dim1] -
ysafe[l - 1 + i__ * ysafe_dim1]) / factor;
/* L373: */
}
}
}
krn = (kmi + 4) * *nrd;
i__4 = *nrd;
for (i__ = 1; i__ <= i__4; ++i__) {
/* L374: */
dens[krn + i__] = ysafe[kbeg + i__ * ysafe_dim1] * *h__;
}
if (kmi == kmit) {
goto L180;
}
/* --- COMPUTE DIFFERENCES */
i__4 = kc;
for (kk = (kmi + 2) / 2; kk <= i__4; ++kk) {
lbeg = ipoint[kk + 1];
lend = ipoint[kk] + kmi + 1;
if (kmi == 1 && *nsequ == 4) {
lend += 2;
}
i__3 = lend;
for (l = lbeg; l >= i__3; l += -2) {
i__1 = *nrd;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L64: */
fsafe[l + i__ * fsafe_dim1] -= fsafe[l - 2 + i__ *
fsafe_dim1];
}
}
if (kmi == 1 && *nsequ == 4) {
l = lend - 2;
i__1 = *nrd;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L65: */
fsafe[l + i__ * fsafe_dim1] -= dz[icomp[i__]];
}
}
/* L66: */
}
/* --- COMPUTE DIFFERENCES */
i__4 = kc;
for (kk = (kmi + 2) / 2; kk <= i__4; ++kk) {
lbeg = ipoint[kk + 1] - 1;
lend = ipoint[kk] + kmi + 2;
i__1 = lend;
for (l = lbeg; l >= i__1; l += -2) {
i__3 = *nrd;
for (i__ = 1; i__ <= i__3; ++i__) {
/* L164: */
fsafe[l + i__ * fsafe_dim1] -= fsafe[l - 2 + i__ *
fsafe_dim1];
}
}
/* L166: */
}
L180:
;
}
ok_odex_interp_(*nrd, &dens[1], kmit);
/* --- ESTIMATION OF INTERPOLATION ERROR */
if (*iderr == 0 && kmit >= 1) {
errint = 0.;
i__2 = *nrd;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L187: */
/* Computing 2nd power */
d__1 = dens[(kmit + 4) * *nrd + i__] / scal[icomp[i__]];
errint += d__1 * d__1;
}
errint = sqrt(errint / *nrd) * errfac[kmit];
/* Computing MAX */
d__2 = 1. / (kmit + 4);
d__1 = pow_dd(&errint, &d__2);
hoptde = *h__ / max(d__1,.01);
if (errint > 10.) {
*h__ = hoptde;
*x = xold;
++(*nrejct);
reject = TRUE_;
goto L10;
}
}
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L189: */
dz[i__] = yh2[i__];
}
}
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L70: */
y[i__] = t[i__ * t_dim1 + 1];
}
++(*naccpt);
if (*iout >= 1) {
i__2 = *naccpt + 1;
if (irtrn < 0) {
goto L120;
}
}
/* --- COMPUTE OPTIMAL ORDER */
if (kc == 2) {
/* Computing MIN */
i__2 = 3, i__4 = *km - 1;
kopt = min(i__2,i__4);
if (reject) {
kopt = 2;
}
goto L80;
}
if (kc <= k) {
kopt = kc;
if (w[kc - 1] < w[kc] * *fac3) {
kopt = kc - 1;
}
if (w[kc] < w[kc - 1] * *fac4) {
/* Computing MIN */
i__2 = kc + 1, i__4 = *km - 1;
kopt = min(i__2,i__4);
}
} else {
kopt = kc - 1;
if (kc > 3 && w[kc - 2] < w[kc - 1] * *fac3) {
kopt = kc - 2;
}
if (w[kc] < w[kopt] * *fac4) {
/* Computing MIN */
i__2 = kc, i__4 = *km - 1;
kopt = min(i__2,i__4);
}
}
/* --- AFTER A REJECTED STEP */
L80:
if (reject) {
k = min(kopt,kc);
/* Computing MIN */
d__2 = abs(*h__), d__3 = (d__1 = hh[k], abs(d__1));
*h__ = posneg * min(d__2,d__3);
reject = FALSE_;
goto L10;
}
/* --- COMPUTE STEPSIZE FOR NEXT STEP */
if (kopt <= kc) {
*h__ = hh[kopt];
} else {
if (kc < k && w[kc] < w[kc - 1] * *fac4) {
*h__ = hh[kc] * a[kopt + 1] / a[kc];
} else {
*h__ = hh[kc] * a[kopt] / a[kc];
}
}
k = kopt;
*h__ = posneg * abs(*h__);
goto L10;
/* --- STEP IS REJECTED */
L100:
/* Computing MIN */
i__2 = min(k,kc), i__4 = *km - 1;
k = min(i__2,i__4);
if (k > 2 && w[k - 1] < w[k] * *fac3) {
--k;
}
++(*nrejct);
*h__ = posneg * hh[k];
reject = TRUE_;
goto L30;
/* --- SOLUTION EXIT */
L110:
*idid = 1;
return 0;
/* --- FAIL EXIT */
L120:
s_wsfe(&io___91);
do_fio(&c__1, (char *)&(*x), (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&(*h__), (ftnlen)sizeof(doublereal));
e_wsfe();
*idid = -1;
return 0;
} /* odxcor_ */
/* Subroutine */ int zggbal_(char *job, integer *n, doublecomplex *a, integer
*lda, doublecomplex *b, integer *ldb, integer *ilo, integer *ihi,
doublereal *lscale, doublereal *rscale, doublereal *work, integer *
info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZGGBAL 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*16 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*16 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b35 = 10.;
static doublereal c_b71 = .5;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double d_lg10(doublereal *), d_imag(doublecomplex *), z_abs(doublecomplex
*), d_sign(doublereal *, doublereal *), pow_di(doublereal *,
integer *);
/* Local variables */
static integer lcab;
static doublereal beta, coef;
static integer irab, lrab;
static doublereal basl, cmax;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal coef2, coef5;
static integer i, j, k, l, m;
static doublereal gamma, t, alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
static doublereal sfmin, sfmax;
static integer iflow;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static integer kount;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static integer jc;
static doublereal ta, tb, tc;
extern doublereal dlamch_(char *);
static integer ir, it;
static doublereal ew;
static integer nr;
static doublereal pgamma;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
static integer lsfmin;
extern integer izamax_(integer *, doublecomplex *, integer *);
static integer lsfmax, ip1, jp1, lm1;
static doublereal cab, rab, ewc, cor, sum;
static integer nrp2, icab;
#define LSCALE(I) lscale[(I)-1]
#define RSCALE(I) rscale[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
*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_("ZGGBAL", &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 <= *n; ++i) {
LSCALE(i) = 1.;
RSCALE(i) = 1.;
/* L10: */
}
return 0;
}
if (k == l) {
*ilo = 1;
*ihi = 1;
LSCALE(1) = 1.;
RSCALE(1) = 1.;
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.;
LSCALE(1) = 1.;
goto L190;
L30:
lm1 = l - 1;
for (i = l; i >= 1; --i) {
i__1 = lm1;
for (j = 1; j <= lm1; ++j) {
jp1 = j + 1;
i__2 = i + j * a_dim1;
i__3 = i + j * b_dim1;
if (A(i,j).r != 0. || A(i,j).i != 0. || (B(i,j).r != 0. || B(i,j).i != 0.)) {
goto L50;
}
/* L40: */
}
j = l;
goto L70;
L50:
i__1 = l;
for (j = jp1; j <= l; ++j) {
i__2 = i + j * a_dim1;
i__3 = i + j * b_dim1;
if (A(i,j).r != 0. || A(i,j).i != 0. || (B(i,j).r != 0. || B(i,j).i != 0.)) {
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 <= l; ++j) {
i__2 = lm1;
for (i = k; i <= lm1; ++i) {
ip1 = i + 1;
i__3 = i + j * a_dim1;
i__4 = i + j * b_dim1;
if (A(i,j).r != 0. || A(i,j).i != 0. || (B(i,j).r != 0. || B(i,j).i != 0.)) {
goto L120;
}
/* L110: */
}
i = l;
goto L140;
L120:
i__2 = l;
for (i = ip1; i <= l; ++i) {
i__3 = i + j * a_dim1;
i__4 = i + j * b_dim1;
if (A(i,j).r != 0. || A(i,j).i != 0. || (B(i,j).r != 0. || B(i,j).i != 0.)) {
goto L150;
}
/* L130: */
}
i = ip1 - 1;
L140:
m = k;
iflow = 2;
goto L160;
L150:
;
}
goto L190;
/* Permute rows M and I */
L160:
LSCALE(m) = (doublereal) i;
if (i == m) {
goto L170;
}
i__1 = *n - k + 1;
zswap_(&i__1, &A(i,k), lda, &A(m,k), lda);
i__1 = *n - k + 1;
zswap_(&i__1, &B(i,k), ldb, &B(m,k), ldb);
/* Permute columns M and J */
L170:
RSCALE(m) = (doublereal) j;
if (j == m) {
goto L180;
}
zswap_(&l, &A(1,j), &c__1, &A(1,m), &c__1);
zswap_(&l, &B(1,j), &c__1, &B(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 <= *ihi; ++i) {
RSCALE(i) = 0.;
LSCALE(i) = 0.;
WORK(i) = 0.;
WORK(i + *n) = 0.;
WORK(i + (*n << 1)) = 0.;
WORK(i + *n * 3) = 0.;
WORK(i + (*n << 2)) = 0.;
WORK(i + *n * 5) = 0.;
/* L200: */
}
/* Compute right side vector in resulting linear equations */
basl = d_lg10(&c_b35);
i__1 = *ihi;
for (i = *ilo; i <= *ihi; ++i) {
i__2 = *ihi;
for (j = *ilo; j <= *ihi; ++j) {
i__3 = i + j * a_dim1;
if (A(i,j).r == 0. && A(i,j).i == 0.) {
ta = 0.;
goto L210;
}
i__3 = i + j * a_dim1;
d__3 = (d__1 = A(i,j).r, abs(d__1)) + (d__2 = d_imag(&A(i,j)), abs(d__2));
ta = d_lg10(&d__3) / basl;
L210:
i__3 = i + j * b_dim1;
if (B(i,j).r == 0. && B(i,j).i == 0.) {
tb = 0.;
goto L220;
}
i__3 = i + j * b_dim1;
d__3 = (d__1 = B(i,j).r, abs(d__1)) + (d__2 = d_imag(&B(i,j)), abs(d__2));
tb = d_lg10(&d__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. / (doublereal) (nr << 1);
coef2 = coef * coef;
coef5 = coef2 * .5;
nrp2 = nr + 2;
beta = 0.;
it = 1;
/* Start generalized conjugate gradient iteration */
L250:
gamma = ddot_(&nr, &WORK(*ilo + (*n << 2)), &c__1, &WORK(*ilo + (*n << 2))
, &c__1) + ddot_(&nr, &WORK(*ilo + *n * 5), &c__1, &WORK(*ilo + *
n * 5), &c__1);
ew = 0.;
ewc = 0.;
i__1 = *ihi;
for (i = *ilo; i <= *ihi; ++i) {
ew += WORK(i + (*n << 2));
ewc += WORK(i + *n * 5);
/* L260: */
}
/* Computing 2nd power */
d__1 = ew;
/* Computing 2nd power */
d__2 = ewc;
/* Computing 2nd power */
d__3 = ew - ewc;
gamma = coef * gamma - coef2 * (d__1 * d__1 + d__2 * d__2) - coef5 * (
d__3 * d__3);
if (gamma == 0.) {
goto L350;
}
if (it != 1) {
beta = gamma / pgamma;
}
t = coef5 * (ewc - ew * 3.);
tc = coef5 * (ew - ewc * 3.);
dscal_(&nr, &beta, &WORK(*ilo), &c__1);
dscal_(&nr, &beta, &WORK(*ilo + *n), &c__1);
daxpy_(&nr, &coef, &WORK(*ilo + (*n << 2)), &c__1, &WORK(*ilo + *n), &
c__1);
daxpy_(&nr, &coef, &WORK(*ilo + *n * 5), &c__1, &WORK(*ilo), &c__1);
i__1 = *ihi;
for (i = *ilo; i <= *ihi; ++i) {
WORK(i) += tc;
WORK(i + *n) += t;
/* L270: */
}
/* Apply matrix to vector */
i__1 = *ihi;
for (i = *ilo; i <= *ihi; ++i) {
kount = 0;
sum = 0.;
i__2 = *ihi;
for (j = *ilo; j <= *ihi; ++j) {
i__3 = i + j * a_dim1;
if (A(i,j).r == 0. && A(i,j).i == 0.) {
goto L280;
}
++kount;
sum += WORK(j);
L280:
i__3 = i + j * b_dim1;
if (B(i,j).r == 0. && B(i,j).i == 0.) {
goto L290;
}
++kount;
sum += WORK(j);
L290:
;
}
WORK(i + (*n << 1)) = (doublereal) kount * WORK(i + *n) + sum;
/* L300: */
}
i__1 = *ihi;
for (j = *ilo; j <= *ihi; ++j) {
kount = 0;
sum = 0.;
i__2 = *ihi;
for (i = *ilo; i <= *ihi; ++i) {
i__3 = i + j * a_dim1;
if (A(i,j).r == 0. && A(i,j).i == 0.) {
goto L310;
}
++kount;
sum += WORK(i + *n);
L310:
i__3 = i + j * b_dim1;
if (B(i,j).r == 0. && B(i,j).i == 0.) {
goto L320;
}
++kount;
sum += WORK(i + *n);
L320:
;
}
WORK(j + *n * 3) = (doublereal) kount * WORK(j) + sum;
/* L330: */
}
sum = ddot_(&nr, &WORK(*ilo + *n), &c__1, &WORK(*ilo + (*n << 1)), &c__1)
+ ddot_(&nr, &WORK(*ilo), &c__1, &WORK(*ilo + *n * 3), &c__1);
alpha = gamma / sum;
/* Determine correction to current iteration */
cmax = 0.;
i__1 = *ihi;
for (i = *ilo; i <= *ihi; ++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 < .5) {
goto L350;
}
d__1 = -alpha;
daxpy_(&nr, &d__1, &WORK(*ilo + (*n << 1)), &c__1, &WORK(*ilo + (*n << 2))
, &c__1);
d__1 = -alpha;
daxpy_(&nr, &d__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 = dlamch_("S");
sfmax = 1. / sfmin;
lsfmin = (integer) (d_lg10(&sfmin) / basl + 1.);
lsfmax = (integer) (d_lg10(&sfmax) / basl);
i__1 = *ihi;
for (i = *ilo; i <= *ihi; ++i) {
i__2 = *n - *ilo + 1;
irab = izamax_(&i__2, &A(i,*ilo), lda);
rab = z_abs(&A(i,irab+*ilo-1));
i__2 = *n - *ilo + 1;
irab = izamax_(&i__2, &B(i,*ilo), lda);
/* Computing MAX */
d__1 = rab, d__2 = z_abs(&B(i,irab+*ilo-1));
rab = max(d__1,d__2);
d__1 = rab + sfmin;
lrab = (integer) (d_lg10(&d__1) / basl + 1.);
ir = (integer) (LSCALE(i) + d_sign(&c_b71, &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_di(&c_b35, &ir);
icab = izamax_(ihi, &A(1,i), &c__1);
cab = z_abs(&A(icab,i));
icab = izamax_(ihi, &B(1,i), &c__1);
/* Computing MAX */
d__1 = cab, d__2 = z_abs(&B(icab,i));
cab = max(d__1,d__2);
d__1 = cab + sfmin;
lcab = (integer) (d_lg10(&d__1) / basl + 1.);
jc = (integer) (RSCALE(i) + d_sign(&c_b71, &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_di(&c_b35, &jc);
/* L360: */
}
/* Row scaling of matrices A and B */
i__1 = *ihi;
for (i = *ilo; i <= *ihi; ++i) {
i__2 = *n - *ilo + 1;
zdscal_(&i__2, &LSCALE(i), &A(i,*ilo), lda);
i__2 = *n - *ilo + 1;
zdscal_(&i__2, &LSCALE(i), &B(i,*ilo), ldb);
/* L370: */
}
/* Column scaling of matrices A and B */
i__1 = *ihi;
for (j = *ilo; j <= *ihi; ++j) {
zdscal_(ihi, &RSCALE(j), &A(1,j), &c__1);
zdscal_(ihi, &RSCALE(j), &B(1,j), &c__1);
/* L380: */
}
return 0;
/* End of ZGGBAL */
} /* zggbal_ */
/*< >*/
/* Subroutine */ int dggbal_(char *job, integer *n, doublereal *a, integer *
lda, doublereal *b, integer *ldb, integer *ilo, integer *ihi,
doublereal *lscale, doublereal *rscale, doublereal *work, integer *
info, ftnlen job_len)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double d_lg10(doublereal *), d_sign(doublereal *, doublereal *), pow_di(
doublereal *, integer *);
/* Local variables */
integer i__, j, k, l, m;
doublereal t;
integer jc;
doublereal ta, tb, tc;
integer ir;
doublereal ew;
integer it, nr, ip1, jp1, lm1;
doublereal cab, rab, ewc, cor, sum;
integer nrp2, icab, lcab;
doublereal beta, coef;
integer irab, lrab;
doublereal basl, cmax;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
doublereal coef2, coef5, gamma, alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(const char *, const char *, ftnlen, ftnlen);
doublereal sfmin, sfmax;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer iflow;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
integer kount;
extern doublereal dlamch_(char *, ftnlen);
doublereal pgamma=0;
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
integer lsfmin, lsfmax;
(void)job_len;
/* -- 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 */
/* .. Scalar Arguments .. */
/*< CHARACTER JOB >*/
/*< INTEGER IHI, ILO, INFO, LDA, LDB, N >*/
/* .. */
/* .. Array Arguments .. */
/*< >*/
/* .. */
/* Purpose */
/* ======= */
/* DGGBAL 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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. */
/* ===================================================================== */
/* .. Parameters .. */
/*< DOUBLE PRECISION ZERO, HALF, ONE >*/
/*< PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) >*/
/*< DOUBLE PRECISION THREE, SCLFAC >*/
/*< PARAMETER ( THREE = 3.0D+0, SCLFAC = 1.0D+1 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< >*/
/*< >*/
/* .. */
/* .. External Functions .. */
/*< LOGICAL LSAME >*/
/*< INTEGER IDAMAX >*/
/*< DOUBLE PRECISION DDOT, DLAMCH >*/
/*< EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL DAXPY, DSCAL, DSWAP, XERBLA >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC ABS, DBLE, INT, LOG10, MAX, MIN, SIGN >*/
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/*< INFO = 0 >*/
/* 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", (ftnlen)1, (ftnlen)1) && ! lsame_(job, "P", (
ftnlen)1, (ftnlen)1) && ! lsame_(job, "S", (ftnlen)1, (ftnlen)1)
&& ! lsame_(job, "B", (ftnlen)1, (ftnlen)1)) {
/*< INFO = -1 >*/
*info = -1;
/*< ELSE IF( N.LT.0 ) THEN >*/
} else if (*n < 0) {
/*< INFO = -2 >*/
*info = -2;
/*< ELSE IF( LDA.LT.MAX( 1, N ) ) THEN >*/
} else if (*lda < max(1,*n)) {
/*< INFO = -4 >*/
*info = -4;
/*< ELSE IF( LDB.LT.MAX( 1, N ) ) THEN >*/
} else if (*ldb < max(1,*n)) {
/*< INFO = -5 >*/
*info = -5;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'DGGBAL', -INFO ) >*/
i__1 = -(*info);
xerbla_("DGGBAL", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/*< K = 1 >*/
k = 1;
/*< L = N >*/
l = *n;
/* Quick return if possible */
/*< >*/
if (*n == 0) {
return 0;
}
/*< IF( LSAME( JOB, 'N' ) ) THEN >*/
if (lsame_(job, "N", (ftnlen)1, (ftnlen)1)) {
/*< ILO = 1 >*/
*ilo = 1;
/*< IHI = N >*/
*ihi = *n;
/*< DO 10 I = 1, N >*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< LSCALE( I ) = ONE >*/
lscale[i__] = 1.;
/*< RSCALE( I ) = ONE >*/
rscale[i__] = 1.;
/*< 10 CONTINUE >*/
/* L10: */
}
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/*< IF( K.EQ.L ) THEN >*/
if (k == l) {
/*< ILO = 1 >*/
*ilo = 1;
/*< IHI = 1 >*/
*ihi = 1;
/*< LSCALE( 1 ) = ONE >*/
lscale[1] = 1.;
/*< RSCALE( 1 ) = ONE >*/
rscale[1] = 1.;
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/*< >*/
if (lsame_(job, "S", (ftnlen)1, (ftnlen)1)) {
goto L190;
}
/*< GO TO 30 >*/
goto L30;
/* Permute the matrices A and B to isolate the eigenvalues. */
/* Find row with one nonzero in columns 1 through L */
/*< 20 CONTINUE >*/
L20:
/*< L = LM1 >*/
l = lm1;
/*< >*/
if (l != 1) {
goto L30;
}
/*< RSCALE( 1 ) = 1 >*/
rscale[1] = 1.;
/*< LSCALE( 1 ) = 1 >*/
lscale[1] = 1.;
/*< GO TO 190 >*/
goto L190;
/*< 30 CONTINUE >*/
L30:
/*< LM1 = L - 1 >*/
lm1 = l - 1;
/*< DO 80 I = L, 1, -1 >*/
for (i__ = l; i__ >= 1; --i__) {
/*< DO 40 J = 1, LM1 >*/
i__1 = lm1;
for (j = 1; j <= i__1; ++j) {
/*< JP1 = J + 1 >*/
jp1 = j + 1;
/*< >*/
if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) {
goto L50;
}
/*< 40 CONTINUE >*/
/* L40: */
}
/*< J = L >*/
j = l;
/*< GO TO 70 >*/
goto L70;
/*< 50 CONTINUE >*/
L50:
/*< DO 60 J = JP1, L >*/
i__1 = l;
for (j = jp1; j <= i__1; ++j) {
/*< >*/
if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) {
goto L80;
}
/*< 60 CONTINUE >*/
/* L60: */
}
/*< J = JP1 - 1 >*/
j = jp1 - 1;
/*< 70 CONTINUE >*/
L70:
/*< M = L >*/
m = l;
/*< IFLOW = 1 >*/
iflow = 1;
/*< GO TO 160 >*/
goto L160;
/*< 80 CONTINUE >*/
L80:
;
}
/*< GO TO 100 >*/
goto L100;
/* Find column with one nonzero in rows K through N */
/*< 90 CONTINUE >*/
L90:
/*< K = K + 1 >*/
++k;
/*< 100 CONTINUE >*/
L100:
/*< DO 150 J = K, L >*/
i__1 = l;
for (j = k; j <= i__1; ++j) {
/*< DO 110 I = K, LM1 >*/
i__2 = lm1;
for (i__ = k; i__ <= i__2; ++i__) {
/*< IP1 = I + 1 >*/
ip1 = i__ + 1;
/*< >*/
if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) {
goto L120;
}
/*< 110 CONTINUE >*/
/* L110: */
}
/*< I = L >*/
i__ = l;
/*< GO TO 140 >*/
goto L140;
/*< 120 CONTINUE >*/
L120:
/*< DO 130 I = IP1, L >*/
i__2 = l;
for (i__ = ip1; i__ <= i__2; ++i__) {
/*< >*/
if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) {
goto L150;
}
/*< 130 CONTINUE >*/
/* L130: */
}
/*< I = IP1 - 1 >*/
i__ = ip1 - 1;
/*< 140 CONTINUE >*/
L140:
/*< M = K >*/
m = k;
/*< IFLOW = 2 >*/
iflow = 2;
/*< GO TO 160 >*/
goto L160;
/*< 150 CONTINUE >*/
L150:
;
}
/*< GO TO 190 >*/
goto L190;
/* Permute rows M and I */
/*< 160 CONTINUE >*/
L160:
/*< LSCALE( M ) = I >*/
lscale[m] = (doublereal) i__;
/*< >*/
if (i__ == m) {
goto L170;
}
/*< CALL DSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA ) >*/
i__1 = *n - k + 1;
dswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[m + k * a_dim1], lda);
/*< CALL DSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB ) >*/
i__1 = *n - k + 1;
dswap_(&i__1, &b[i__ + k * b_dim1], ldb, &b[m + k * b_dim1], ldb);
/* Permute columns M and J */
/*< 170 CONTINUE >*/
L170:
/*< RSCALE( M ) = J >*/
rscale[m] = (doublereal) j;
/*< >*/
if (j == m) {
goto L180;
}
/*< CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) >*/
dswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
/*< CALL DSWAP( L, B( 1, J ), 1, B( 1, M ), 1 ) >*/
dswap_(&l, &b[j * b_dim1 + 1], &c__1, &b[m * b_dim1 + 1], &c__1);
/*< 180 CONTINUE >*/
L180:
/*< GO TO ( 20, 90 )IFLOW >*/
switch (iflow) {
case 1: goto L20;
case 2: goto L90;
}
/*< 190 CONTINUE >*/
L190:
/*< ILO = K >*/
*ilo = k;
/*< IHI = L >*/
*ihi = l;
/*< >*/
if (*ilo == *ihi) {
return 0;
}
/*< >*/
if (lsame_(job, "P", (ftnlen)1, (ftnlen)1)) {
return 0;
}
/* Balance the submatrix in rows ILO to IHI. */
/*< NR = IHI - ILO + 1 >*/
nr = *ihi - *ilo + 1;
/*< DO 200 I = ILO, IHI >*/
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
/*< RSCALE( I ) = ZERO >*/
rscale[i__] = 0.;
/*< LSCALE( I ) = ZERO >*/
lscale[i__] = 0.;
/*< WORK( I ) = ZERO >*/
work[i__] = 0.;
/*< WORK( I+N ) = ZERO >*/
work[i__ + *n] = 0.;
/*< WORK( I+2*N ) = ZERO >*/
work[i__ + (*n << 1)] = 0.;
/*< WORK( I+3*N ) = ZERO >*/
work[i__ + *n * 3] = 0.;
/*< WORK( I+4*N ) = ZERO >*/
work[i__ + (*n << 2)] = 0.;
/*< WORK( I+5*N ) = ZERO >*/
work[i__ + *n * 5] = 0.;
/*< 200 CONTINUE >*/
/* L200: */
}
/* Compute right side vector in resulting linear equations */
/*< BASL = LOG10( SCLFAC ) >*/
basl = d_lg10(&c_b34);
/*< DO 240 I = ILO, IHI >*/
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
/*< DO 230 J = ILO, IHI >*/
i__2 = *ihi;
for (j = *ilo; j <= i__2; ++j) {
/*< TB = B( I, J ) >*/
tb = b[i__ + j * b_dim1];
/*< TA = A( I, J ) >*/
ta = a[i__ + j * a_dim1];
/*< >*/
if (ta == 0.) {
goto L210;
}
/*< TA = LOG10( ABS( TA ) ) / BASL >*/
d__1 = abs(ta);
ta = d_lg10(&d__1) / basl;
/*< 210 CONTINUE >*/
L210:
/*< >*/
if (tb == 0.) {
goto L220;
}
/*< TB = LOG10( ABS( TB ) ) / BASL >*/
d__1 = abs(tb);
tb = d_lg10(&d__1) / basl;
/*< 220 CONTINUE >*/
L220:
/*< WORK( I+4*N ) = WORK( I+4*N ) - TA - TB >*/
work[i__ + (*n << 2)] = work[i__ + (*n << 2)] - ta - tb;
/*< WORK( J+5*N ) = WORK( J+5*N ) - TA - TB >*/
work[j + *n * 5] = work[j + *n * 5] - ta - tb;
/*< 230 CONTINUE >*/
/* L230: */
}
/*< 240 CONTINUE >*/
/* L240: */
}
/*< COEF = ONE / DBLE( 2*NR ) >*/
coef = 1. / (doublereal) (nr << 1);
/*< COEF2 = COEF*COEF >*/
coef2 = coef * coef;
/*< COEF5 = HALF*COEF2 >*/
coef5 = coef2 * .5;
/*< NRP2 = NR + 2 >*/
nrp2 = nr + 2;
/*< BETA = ZERO >*/
beta = 0.;
/*< IT = 1 >*/
it = 1;
/* Start generalized conjugate gradient iteration */
/*< 250 CONTINUE >*/
L250:
/*< >*/
gamma = ddot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)]
, &c__1) + ddot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + *
n * 5], &c__1);
/*< EW = ZERO >*/
ew = 0.;
/*< EWC = ZERO >*/
ewc = 0.;
/*< DO 260 I = ILO, IHI >*/
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
/*< EW = EW + WORK( I+4*N ) >*/
ew += work[i__ + (*n << 2)];
/*< EWC = EWC + WORK( I+5*N ) >*/
ewc += work[i__ + *n * 5];
/*< 260 CONTINUE >*/
/* L260: */
}
/*< GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2 >*/
/* Computing 2nd power */
d__1 = ew;
/* Computing 2nd power */
d__2 = ewc;
/* Computing 2nd power */
d__3 = ew - ewc;
gamma = coef * gamma - coef2 * (d__1 * d__1 + d__2 * d__2) - coef5 * (
d__3 * d__3);
/*< >*/
if (gamma == 0.) {
goto L350;
}
/*< >*/
if (it != 1) {
beta = gamma / pgamma;
}
/*< T = COEF5*( EWC-THREE*EW ) >*/
t = coef5 * (ewc - ew * 3.);
/*< TC = COEF5*( EW-THREE*EWC ) >*/
tc = coef5 * (ew - ewc * 3.);
/*< CALL DSCAL( NR, BETA, WORK( ILO ), 1 ) >*/
dscal_(&nr, &beta, &work[*ilo], &c__1);
/*< CALL DSCAL( NR, BETA, WORK( ILO+N ), 1 ) >*/
dscal_(&nr, &beta, &work[*ilo + *n], &c__1);
/*< CALL DAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 ) >*/
daxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], &
c__1);
/*< CALL DAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 ) >*/
daxpy_(&nr, &coef, &work[*ilo + *n * 5], &c__1, &work[*ilo], &c__1);
/*< DO 270 I = ILO, IHI >*/
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
/*< WORK( I ) = WORK( I ) + TC >*/
work[i__] += tc;
/*< WORK( I+N ) = WORK( I+N ) + T >*/
work[i__ + *n] += t;
/*< 270 CONTINUE >*/
/* L270: */
}
/* Apply matrix to vector */
/*< DO 300 I = ILO, IHI >*/
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
/*< KOUNT = 0 >*/
kount = 0;
/*< SUM = ZERO >*/
sum = 0.;
/*< DO 290 J = ILO, IHI >*/
i__2 = *ihi;
for (j = *ilo; j <= i__2; ++j) {
/*< >*/
if (a[i__ + j * a_dim1] == 0.) {
goto L280;
}
/*< KOUNT = KOUNT + 1 >*/
++kount;
/*< SUM = SUM + WORK( J ) >*/
sum += work[j];
/*< 280 CONTINUE >*/
L280:
/*< >*/
if (b[i__ + j * b_dim1] == 0.) {
goto L290;
}
/*< KOUNT = KOUNT + 1 >*/
++kount;
/*< SUM = SUM + WORK( J ) >*/
sum += work[j];
/*< 290 CONTINUE >*/
L290:
;
}
/*< WORK( I+2*N ) = DBLE( KOUNT )*WORK( I+N ) + SUM >*/
work[i__ + (*n << 1)] = (doublereal) kount * work[i__ + *n] + sum;
/*< 300 CONTINUE >*/
/* L300: */
}
/*< DO 330 J = ILO, IHI >*/
i__1 = *ihi;
for (j = *ilo; j <= i__1; ++j) {
/*< KOUNT = 0 >*/
kount = 0;
/*< SUM = ZERO >*/
sum = 0.;
/*< DO 320 I = ILO, IHI >*/
i__2 = *ihi;
for (i__ = *ilo; i__ <= i__2; ++i__) {
/*< >*/
if (a[i__ + j * a_dim1] == 0.) {
goto L310;
}
/*< KOUNT = KOUNT + 1 >*/
++kount;
/*< SUM = SUM + WORK( I+N ) >*/
sum += work[i__ + *n];
/*< 310 CONTINUE >*/
L310:
/*< >*/
if (b[i__ + j * b_dim1] == 0.) {
goto L320;
}
/*< KOUNT = KOUNT + 1 >*/
++kount;
/*< SUM = SUM + WORK( I+N ) >*/
sum += work[i__ + *n];
/*< 320 CONTINUE >*/
L320:
;
}
/*< WORK( J+3*N ) = DBLE( KOUNT )*WORK( J ) + SUM >*/
work[j + *n * 3] = (doublereal) kount * work[j] + sum;
/*< 330 CONTINUE >*/
/* L330: */
}
/*< >*/
sum = ddot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1)
+ ddot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1);
/*< ALPHA = GAMMA / SUM >*/
alpha = gamma / sum;
/* Determine correction to current iteration */
/*< CMAX = ZERO >*/
cmax = 0.;
/*< DO 340 I = ILO, IHI >*/
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
/*< COR = ALPHA*WORK( I+N ) >*/
cor = alpha * work[i__ + *n];
/*< >*/
if (abs(cor) > cmax) {
cmax = abs(cor);
}
/*< LSCALE( I ) = LSCALE( I ) + COR >*/
lscale[i__] += cor;
/*< COR = ALPHA*WORK( I ) >*/
cor = alpha * work[i__];
/*< >*/
if (abs(cor) > cmax) {
cmax = abs(cor);
}
/*< RSCALE( I ) = RSCALE( I ) + COR >*/
rscale[i__] += cor;
/*< 340 CONTINUE >*/
/* L340: */
}
/*< >*/
if (cmax < .5) {
goto L350;
}
/*< CALL DAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 ) >*/
d__1 = -alpha;
daxpy_(&nr, &d__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)]
, &c__1);
/*< CALL DAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 ) >*/
d__1 = -alpha;
daxpy_(&nr, &d__1, &work[*ilo + *n * 3], &c__1, &work[*ilo + *n * 5], &
c__1);
/*< PGAMMA = GAMMA >*/
pgamma = gamma;
/*< IT = IT + 1 >*/
++it;
/*< >*/
if (it <= nrp2) {
goto L250;
}
/* End generalized conjugate gradient iteration */
/*< 350 CONTINUE >*/
L350:
/*< SFMIN = DLAMCH( 'S' ) >*/
sfmin = dlamch_("S", (ftnlen)1);
/*< SFMAX = ONE / SFMIN >*/
sfmax = 1. / sfmin;
/*< LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE ) >*/
lsfmin = (integer) (d_lg10(&sfmin) / basl + 1.);
/*< LSFMAX = INT( LOG10( SFMAX ) / BASL ) >*/
lsfmax = (integer) (d_lg10(&sfmax) / basl);
/*< DO 360 I = ILO, IHI >*/
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
/*< IRAB = IDAMAX( N-ILO+1, A( I, ILO ), LDA ) >*/
i__2 = *n - *ilo + 1;
irab = idamax_(&i__2, &a[i__ + *ilo * a_dim1], lda);
/*< RAB = ABS( A( I, IRAB+ILO-1 ) ) >*/
rab = (d__1 = a[i__ + (irab + *ilo - 1) * a_dim1], abs(d__1));
/*< IRAB = IDAMAX( N-ILO+1, B( I, ILO ), LDA ) >*/
i__2 = *n - *ilo + 1;
irab = idamax_(&i__2, &b[i__ + *ilo * b_dim1], lda);
/*< RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) >*/
/* Computing MAX */
d__2 = rab, d__3 = (d__1 = b[i__ + (irab + *ilo - 1) * b_dim1], abs(
d__1));
rab = max(d__2,d__3);
/*< LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) >*/
d__1 = rab + sfmin;
lrab = (integer) (d_lg10(&d__1) / basl + 1.);
/*< IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) >*/
ir = (integer) (lscale[i__] + d_sign(&c_b70, &lscale[i__]));
/*< IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) >*/
/* 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 ) = SCLFAC**IR >*/
lscale[i__] = pow_di(&c_b34, &ir);
/*< ICAB = IDAMAX( IHI, A( 1, I ), 1 ) >*/
icab = idamax_(ihi, &a[i__ * a_dim1 + 1], &c__1);
/*< CAB = ABS( A( ICAB, I ) ) >*/
cab = (d__1 = a[icab + i__ * a_dim1], abs(d__1));
/*< ICAB = IDAMAX( IHI, B( 1, I ), 1 ) >*/
icab = idamax_(ihi, &b[i__ * b_dim1 + 1], &c__1);
/*< CAB = MAX( CAB, ABS( B( ICAB, I ) ) ) >*/
/* Computing MAX */
d__2 = cab, d__3 = (d__1 = b[icab + i__ * b_dim1], abs(d__1));
cab = max(d__2,d__3);
/*< LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE ) >*/
d__1 = cab + sfmin;
lcab = (integer) (d_lg10(&d__1) / basl + 1.);
/*< JC = RSCALE( I ) + SIGN( HALF, RSCALE( I ) ) >*/
jc = (integer) (rscale[i__] + d_sign(&c_b70, &rscale[i__]));
/*< JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) >*/
/* 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 ) = SCLFAC**JC >*/
rscale[i__] = pow_di(&c_b34, &jc);
/*< 360 CONTINUE >*/
/* L360: */
}
/* Row scaling of matrices A and B */
/*< DO 370 I = ILO, IHI >*/
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
/*< CALL DSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA ) >*/
i__2 = *n - *ilo + 1;
dscal_(&i__2, &lscale[i__], &a[i__ + *ilo * a_dim1], lda);
/*< CALL DSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB ) >*/
i__2 = *n - *ilo + 1;
dscal_(&i__2, &lscale[i__], &b[i__ + *ilo * b_dim1], ldb);
/*< 370 CONTINUE >*/
/* L370: */
}
/* Column scaling of matrices A and B */
/*< DO 380 J = ILO, IHI >*/
i__1 = *ihi;
for (j = *ilo; j <= i__1; ++j) {
/*< CALL DSCAL( IHI, RSCALE( J ), A( 1, J ), 1 ) >*/
dscal_(ihi, &rscale[j], &a[j * a_dim1 + 1], &c__1);
/*< CALL DSCAL( IHI, RSCALE( J ), B( 1, J ), 1 ) >*/
dscal_(ihi, &rscale[j], &b[j * b_dim1 + 1], &c__1);
/*< 380 CONTINUE >*/
/* L380: */
}
/*< RETURN >*/
return 0;
/* End of DGGBAL */
/*< END >*/
} /* dggbal_ */
/* Subroutine */
int dggbal_(char *job, integer *n, doublereal *a, integer * lda, doublereal *b, integer *ldb, integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale, doublereal *work, integer * info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double d_lg10(doublereal *), d_sign(doublereal *, doublereal *), pow_di( doublereal *, integer *);
/* Local variables */
integer i__, j, k, l, m;
doublereal t;
integer jc;
doublereal ta, tb, tc;
integer ir;
doublereal ew;
integer it, nr, ip1, jp1, lm1;
doublereal cab, rab, ewc, cor, sum;
integer nrp2, icab, lcab;
doublereal beta, coef;
integer irab, lrab;
doublereal basl, cmax;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *);
doublereal coef2, coef5, gamma, alpha;
extern /* Subroutine */
int dscal_(integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
doublereal sfmin, sfmax;
extern /* Subroutine */
int dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
integer iflow;
extern /* Subroutine */
int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *);
integer kount;
extern doublereal dlamch_(char *);
doublereal pgamma;
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */
int xerbla_(char *, integer *);
integer lsfmin, lsfmax;
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. 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_("DGGBAL", &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.;
rscale[1] = 1.;
return 0;
}
if (lsame_(job, "N"))
{
*ilo = 1;
*ihi = *n;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
lscale[i__] = 1.;
rscale[i__] = 1.;
/* 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.;
lscale[1] = 1.;
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[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.)
{
goto L50;
}
/* L40: */
}
j = l;
goto L70;
L50:
i__1 = l;
for (j = jp1;
j <= i__1;
++j)
{
if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.)
{
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[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.)
{
goto L120;
}
/* L110: */
}
i__ = l;
goto L140;
L120:
i__2 = l;
for (i__ = ip1;
i__ <= i__2;
++i__)
{
if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.)
{
goto L150;
}
/* L130: */
}
i__ = ip1 - 1;
L140:
m = k;
iflow = 2;
goto L160;
L150:
;
}
goto L190;
/* Permute rows M and I */
L160:
lscale[m] = (doublereal) i__;
if (i__ == m)
{
goto L170;
}
i__1 = *n - k + 1;
dswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[m + k * a_dim1], lda);
i__1 = *n - k + 1;
dswap_(&i__1, &b[i__ + k * b_dim1], ldb, &b[m + k * b_dim1], ldb);
/* Permute columns M and J */
L170:
rscale[m] = (doublereal) j;
if (j == m)
{
goto L180;
}
dswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
dswap_(&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.;
rscale[i__] = 1.;
/* 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.;
lscale[i__] = 0.;
work[i__] = 0.;
work[i__ + *n] = 0.;
work[i__ + (*n << 1)] = 0.;
work[i__ + *n * 3] = 0.;
work[i__ + (*n << 2)] = 0.;
work[i__ + *n * 5] = 0.;
/* L200: */
}
/* Compute right side vector in resulting linear equations */
basl = d_lg10(&c_b35);
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
i__2 = *ihi;
for (j = *ilo;
j <= i__2;
++j)
{
tb = b[i__ + j * b_dim1];
ta = a[i__ + j * a_dim1];
if (ta == 0.)
{
goto L210;
}
d__1 = f2c_abs(ta);
ta = d_lg10(&d__1) / basl;
L210:
if (tb == 0.)
{
goto L220;
}
d__1 = f2c_abs(tb);
tb = d_lg10(&d__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. / (doublereal) (nr << 1);
coef2 = coef * coef;
coef5 = coef2 * .5;
nrp2 = nr + 2;
beta = 0.;
it = 1;
/* Start generalized conjugate gradient iteration */
L250:
gamma = ddot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)] , &c__1) + ddot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + * n * 5], &c__1);
ew = 0.;
ewc = 0.;
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
ew += work[i__ + (*n << 2)];
ewc += work[i__ + *n * 5];
/* L260: */
}
/* Computing 2nd power */
d__1 = ew;
/* Computing 2nd power */
d__2 = ewc;
/* Computing 2nd power */
d__3 = ew - ewc;
gamma = coef * gamma - coef2 * (d__1 * d__1 + d__2 * d__2) - coef5 * ( d__3 * d__3);
if (gamma == 0.)
{
goto L350;
}
if (it != 1)
{
beta = gamma / pgamma;
}
t = coef5 * (ewc - ew * 3.);
tc = coef5 * (ew - ewc * 3.);
dscal_(&nr, &beta, &work[*ilo], &c__1);
dscal_(&nr, &beta, &work[*ilo + *n], &c__1);
daxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], & c__1);
daxpy_(&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.;
i__2 = *ihi;
for (j = *ilo;
j <= i__2;
++j)
{
if (a[i__ + j * a_dim1] == 0.)
{
goto L280;
}
++kount;
sum += work[j];
L280:
if (b[i__ + j * b_dim1] == 0.)
{
goto L290;
}
++kount;
sum += work[j];
L290:
;
}
work[i__ + (*n << 1)] = (doublereal) kount * work[i__ + *n] + sum;
/* L300: */
}
i__1 = *ihi;
for (j = *ilo;
j <= i__1;
++j)
{
kount = 0;
sum = 0.;
i__2 = *ihi;
for (i__ = *ilo;
i__ <= i__2;
++i__)
{
if (a[i__ + j * a_dim1] == 0.)
{
goto L310;
}
++kount;
sum += work[i__ + *n];
L310:
if (b[i__ + j * b_dim1] == 0.)
{
goto L320;
}
++kount;
sum += work[i__ + *n];
L320:
;
}
work[j + *n * 3] = (doublereal) kount * work[j] + sum;
/* L330: */
}
sum = ddot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1) + ddot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1);
alpha = gamma / sum;
/* Determine correction to current iteration */
cmax = 0.;
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
cor = alpha * work[i__ + *n];
if (f2c_abs(cor) > cmax)
{
cmax = f2c_abs(cor);
}
lscale[i__] += cor;
cor = alpha * work[i__];
if (f2c_abs(cor) > cmax)
{
cmax = f2c_abs(cor);
}
rscale[i__] += cor;
/* L340: */
}
if (cmax < .5)
{
goto L350;
}
d__1 = -alpha;
daxpy_(&nr, &d__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)] , &c__1);
d__1 = -alpha;
daxpy_(&nr, &d__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 = dlamch_("S");
sfmax = 1. / sfmin;
lsfmin = (integer) (d_lg10(&sfmin) / basl + 1.);
lsfmax = (integer) (d_lg10(&sfmax) / basl);
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
i__2 = *n - *ilo + 1;
irab = idamax_(&i__2, &a[i__ + *ilo * a_dim1], lda);
rab = (d__1 = a[i__ + (irab + *ilo - 1) * a_dim1], f2c_abs(d__1));
i__2 = *n - *ilo + 1;
irab = idamax_(&i__2, &b[i__ + *ilo * b_dim1], ldb);
/* Computing MAX */
d__2 = rab;
d__3 = (d__1 = b[i__ + (irab + *ilo - 1) * b_dim1], f2c_abs( d__1)); // , expr subst
rab = max(d__2,d__3);
d__1 = rab + sfmin;
lrab = (integer) (d_lg10(&d__1) / basl + 1.);
ir = (integer) (lscale[i__] + d_sign(&c_b71, &lscale[i__]));
/* Computing MIN */
i__2 = max(ir,lsfmin);
i__2 = min(i__2,lsfmax);
i__3 = lsfmax - lrab; // ; expr subst
ir = min(i__2,i__3);
lscale[i__] = pow_di(&c_b35, &ir);
icab = idamax_(ihi, &a[i__ * a_dim1 + 1], &c__1);
cab = (d__1 = a[icab + i__ * a_dim1], f2c_abs(d__1));
icab = idamax_(ihi, &b[i__ * b_dim1 + 1], &c__1);
/* Computing MAX */
d__2 = cab;
d__3 = (d__1 = b[icab + i__ * b_dim1], f2c_abs(d__1)); // , expr subst
cab = max(d__2,d__3);
d__1 = cab + sfmin;
lcab = (integer) (d_lg10(&d__1) / basl + 1.);
jc = (integer) (rscale[i__] + d_sign(&c_b71, &rscale[i__]));
/* Computing MIN */
i__2 = max(jc,lsfmin);
i__2 = min(i__2,lsfmax);
i__3 = lsfmax - lcab; // ; expr subst
jc = min(i__2,i__3);
rscale[i__] = pow_di(&c_b35, &jc);
/* L360: */
}
/* Row scaling of matrices A and B */
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
i__2 = *n - *ilo + 1;
dscal_(&i__2, &lscale[i__], &a[i__ + *ilo * a_dim1], lda);
i__2 = *n - *ilo + 1;
dscal_(&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)
{
dscal_(ihi, &rscale[j], &a[j * a_dim1 + 1], &c__1);
dscal_(ihi, &rscale[j], &b[j * b_dim1 + 1], &c__1);
/* L380: */
}
return 0;
/* End of DGGBAL */
}
