307 lines
13 KiB
C++
307 lines
13 KiB
C++
#ifdef __cplusplus
|
|
extern "C" {
|
|
#endif
|
|
#include "lmp_f2c.h"
|
|
static integer c__13 = 13;
|
|
static integer c__15 = 15;
|
|
static integer c_n1 = -1;
|
|
static integer c__12 = 12;
|
|
static integer c__14 = 14;
|
|
static integer c__16 = 16;
|
|
static logical c_false = FALSE_;
|
|
static integer c__1 = 1;
|
|
static integer c__3 = 3;
|
|
int dlaqr0_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, doublereal *h__,
|
|
integer *ldh, doublereal *wr, doublereal *wi, integer *iloz, integer *ihiz,
|
|
doublereal *z__, integer *ldz, doublereal *work, integer *lwork, integer *info)
|
|
{
|
|
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
|
|
doublereal d__1, d__2, d__3, d__4;
|
|
integer i__, k;
|
|
doublereal aa, bb, cc, dd;
|
|
integer ld;
|
|
doublereal cs;
|
|
integer nh, it, ks, kt;
|
|
doublereal sn;
|
|
integer ku, kv, ls, ns;
|
|
doublereal ss;
|
|
integer nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin;
|
|
doublereal swap;
|
|
integer ktop;
|
|
doublereal zdum[1];
|
|
integer kacc22, itmax, nsmax, nwmax, kwtop;
|
|
extern int dlanv2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *,
|
|
doublereal *, doublereal *, doublereal *, doublereal *, doublereal *),
|
|
dlaqr3_(logical *, logical *, integer *, integer *, integer *, integer *, doublereal *,
|
|
integer *, integer *, integer *, doublereal *, integer *, integer *, integer *,
|
|
doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *,
|
|
integer *, integer *, doublereal *, integer *, doublereal *, integer *),
|
|
dlaqr4_(logical *, logical *, integer *, integer *, integer *, doublereal *, integer *,
|
|
doublereal *, doublereal *, integer *, integer *, doublereal *, integer *,
|
|
doublereal *, integer *, integer *),
|
|
dlaqr5_(logical *, logical *, integer *, integer *, integer *, integer *, integer *,
|
|
doublereal *, doublereal *, doublereal *, integer *, integer *, integer *,
|
|
doublereal *, integer *, doublereal *, integer *, doublereal *, integer *,
|
|
integer *, doublereal *, integer *, integer *, doublereal *, integer *);
|
|
integer nibble;
|
|
extern int dlahqr_(logical *, logical *, integer *, integer *, integer *, doublereal *,
|
|
integer *, doublereal *, doublereal *, integer *, integer *, doublereal *,
|
|
integer *, integer *),
|
|
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
|
|
ftnlen);
|
|
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *,
|
|
ftnlen, ftnlen);
|
|
char jbcmpz[2];
|
|
integer nwupbd;
|
|
logical sorted;
|
|
integer lwkopt;
|
|
h_dim1 = *ldh;
|
|
h_offset = 1 + h_dim1;
|
|
h__ -= h_offset;
|
|
--wr;
|
|
--wi;
|
|
z_dim1 = *ldz;
|
|
z_offset = 1 + z_dim1;
|
|
z__ -= z_offset;
|
|
--work;
|
|
*info = 0;
|
|
if (*n == 0) {
|
|
work[1] = 1.;
|
|
return 0;
|
|
}
|
|
if (*n <= 11) {
|
|
lwkopt = 1;
|
|
if (*lwork != -1) {
|
|
dlahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[1], iloz, ihiz,
|
|
&z__[z_offset], ldz, info);
|
|
}
|
|
} else {
|
|
*info = 0;
|
|
if (*wantt) {
|
|
*(unsigned char *)jbcmpz = 'S';
|
|
} else {
|
|
*(unsigned char *)jbcmpz = 'E';
|
|
}
|
|
if (*wantz) {
|
|
*(unsigned char *)&jbcmpz[1] = 'V';
|
|
} else {
|
|
*(unsigned char *)&jbcmpz[1] = 'N';
|
|
}
|
|
nwr = ilaenv_(&c__13, (char *)"DLAQR0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, (ftnlen)2);
|
|
nwr = max(2, nwr);
|
|
i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = min(i__1, i__2);
|
|
nwr = min(i__1, nwr);
|
|
nsr = ilaenv_(&c__15, (char *)"DLAQR0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, (ftnlen)2);
|
|
i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = min(i__1, i__2), i__2 = *ihi - *ilo;
|
|
nsr = min(i__1, i__2);
|
|
i__1 = 2, i__2 = nsr - nsr % 2;
|
|
nsr = max(i__1, i__2);
|
|
i__1 = nwr + 1;
|
|
dlaqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz, ihiz, &z__[z_offset],
|
|
ldz, &ls, &ld, &wr[1], &wi[1], &h__[h_offset], ldh, n, &h__[h_offset], ldh, n,
|
|
&h__[h_offset], ldh, &work[1], &c_n1);
|
|
i__1 = nsr * 3 / 2, i__2 = (integer)work[1];
|
|
lwkopt = max(i__1, i__2);
|
|
if (*lwork == -1) {
|
|
work[1] = (doublereal)lwkopt;
|
|
return 0;
|
|
}
|
|
nmin = ilaenv_(&c__12, (char *)"DLAQR0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, (ftnlen)2);
|
|
nmin = max(11, nmin);
|
|
nibble = ilaenv_(&c__14, (char *)"DLAQR0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, (ftnlen)2);
|
|
nibble = max(0, nibble);
|
|
kacc22 = ilaenv_(&c__16, (char *)"DLAQR0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, (ftnlen)2);
|
|
kacc22 = max(0, kacc22);
|
|
kacc22 = min(2, kacc22);
|
|
i__1 = (*n - 1) / 3, i__2 = *lwork / 2;
|
|
nwmax = min(i__1, i__2);
|
|
nw = nwmax;
|
|
i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3;
|
|
nsmax = min(i__1, i__2);
|
|
nsmax -= nsmax % 2;
|
|
ndfl = 1;
|
|
i__1 = 10, i__2 = *ihi - *ilo + 1;
|
|
itmax = max(i__1, i__2) * 30;
|
|
kbot = *ihi;
|
|
i__1 = itmax;
|
|
for (it = 1; it <= i__1; ++it) {
|
|
if (kbot < *ilo) {
|
|
goto L90;
|
|
}
|
|
i__2 = *ilo + 1;
|
|
for (k = kbot; k >= i__2; --k) {
|
|
if (h__[k + (k - 1) * h_dim1] == 0.) {
|
|
goto L20;
|
|
}
|
|
}
|
|
k = *ilo;
|
|
L20:
|
|
ktop = k;
|
|
nh = kbot - ktop + 1;
|
|
nwupbd = min(nh, nwmax);
|
|
if (ndfl < 5) {
|
|
nw = min(nwupbd, nwr);
|
|
} else {
|
|
i__2 = nwupbd, i__3 = nw << 1;
|
|
nw = min(i__2, i__3);
|
|
}
|
|
if (nw < nwmax) {
|
|
if (nw >= nh - 1) {
|
|
nw = nh;
|
|
} else {
|
|
kwtop = kbot - nw + 1;
|
|
if ((d__1 = h__[kwtop + (kwtop - 1) * h_dim1], abs(d__1)) >
|
|
(d__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1], abs(d__2))) {
|
|
++nw;
|
|
}
|
|
}
|
|
}
|
|
if (ndfl < 5) {
|
|
ndec = -1;
|
|
} else if (ndec >= 0 || nw >= nwupbd) {
|
|
++ndec;
|
|
if (nw - ndec < 2) {
|
|
ndec = 0;
|
|
}
|
|
nw -= ndec;
|
|
}
|
|
kv = *n - nw + 1;
|
|
kt = nw + 1;
|
|
nho = *n - nw - 1 - kt + 1;
|
|
kwv = nw + 2;
|
|
nve = *n - nw - kwv + 1;
|
|
dlaqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh, iloz, ihiz,
|
|
&z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[kv + h_dim1], ldh, &nho,
|
|
&h__[kv + kt * h_dim1], ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork);
|
|
kbot -= ld;
|
|
ks = kbot - ls + 1;
|
|
if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min(nmin, nwmax)) {
|
|
i__4 = 2, i__5 = kbot - ktop;
|
|
i__2 = min(nsmax, nsr), i__3 = max(i__4, i__5);
|
|
ns = min(i__2, i__3);
|
|
ns -= ns % 2;
|
|
if (ndfl % 6 == 0) {
|
|
ks = kbot - ns + 1;
|
|
i__3 = ks + 1, i__4 = ktop + 2;
|
|
i__2 = max(i__3, i__4);
|
|
for (i__ = kbot; i__ >= i__2; i__ += -2) {
|
|
ss = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) +
|
|
(d__2 = h__[i__ - 1 + (i__ - 2) * h_dim1], abs(d__2));
|
|
aa = ss * .75 + h__[i__ + i__ * h_dim1];
|
|
bb = ss;
|
|
cc = ss * -.4375;
|
|
dd = aa;
|
|
dlanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__],
|
|
&cs, &sn);
|
|
}
|
|
if (ks == ktop) {
|
|
wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1];
|
|
wi[ks + 1] = 0.;
|
|
wr[ks] = wr[ks + 1];
|
|
wi[ks] = wi[ks + 1];
|
|
}
|
|
} else {
|
|
if (kbot - ks + 1 <= ns / 2) {
|
|
ks = kbot - ns + 1;
|
|
kt = *n - ns + 1;
|
|
dlacpy_((char *)"A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, &h__[kt + h_dim1], ldh,
|
|
(ftnlen)1);
|
|
if (ns > nmin) {
|
|
dlaqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[kt + h_dim1], ldh,
|
|
&wr[ks], &wi[ks], &c__1, &c__1, zdum, &c__1, &work[1], lwork,
|
|
&inf);
|
|
} else {
|
|
dlahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[kt + h_dim1], ldh,
|
|
&wr[ks], &wi[ks], &c__1, &c__1, zdum, &c__1, &inf);
|
|
}
|
|
ks += inf;
|
|
if (ks >= kbot) {
|
|
aa = h__[kbot - 1 + (kbot - 1) * h_dim1];
|
|
cc = h__[kbot + (kbot - 1) * h_dim1];
|
|
bb = h__[kbot - 1 + kbot * h_dim1];
|
|
dd = h__[kbot + kbot * h_dim1];
|
|
dlanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[kbot - 1], &wr[kbot],
|
|
&wi[kbot], &cs, &sn);
|
|
ks = kbot - 1;
|
|
}
|
|
}
|
|
if (kbot - ks + 1 > ns) {
|
|
sorted = FALSE_;
|
|
i__2 = ks + 1;
|
|
for (k = kbot; k >= i__2; --k) {
|
|
if (sorted) {
|
|
goto L60;
|
|
}
|
|
sorted = TRUE_;
|
|
i__3 = k - 1;
|
|
for (i__ = ks; i__ <= i__3; ++i__) {
|
|
if ((d__1 = wr[i__], abs(d__1)) + (d__2 = wi[i__], abs(d__2)) <
|
|
(d__3 = wr[i__ + 1], abs(d__3)) +
|
|
(d__4 = wi[i__ + 1], abs(d__4))) {
|
|
sorted = FALSE_;
|
|
swap = wr[i__];
|
|
wr[i__] = wr[i__ + 1];
|
|
wr[i__ + 1] = swap;
|
|
swap = wi[i__];
|
|
wi[i__] = wi[i__ + 1];
|
|
wi[i__ + 1] = swap;
|
|
}
|
|
}
|
|
}
|
|
L60:;
|
|
}
|
|
i__2 = ks + 2;
|
|
for (i__ = kbot; i__ >= i__2; i__ += -2) {
|
|
if (wi[i__] != -wi[i__ - 1]) {
|
|
swap = wr[i__];
|
|
wr[i__] = wr[i__ - 1];
|
|
wr[i__ - 1] = wr[i__ - 2];
|
|
wr[i__ - 2] = swap;
|
|
swap = wi[i__];
|
|
wi[i__] = wi[i__ - 1];
|
|
wi[i__ - 1] = wi[i__ - 2];
|
|
wi[i__ - 2] = swap;
|
|
}
|
|
}
|
|
}
|
|
if (kbot - ks + 1 == 2) {
|
|
if (wi[kbot] == 0.) {
|
|
if ((d__1 = wr[kbot] - h__[kbot + kbot * h_dim1], abs(d__1)) <
|
|
(d__2 = wr[kbot - 1] - h__[kbot + kbot * h_dim1], abs(d__2))) {
|
|
wr[kbot - 1] = wr[kbot];
|
|
} else {
|
|
wr[kbot] = wr[kbot - 1];
|
|
}
|
|
}
|
|
}
|
|
i__2 = ns, i__3 = kbot - ks + 1;
|
|
ns = min(i__2, i__3);
|
|
ns -= ns % 2;
|
|
ks = kbot - ns + 1;
|
|
kdu = ns * 3 - 3;
|
|
ku = *n - kdu + 1;
|
|
kwh = kdu + 1;
|
|
nho = *n - kdu - 3 - (kdu + 1) + 1;
|
|
kwv = kdu + 4;
|
|
nve = *n - kdu - kwv + 1;
|
|
dlaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks], &wi[ks],
|
|
&h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, &work[1], &c__3,
|
|
&h__[ku + h_dim1], ldh, &nve, &h__[kwv + h_dim1], ldh, &nho,
|
|
&h__[ku + kwh * h_dim1], ldh);
|
|
}
|
|
if (ld > 0) {
|
|
ndfl = 1;
|
|
} else {
|
|
++ndfl;
|
|
}
|
|
}
|
|
*info = kbot;
|
|
L90:;
|
|
}
|
|
work[1] = (doublereal)lwkopt;
|
|
return 0;
|
|
}
|
|
#ifdef __cplusplus
|
|
}
|
|
#endif
|