update linalg for ML-QUIP

2024-11-09 04:04:52 -05:00
parent 324e795237
commit a1a2a54f72
69 changed files with 15699 additions and 0 deletions
--- a/lib/linalg/dlasd1.cpp
+++ b/lib/linalg/dlasd1.cpp
@ -0,0 +1,96 @@
+#ifdef __cplusplus
+extern "C" {
+#endif
+#include "lmp_f2c.h"
+static integer c__0 = 0;
+static doublereal c_b7 = 1.;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+int dlasd1_(integer *nl, integer *nr, integer *sqre, doublereal *d__, doublereal *alpha,
+            doublereal *beta, doublereal *u, integer *ldu, doublereal *vt, integer *ldvt,
+            integer *idxq, integer *iwork, doublereal *work, integer *info)
+{
+    integer u_dim1, u_offset, vt_dim1, vt_offset, i__1;
+    doublereal d__1, d__2;
+    integer i__, k, m, n, n1, n2, iq, iz, iu2, ldq, idx, ldu2, ivt2, idxc, idxp, ldvt2;
+    extern int dlasd2_(integer *, integer *, integer *, integer *, doublereal *, doublereal *,
+                       doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *,
+                       doublereal *, doublereal *, integer *, doublereal *, integer *, integer *,
+                       integer *, integer *, integer *, integer *, integer *),
+        dlasd3_(integer *, integer *, integer *, integer *, doublereal *, doublereal *, integer *,
+                doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+                integer *, doublereal *, integer *, integer *, integer *, doublereal *, integer *),
+        dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *,
+                doublereal *, integer *, integer *, ftnlen),
+        dlamrg_(integer *, integer *, doublereal *, integer *, integer *, integer *);
+    integer isigma;
+    extern int xerbla_(char *, integer *, ftnlen);
+    doublereal orgnrm;
+    integer coltyp;
+    --d__;
+    u_dim1 = *ldu;
+    u_offset = 1 + u_dim1;
+    u -= u_offset;
+    vt_dim1 = *ldvt;
+    vt_offset = 1 + vt_dim1;
+    vt -= vt_offset;
+    --idxq;
+    --iwork;
+    --work;
+    *info = 0;
+    if (*nl < 1) {
+        *info = -1;
+    } else if (*nr < 1) {
+        *info = -2;
+    } else if (*sqre < 0 || *sqre > 1) {
+        *info = -3;
+    }
+    if (*info != 0) {
+        i__1 = -(*info);
+        xerbla_((char *)"DLASD1", &i__1, (ftnlen)6);
+        return 0;
+    }
+    n = *nl + *nr + 1;
+    m = n + *sqre;
+    ldu2 = n;
+    ldvt2 = m;
+    iz = 1;
+    isigma = iz + m;
+    iu2 = isigma + n;
+    ivt2 = iu2 + ldu2 * n;
+    iq = ivt2 + ldvt2 * m;
+    idx = 1;
+    idxc = idx + n;
+    coltyp = idxc + n;
+    idxp = coltyp + n;
+    d__1 = abs(*alpha), d__2 = abs(*beta);
+    orgnrm = max(d__1, d__2);
+    d__[*nl + 1] = 0.;
+    i__1 = n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+        if ((d__1 = d__[i__], abs(d__1)) > orgnrm) {
+            orgnrm = (d__1 = d__[i__], abs(d__1));
+        }
+    }
+    dlascl_((char *)"G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info, (ftnlen)1);
+    *alpha /= orgnrm;
+    *beta /= orgnrm;
+    dlasd2_(nl, nr, sqre, &k, &d__[1], &work[iz], alpha, beta, &u[u_offset], ldu, &vt[vt_offset],
+            ldvt, &work[isigma], &work[iu2], &ldu2, &work[ivt2], &ldvt2, &iwork[idxp], &iwork[idx],
+            &iwork[idxc], &idxq[1], &iwork[coltyp], info);
+    ldq = k;
+    dlasd3_(nl, nr, sqre, &k, &d__[1], &work[iq], &ldq, &work[isigma], &u[u_offset], ldu,
+            &work[iu2], &ldu2, &vt[vt_offset], ldvt, &work[ivt2], &ldvt2, &iwork[idxc],
+            &iwork[coltyp], &work[iz], info);
+    if (*info != 0) {
+        return 0;
+    }
+    dlascl_((char *)"G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info, (ftnlen)1);
+    n1 = k;
+    n2 = n - k;
+    dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &idxq[1]);
+    return 0;
+}
+#ifdef __cplusplus
+}
+#endif