208 lines
6.5 KiB
C++
208 lines
6.5 KiB
C++
#ifdef __cplusplus
|
|
extern "C" {
|
|
#endif
|
|
#include "lmp_f2c.h"
|
|
static integer c__1 = 1;
|
|
int dgebal_(char *job, integer *n, doublereal *a, integer *lda, integer *ilo, integer *ihi,
|
|
doublereal *scale, integer *info, ftnlen job_len)
|
|
{
|
|
integer a_dim1, a_offset, i__1, i__2;
|
|
doublereal d__1, d__2;
|
|
doublereal c__, f, g;
|
|
integer i__, j, k, l;
|
|
doublereal r__, s, ca, ra;
|
|
integer ica, ira;
|
|
extern doublereal dnrm2_(integer *, doublereal *, integer *);
|
|
extern int dscal_(integer *, doublereal *, doublereal *, integer *);
|
|
extern logical lsame_(char *, char *, ftnlen, ftnlen);
|
|
extern int dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
|
|
doublereal sfmin1, sfmin2, sfmax1, sfmax2;
|
|
extern doublereal dlamch_(char *, ftnlen);
|
|
extern integer idamax_(integer *, doublereal *, integer *);
|
|
extern logical disnan_(doublereal *);
|
|
extern int xerbla_(char *, integer *, ftnlen);
|
|
logical noconv, canswap;
|
|
a_dim1 = *lda;
|
|
a_offset = 1 + a_dim1;
|
|
a -= a_offset;
|
|
--scale;
|
|
*info = 0;
|
|
if (!lsame_(job, (char *)"N", (ftnlen)1, (ftnlen)1) && !lsame_(job, (char *)"P", (ftnlen)1, (ftnlen)1) &&
|
|
!lsame_(job, (char *)"S", (ftnlen)1, (ftnlen)1) && !lsame_(job, (char *)"B", (ftnlen)1, (ftnlen)1)) {
|
|
*info = -1;
|
|
} else if (*n < 0) {
|
|
*info = -2;
|
|
} else if (*lda < max(1, *n)) {
|
|
*info = -4;
|
|
}
|
|
if (*info != 0) {
|
|
i__1 = -(*info);
|
|
xerbla_((char *)"DGEBAL", &i__1, (ftnlen)6);
|
|
return 0;
|
|
}
|
|
if (*n == 0) {
|
|
*ilo = 1;
|
|
*ihi = 0;
|
|
return 0;
|
|
}
|
|
if (lsame_(job, (char *)"N", (ftnlen)1, (ftnlen)1)) {
|
|
i__1 = *n;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
scale[i__] = 1.;
|
|
}
|
|
*ilo = 1;
|
|
*ihi = *n;
|
|
return 0;
|
|
}
|
|
k = 1;
|
|
l = *n;
|
|
if (!lsame_(job, (char *)"S", (ftnlen)1, (ftnlen)1)) {
|
|
noconv = TRUE_;
|
|
while (noconv) {
|
|
noconv = FALSE_;
|
|
for (i__ = l; i__ >= 1; --i__) {
|
|
canswap = TRUE_;
|
|
i__1 = l;
|
|
for (j = 1; j <= i__1; ++j) {
|
|
if (i__ != j && a[i__ + j * a_dim1] != 0.) {
|
|
canswap = FALSE_;
|
|
goto L100;
|
|
}
|
|
}
|
|
L100:
|
|
if (canswap) {
|
|
scale[l] = (doublereal)i__;
|
|
if (i__ != l) {
|
|
dswap_(&l, &a[i__ * a_dim1 + 1], &c__1, &a[l * a_dim1 + 1], &c__1);
|
|
i__1 = *n - k + 1;
|
|
dswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[l + k * a_dim1], lda);
|
|
}
|
|
noconv = TRUE_;
|
|
if (l == 1) {
|
|
*ilo = 1;
|
|
*ihi = 1;
|
|
return 0;
|
|
}
|
|
--l;
|
|
}
|
|
}
|
|
}
|
|
noconv = TRUE_;
|
|
while (noconv) {
|
|
noconv = FALSE_;
|
|
i__1 = l;
|
|
for (j = k; j <= i__1; ++j) {
|
|
canswap = TRUE_;
|
|
i__2 = l;
|
|
for (i__ = k; i__ <= i__2; ++i__) {
|
|
if (i__ != j && a[i__ + j * a_dim1] != 0.) {
|
|
canswap = FALSE_;
|
|
goto L200;
|
|
}
|
|
}
|
|
L200:
|
|
if (canswap) {
|
|
scale[k] = (doublereal)j;
|
|
if (j != k) {
|
|
dswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
|
|
i__2 = *n - k + 1;
|
|
dswap_(&i__2, &a[j + k * a_dim1], lda, &a[k + k * a_dim1], lda);
|
|
}
|
|
noconv = TRUE_;
|
|
++k;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
i__1 = l;
|
|
for (i__ = k; i__ <= i__1; ++i__) {
|
|
scale[i__] = 1.;
|
|
}
|
|
if (lsame_(job, (char *)"P", (ftnlen)1, (ftnlen)1)) {
|
|
*ilo = k;
|
|
*ihi = l;
|
|
return 0;
|
|
}
|
|
sfmin1 = dlamch_((char *)"S", (ftnlen)1) / dlamch_((char *)"P", (ftnlen)1);
|
|
sfmax1 = 1. / sfmin1;
|
|
sfmin2 = sfmin1 * 2.;
|
|
sfmax2 = 1. / sfmin2;
|
|
noconv = TRUE_;
|
|
while (noconv) {
|
|
noconv = FALSE_;
|
|
i__1 = l;
|
|
for (i__ = k; i__ <= i__1; ++i__) {
|
|
i__2 = l - k + 1;
|
|
c__ = dnrm2_(&i__2, &a[k + i__ * a_dim1], &c__1);
|
|
i__2 = l - k + 1;
|
|
r__ = dnrm2_(&i__2, &a[i__ + k * a_dim1], lda);
|
|
ica = idamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
|
|
ca = (d__1 = a[ica + i__ * a_dim1], abs(d__1));
|
|
i__2 = *n - k + 1;
|
|
ira = idamax_(&i__2, &a[i__ + k * a_dim1], lda);
|
|
ra = (d__1 = a[i__ + (ira + k - 1) * a_dim1], abs(d__1));
|
|
if (c__ == 0. || r__ == 0.) {
|
|
goto L300;
|
|
}
|
|
d__1 = c__ + ca + r__ + ra;
|
|
if (disnan_(&d__1)) {
|
|
*info = -3;
|
|
i__2 = -(*info);
|
|
xerbla_((char *)"DGEBAL", &i__2, (ftnlen)6);
|
|
return 0;
|
|
}
|
|
g = r__ / 2.;
|
|
f = 1.;
|
|
s = c__ + r__;
|
|
for (;;) {
|
|
d__1 = max(f, c__);
|
|
d__2 = min(r__, g);
|
|
if (!(c__ < g && max(d__1, ca) < sfmax2 && min(d__2, ra) > sfmin2)) break;
|
|
f *= 2.;
|
|
c__ *= 2.;
|
|
ca *= 2.;
|
|
r__ /= 2.;
|
|
g /= 2.;
|
|
ra /= 2.;
|
|
}
|
|
g = c__ / 2.;
|
|
for (;;) {
|
|
d__1 = min(f, c__), d__1 = min(d__1, g);
|
|
if (!(g >= r__ && max(r__, ra) < sfmax2 && min(d__1, ca) > sfmin2)) break;
|
|
f /= 2.;
|
|
c__ /= 2.;
|
|
g /= 2.;
|
|
ca /= 2.;
|
|
r__ *= 2.;
|
|
ra *= 2.;
|
|
}
|
|
if (c__ + r__ >= s * .95) {
|
|
goto L300;
|
|
}
|
|
if (f < 1. && scale[i__] < 1.) {
|
|
if (f * scale[i__] <= sfmin1) {
|
|
goto L300;
|
|
}
|
|
}
|
|
if (f > 1. && scale[i__] > 1.) {
|
|
if (scale[i__] >= sfmax1 / f) {
|
|
goto L300;
|
|
}
|
|
}
|
|
g = 1. / f;
|
|
scale[i__] *= f;
|
|
noconv = TRUE_;
|
|
i__2 = *n - k + 1;
|
|
dscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
|
|
dscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);
|
|
L300:;
|
|
}
|
|
}
|
|
*ilo = k;
|
|
*ihi = l;
|
|
return 0;
|
|
}
|
|
#ifdef __cplusplus
|
|
}
|
|
#endif
|