update linalg for ML-QUIP
This commit is contained in:
Axel Kohlmeyer
282
lib/linalg/dlasd2.cpp
Normal file
282
lib/linalg/dlasd2.cpp
Normal file
@ -0,0 +1,282 @@
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
#include "lmp_f2c.h"
|
||||
static integer c__1 = 1;
|
||||
static doublereal c_b30 = 0.;
|
||||
int dlasd2_(integer *nl, integer *nr, integer *sqre, integer *k, doublereal *d__, doublereal *z__,
|
||||
doublereal *alpha, doublereal *beta, doublereal *u, integer *ldu, doublereal *vt,
|
||||
integer *ldvt, doublereal *dsigma, doublereal *u2, integer *ldu2, doublereal *vt2,
|
||||
integer *ldvt2, integer *idxp, integer *idx, integer *idxc, integer *idxq,
|
||||
integer *coltyp, integer *info)
|
||||
{
|
||||
integer u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, vt_offset, vt2_dim1, vt2_offset, i__1;
|
||||
doublereal d__1, d__2;
|
||||
doublereal c__;
|
||||
integer i__, j, m, n;
|
||||
doublereal s;
|
||||
integer k2;
|
||||
doublereal z1;
|
||||
integer ct, jp;
|
||||
doublereal eps, tau, tol;
|
||||
integer psm[4], nlp1, nlp2, idxi, idxj;
|
||||
extern int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *,
|
||||
doublereal *);
|
||||
integer ctot[4], idxjp;
|
||||
extern int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
|
||||
integer jprev;
|
||||
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *, ftnlen);
|
||||
extern int dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *),
|
||||
dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *,
|
||||
ftnlen),
|
||||
dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *,
|
||||
ftnlen),
|
||||
xerbla_(char *, integer *, ftnlen);
|
||||
doublereal hlftol;
|
||||
--d__;
|
||||
--z__;
|
||||
u_dim1 = *ldu;
|
||||
u_offset = 1 + u_dim1;
|
||||
u -= u_offset;
|
||||
vt_dim1 = *ldvt;
|
||||
vt_offset = 1 + vt_dim1;
|
||||
vt -= vt_offset;
|
||||
--dsigma;
|
||||
u2_dim1 = *ldu2;
|
||||
u2_offset = 1 + u2_dim1;
|
||||
u2 -= u2_offset;
|
||||
vt2_dim1 = *ldvt2;
|
||||
vt2_offset = 1 + vt2_dim1;
|
||||
vt2 -= vt2_offset;
|
||||
--idxp;
|
||||
--idx;
|
||||
--idxc;
|
||||
--idxq;
|
||||
--coltyp;
|
||||
*info = 0;
|
||||
if (*nl < 1) {
|
||||
*info = -1;
|
||||
} else if (*nr < 1) {
|
||||
*info = -2;
|
||||
} else if (*sqre != 1 && *sqre != 0) {
|
||||
*info = -3;
|
||||
}
|
||||
n = *nl + *nr + 1;
|
||||
m = n + *sqre;
|
||||
if (*ldu < n) {
|
||||
*info = -10;
|
||||
} else if (*ldvt < m) {
|
||||
*info = -12;
|
||||
} else if (*ldu2 < n) {
|
||||
*info = -15;
|
||||
} else if (*ldvt2 < m) {
|
||||
*info = -17;
|
||||
}
|
||||
if (*info != 0) {
|
||||
i__1 = -(*info);
|
||||
xerbla_((char *)"DLASD2", &i__1, (ftnlen)6);
|
||||
return 0;
|
||||
}
|
||||
nlp1 = *nl + 1;
|
||||
nlp2 = *nl + 2;
|
||||
z1 = *alpha * vt[nlp1 + nlp1 * vt_dim1];
|
||||
z__[1] = z1;
|
||||
for (i__ = *nl; i__ >= 1; --i__) {
|
||||
z__[i__ + 1] = *alpha * vt[i__ + nlp1 * vt_dim1];
|
||||
d__[i__ + 1] = d__[i__];
|
||||
idxq[i__ + 1] = idxq[i__] + 1;
|
||||
}
|
||||
i__1 = m;
|
||||
for (i__ = nlp2; i__ <= i__1; ++i__) {
|
||||
z__[i__] = *beta * vt[i__ + nlp2 * vt_dim1];
|
||||
}
|
||||
i__1 = nlp1;
|
||||
for (i__ = 2; i__ <= i__1; ++i__) {
|
||||
coltyp[i__] = 1;
|
||||
}
|
||||
i__1 = n;
|
||||
for (i__ = nlp2; i__ <= i__1; ++i__) {
|
||||
coltyp[i__] = 2;
|
||||
}
|
||||
i__1 = n;
|
||||
for (i__ = nlp2; i__ <= i__1; ++i__) {
|
||||
idxq[i__] += nlp1;
|
||||
}
|
||||
i__1 = n;
|
||||
for (i__ = 2; i__ <= i__1; ++i__) {
|
||||
dsigma[i__] = d__[idxq[i__]];
|
||||
u2[i__ + u2_dim1] = z__[idxq[i__]];
|
||||
idxc[i__] = coltyp[idxq[i__]];
|
||||
}
|
||||
dlamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]);
|
||||
i__1 = n;
|
||||
for (i__ = 2; i__ <= i__1; ++i__) {
|
||||
idxi = idx[i__] + 1;
|
||||
d__[i__] = dsigma[idxi];
|
||||
z__[i__] = u2[idxi + u2_dim1];
|
||||
coltyp[i__] = idxc[idxi];
|
||||
}
|
||||
eps = dlamch_((char *)"Epsilon", (ftnlen)7);
|
||||
d__1 = abs(*alpha), d__2 = abs(*beta);
|
||||
tol = max(d__1, d__2);
|
||||
d__2 = (d__1 = d__[n], abs(d__1));
|
||||
tol = eps * 8. * max(d__2, tol);
|
||||
*k = 1;
|
||||
k2 = n + 1;
|
||||
i__1 = n;
|
||||
for (j = 2; j <= i__1; ++j) {
|
||||
if ((d__1 = z__[j], abs(d__1)) <= tol) {
|
||||
--k2;
|
||||
idxp[k2] = j;
|
||||
coltyp[j] = 4;
|
||||
if (j == n) {
|
||||
goto L120;
|
||||
}
|
||||
} else {
|
||||
jprev = j;
|
||||
goto L90;
|
||||
}
|
||||
}
|
||||
L90:
|
||||
j = jprev;
|
||||
L100:
|
||||
++j;
|
||||
if (j > n) {
|
||||
goto L110;
|
||||
}
|
||||
if ((d__1 = z__[j], abs(d__1)) <= tol) {
|
||||
--k2;
|
||||
idxp[k2] = j;
|
||||
coltyp[j] = 4;
|
||||
} else {
|
||||
if ((d__1 = d__[j] - d__[jprev], abs(d__1)) <= tol) {
|
||||
s = z__[jprev];
|
||||
c__ = z__[j];
|
||||
tau = dlapy2_(&c__, &s);
|
||||
c__ /= tau;
|
||||
s = -s / tau;
|
||||
z__[j] = tau;
|
||||
z__[jprev] = 0.;
|
||||
idxjp = idxq[idx[jprev] + 1];
|
||||
idxj = idxq[idx[j] + 1];
|
||||
if (idxjp <= nlp1) {
|
||||
--idxjp;
|
||||
}
|
||||
if (idxj <= nlp1) {
|
||||
--idxj;
|
||||
}
|
||||
drot_(&n, &u[idxjp * u_dim1 + 1], &c__1, &u[idxj * u_dim1 + 1], &c__1, &c__, &s);
|
||||
drot_(&m, &vt[idxjp + vt_dim1], ldvt, &vt[idxj + vt_dim1], ldvt, &c__, &s);
|
||||
if (coltyp[j] != coltyp[jprev]) {
|
||||
coltyp[j] = 3;
|
||||
}
|
||||
coltyp[jprev] = 4;
|
||||
--k2;
|
||||
idxp[k2] = jprev;
|
||||
jprev = j;
|
||||
} else {
|
||||
++(*k);
|
||||
u2[*k + u2_dim1] = z__[jprev];
|
||||
dsigma[*k] = d__[jprev];
|
||||
idxp[*k] = jprev;
|
||||
jprev = j;
|
||||
}
|
||||
}
|
||||
goto L100;
|
||||
L110:
|
||||
++(*k);
|
||||
u2[*k + u2_dim1] = z__[jprev];
|
||||
dsigma[*k] = d__[jprev];
|
||||
idxp[*k] = jprev;
|
||||
L120:
|
||||
for (j = 1; j <= 4; ++j) {
|
||||
ctot[j - 1] = 0;
|
||||
}
|
||||
i__1 = n;
|
||||
for (j = 2; j <= i__1; ++j) {
|
||||
ct = coltyp[j];
|
||||
++ctot[ct - 1];
|
||||
}
|
||||
psm[0] = 2;
|
||||
psm[1] = ctot[0] + 2;
|
||||
psm[2] = psm[1] + ctot[1];
|
||||
psm[3] = psm[2] + ctot[2];
|
||||
i__1 = n;
|
||||
for (j = 2; j <= i__1; ++j) {
|
||||
jp = idxp[j];
|
||||
ct = coltyp[jp];
|
||||
idxc[psm[ct - 1]] = j;
|
||||
++psm[ct - 1];
|
||||
}
|
||||
i__1 = n;
|
||||
for (j = 2; j <= i__1; ++j) {
|
||||
jp = idxp[j];
|
||||
dsigma[j] = d__[jp];
|
||||
idxj = idxq[idx[idxp[idxc[j]]] + 1];
|
||||
if (idxj <= nlp1) {
|
||||
--idxj;
|
||||
}
|
||||
dcopy_(&n, &u[idxj * u_dim1 + 1], &c__1, &u2[j * u2_dim1 + 1], &c__1);
|
||||
dcopy_(&m, &vt[idxj + vt_dim1], ldvt, &vt2[j + vt2_dim1], ldvt2);
|
||||
}
|
||||
dsigma[1] = 0.;
|
||||
hlftol = tol / 2.;
|
||||
if (abs(dsigma[2]) <= hlftol) {
|
||||
dsigma[2] = hlftol;
|
||||
}
|
||||
if (m > n) {
|
||||
z__[1] = dlapy2_(&z1, &z__[m]);
|
||||
if (z__[1] <= tol) {
|
||||
c__ = 1.;
|
||||
s = 0.;
|
||||
z__[1] = tol;
|
||||
} else {
|
||||
c__ = z1 / z__[1];
|
||||
s = z__[m] / z__[1];
|
||||
}
|
||||
} else {
|
||||
if (abs(z1) <= tol) {
|
||||
z__[1] = tol;
|
||||
} else {
|
||||
z__[1] = z1;
|
||||
}
|
||||
}
|
||||
i__1 = *k - 1;
|
||||
dcopy_(&i__1, &u2[u2_dim1 + 2], &c__1, &z__[2], &c__1);
|
||||
dlaset_((char *)"A", &n, &c__1, &c_b30, &c_b30, &u2[u2_offset], ldu2, (ftnlen)1);
|
||||
u2[nlp1 + u2_dim1] = 1.;
|
||||
if (m > n) {
|
||||
i__1 = nlp1;
|
||||
for (i__ = 1; i__ <= i__1; ++i__) {
|
||||
vt[m + i__ * vt_dim1] = -s * vt[nlp1 + i__ * vt_dim1];
|
||||
vt2[i__ * vt2_dim1 + 1] = c__ * vt[nlp1 + i__ * vt_dim1];
|
||||
}
|
||||
i__1 = m;
|
||||
for (i__ = nlp2; i__ <= i__1; ++i__) {
|
||||
vt2[i__ * vt2_dim1 + 1] = s * vt[m + i__ * vt_dim1];
|
||||
vt[m + i__ * vt_dim1] = c__ * vt[m + i__ * vt_dim1];
|
||||
}
|
||||
} else {
|
||||
dcopy_(&m, &vt[nlp1 + vt_dim1], ldvt, &vt2[vt2_dim1 + 1], ldvt2);
|
||||
}
|
||||
if (m > n) {
|
||||
dcopy_(&m, &vt[m + vt_dim1], ldvt, &vt2[m + vt2_dim1], ldvt2);
|
||||
}
|
||||
if (n > *k) {
|
||||
i__1 = n - *k;
|
||||
dcopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1);
|
||||
i__1 = n - *k;
|
||||
dlacpy_((char *)"A", &n, &i__1, &u2[(*k + 1) * u2_dim1 + 1], ldu2, &u[(*k + 1) * u_dim1 + 1], ldu,
|
||||
(ftnlen)1);
|
||||
i__1 = n - *k;
|
||||
dlacpy_((char *)"A", &i__1, &m, &vt2[*k + 1 + vt2_dim1], ldvt2, &vt[*k + 1 + vt_dim1], ldvt,
|
||||
(ftnlen)1);
|
||||
}
|
||||
for (j = 1; j <= 4; ++j) {
|
||||
coltyp[j] = ctot[j - 1];
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
Reference in New Issue
Block a user