386 lines
8.6 KiB
C
386 lines
8.6 KiB
C
#include "blaswrap.h"
|
|
#ifdef _cpluscplus
|
|
extern "C" {
|
|
#endif
|
|
#include "f2c.h"
|
|
|
|
/* Subroutine */ int dgebal_(char *job, integer *n, doublereal *a, integer *
|
|
lda, integer *ilo, integer *ihi, doublereal *scale, integer *info)
|
|
{
|
|
/* -- LAPACK routine (version 3.0) --
|
|
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
|
|
Courant Institute, Argonne National Lab, and Rice University
|
|
June 30, 1999
|
|
|
|
|
|
Purpose
|
|
=======
|
|
|
|
DGEBAL balances a general real matrix A. This involves, first,
|
|
permuting A by a similarity transformation 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 matrix, and improve the
|
|
accuracy of the computed eigenvalues and/or eigenvectors.
|
|
|
|
Arguments
|
|
=========
|
|
|
|
JOB (input) CHARACTER*1
|
|
Specifies the operations to be performed on A:
|
|
= 'N': none: simply set ILO = 1, IHI = N, SCALE(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 matrix A. 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.
|
|
See Further Details.
|
|
|
|
LDA (input) INTEGER
|
|
The leading dimension of the array A. LDA >= max(1,N).
|
|
|
|
ILO (output) INTEGER
|
|
IHI (output) INTEGER
|
|
ILO and IHI are set to integers such that on exit
|
|
A(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.
|
|
|
|
SCALE (output) DOUBLE PRECISION array, dimension (N)
|
|
Details of the permutations and scaling factors applied to
|
|
A. If P(j) is the index of the row and column interchanged
|
|
with row and column j and D(j) is the scaling factor
|
|
applied to row and column j, then
|
|
SCALE(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.
|
|
|
|
INFO (output) INTEGER
|
|
= 0: successful exit.
|
|
< 0: if INFO = -i, the i-th argument had an illegal value.
|
|
|
|
Further Details
|
|
===============
|
|
|
|
The permutations consist of row and column interchanges which put
|
|
the matrix in the form
|
|
|
|
( T1 X Y )
|
|
P A P = ( 0 B Z )
|
|
( 0 0 T2 )
|
|
|
|
where T1 and T2 are upper triangular matrices whose eigenvalues lie
|
|
along the diagonal. The column indices ILO and IHI mark the starting
|
|
and ending columns of the submatrix B. Balancing consists of applying
|
|
a diagonal similarity transformation inv(D) * B * D to make the
|
|
1-norms of each row of B and its corresponding column nearly equal.
|
|
The output matrix is
|
|
|
|
( T1 X*D Y )
|
|
( 0 inv(D)*B*D inv(D)*Z ).
|
|
( 0 0 T2 )
|
|
|
|
Information about the permutations P and the diagonal matrix D is
|
|
returned in the vector SCALE.
|
|
|
|
This subroutine is based on the EISPACK routine BALANC.
|
|
|
|
Modified by Tzu-Yi Chen, Computer Science Division, University of
|
|
California at Berkeley, USA
|
|
|
|
=====================================================================
|
|
|
|
|
|
Test the input parameters
|
|
|
|
Parameter adjustments */
|
|
/* Table of constant values */
|
|
static integer c__1 = 1;
|
|
|
|
/* System generated locals */
|
|
integer a_dim1, a_offset, i__1, i__2;
|
|
doublereal d__1, d__2;
|
|
/* Local variables */
|
|
static integer iexc;
|
|
static doublereal c__, f, g;
|
|
static integer i__, j, k, l, m;
|
|
static doublereal r__, s;
|
|
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
|
|
integer *);
|
|
extern logical lsame_(char *, char *);
|
|
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
|
|
doublereal *, integer *);
|
|
static doublereal sfmin1, sfmin2, sfmax1, sfmax2, ca, ra;
|
|
extern doublereal dlamch_(char *);
|
|
extern integer idamax_(integer *, doublereal *, integer *);
|
|
extern /* Subroutine */ int xerbla_(char *, integer *);
|
|
static logical noconv;
|
|
static integer ica, ira;
|
|
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
|
|
|
|
|
|
a_dim1 = *lda;
|
|
a_offset = 1 + a_dim1 * 1;
|
|
a -= a_offset;
|
|
--scale;
|
|
|
|
/* 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;
|
|
}
|
|
if (*info != 0) {
|
|
i__1 = -(*info);
|
|
xerbla_("DGEBAL", &i__1);
|
|
return 0;
|
|
}
|
|
|
|
k = 1;
|
|
l = *n;
|
|
|
|
if (*n == 0) {
|
|
goto L210;
|
|
}
|
|
|
|
if (lsame_(job, "N")) {
|
|
i__1 = *n;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
scale[i__] = 1.;
|
|
/* L10: */
|
|
}
|
|
goto L210;
|
|
}
|
|
|
|
if (lsame_(job, "S")) {
|
|
goto L120;
|
|
}
|
|
|
|
/* Permutation to isolate eigenvalues if possible */
|
|
|
|
goto L50;
|
|
|
|
/* Row and column exchange. */
|
|
|
|
L20:
|
|
scale[m] = (doublereal) j;
|
|
if (j == m) {
|
|
goto L30;
|
|
}
|
|
|
|
dswap_(&l, &a_ref(1, j), &c__1, &a_ref(1, m), &c__1);
|
|
i__1 = *n - k + 1;
|
|
dswap_(&i__1, &a_ref(j, k), lda, &a_ref(m, k), lda);
|
|
|
|
L30:
|
|
switch (iexc) {
|
|
case 1: goto L40;
|
|
case 2: goto L80;
|
|
}
|
|
|
|
/* Search for rows isolating an eigenvalue and push them down. */
|
|
|
|
L40:
|
|
if (l == 1) {
|
|
goto L210;
|
|
}
|
|
--l;
|
|
|
|
L50:
|
|
for (j = l; j >= 1; --j) {
|
|
|
|
i__1 = l;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
if (i__ == j) {
|
|
goto L60;
|
|
}
|
|
if (a_ref(j, i__) != 0.) {
|
|
goto L70;
|
|
}
|
|
L60:
|
|
;
|
|
}
|
|
|
|
m = l;
|
|
iexc = 1;
|
|
goto L20;
|
|
L70:
|
|
;
|
|
}
|
|
|
|
goto L90;
|
|
|
|
/* Search for columns isolating an eigenvalue and push them left. */
|
|
|
|
L80:
|
|
++k;
|
|
|
|
L90:
|
|
i__1 = l;
|
|
for (j = k; j <= i__1; ++j) {
|
|
|
|
i__2 = l;
|
|
for (i__ = k; i__ <= i__2; ++i__) {
|
|
if (i__ == j) {
|
|
goto L100;
|
|
}
|
|
if (a_ref(i__, j) != 0.) {
|
|
goto L110;
|
|
}
|
|
L100:
|
|
;
|
|
}
|
|
|
|
m = k;
|
|
iexc = 2;
|
|
goto L20;
|
|
L110:
|
|
;
|
|
}
|
|
|
|
L120:
|
|
i__1 = l;
|
|
for (i__ = k; i__ <= i__1; ++i__) {
|
|
scale[i__] = 1.;
|
|
/* L130: */
|
|
}
|
|
|
|
if (lsame_(job, "P")) {
|
|
goto L210;
|
|
}
|
|
|
|
/* Balance the submatrix in rows K to L.
|
|
|
|
Iterative loop for norm reduction */
|
|
|
|
sfmin1 = dlamch_("S") / dlamch_("P");
|
|
sfmax1 = 1. / sfmin1;
|
|
sfmin2 = sfmin1 * 8.;
|
|
sfmax2 = 1. / sfmin2;
|
|
L140:
|
|
noconv = FALSE_;
|
|
|
|
i__1 = l;
|
|
for (i__ = k; i__ <= i__1; ++i__) {
|
|
c__ = 0.;
|
|
r__ = 0.;
|
|
|
|
i__2 = l;
|
|
for (j = k; j <= i__2; ++j) {
|
|
if (j == i__) {
|
|
goto L150;
|
|
}
|
|
c__ += (d__1 = a_ref(j, i__), abs(d__1));
|
|
r__ += (d__1 = a_ref(i__, j), abs(d__1));
|
|
L150:
|
|
;
|
|
}
|
|
ica = idamax_(&l, &a_ref(1, i__), &c__1);
|
|
ca = (d__1 = a_ref(ica, i__), abs(d__1));
|
|
i__2 = *n - k + 1;
|
|
ira = idamax_(&i__2, &a_ref(i__, k), lda);
|
|
ra = (d__1 = a_ref(i__, ira + k - 1), abs(d__1));
|
|
|
|
/* Guard against zero C or R due to underflow. */
|
|
|
|
if (c__ == 0. || r__ == 0.) {
|
|
goto L200;
|
|
}
|
|
g = r__ / 8.;
|
|
f = 1.;
|
|
s = c__ + r__;
|
|
L160:
|
|
/* Computing MAX */
|
|
d__1 = max(f,c__);
|
|
/* Computing MIN */
|
|
d__2 = min(r__,g);
|
|
if (c__ >= g || max(d__1,ca) >= sfmax2 || min(d__2,ra) <= sfmin2) {
|
|
goto L170;
|
|
}
|
|
f *= 8.;
|
|
c__ *= 8.;
|
|
ca *= 8.;
|
|
r__ /= 8.;
|
|
g /= 8.;
|
|
ra /= 8.;
|
|
goto L160;
|
|
|
|
L170:
|
|
g = c__ / 8.;
|
|
L180:
|
|
/* Computing MIN */
|
|
d__1 = min(f,c__), d__1 = min(d__1,g);
|
|
if (g < r__ || max(r__,ra) >= sfmax2 || min(d__1,ca) <= sfmin2) {
|
|
goto L190;
|
|
}
|
|
f /= 8.;
|
|
c__ /= 8.;
|
|
g /= 8.;
|
|
ca /= 8.;
|
|
r__ *= 8.;
|
|
ra *= 8.;
|
|
goto L180;
|
|
|
|
/* Now balance. */
|
|
|
|
L190:
|
|
if (c__ + r__ >= s * .95) {
|
|
goto L200;
|
|
}
|
|
if (f < 1. && scale[i__] < 1.) {
|
|
if (f * scale[i__] <= sfmin1) {
|
|
goto L200;
|
|
}
|
|
}
|
|
if (f > 1. && scale[i__] > 1.) {
|
|
if (scale[i__] >= sfmax1 / f) {
|
|
goto L200;
|
|
}
|
|
}
|
|
g = 1. / f;
|
|
scale[i__] *= f;
|
|
noconv = TRUE_;
|
|
|
|
i__2 = *n - k + 1;
|
|
dscal_(&i__2, &g, &a_ref(i__, k), lda);
|
|
dscal_(&l, &f, &a_ref(1, i__), &c__1);
|
|
|
|
L200:
|
|
;
|
|
}
|
|
|
|
if (noconv) {
|
|
goto L140;
|
|
}
|
|
|
|
L210:
|
|
*ilo = k;
|
|
*ihi = l;
|
|
|
|
return 0;
|
|
|
|
/* End of DGEBAL */
|
|
|
|
} /* dgebal_ */
|
|
|
|
#undef a_ref
|
|
|
|
|
|
#ifdef _cpluscplus
|
|
}
|
|
#endif
|