bool schur(const mat &A, mat &U, mat &T) { it_assert_debug(A.rows() == A.cols(), "schur(): Matrix is not square"); char jobvs = 'V'; char sort = 'N'; int info; int n = A.rows(); int lda = n; int ldvs = n; int lwork = 3 * n; // This may be choosen better! int sdim = 0; vec wr(n); vec wi(n); vec work(lwork); T.set_size(lda, n, false); U.set_size(ldvs, n, false); T = A; // The routine overwrites input matrix with eigenvectors dgees_(&jobvs, &sort, 0, &n, T._data(), &lda, &sdim, wr._data(), wi._data(), U._data(), &ldvs, work._data(), &lwork, 0, &info); return (info == 0); }
void Stiefel::ConRetraction(Variable *x, Vector *etax, Variable *result) const { // only accept intrinsic approach const double *V = etax->ObtainReadData(); Vector *exetax = nullptr; double *M = new double[3 * n * n + 2 * n]; double *wr = M + n * n; double *wi = wr + n; double *Vs = wi + n; double *VsT = Vs + n * n; double r2 = sqrt(2.0); integer idx = 0; for (integer i = 0; i < p; i++) { M[i + i * n] = 0; for (integer j = i + 1; j < p; j++) { M[j + i * n] = V[idx] / r2; M[i + j * n] = -M[j + i * n]; idx++; } } for (integer i = 0; i < p; i++) { for (integer j = p; j < n; j++) { M[j + i * n] = V[idx]; M[i + j * n] = -V[idx]; idx++; } } for (integer i = p; i < n; i++) { for (integer j = p; j < n; j++) { M[j + i * n] = 0; } } char *jobv = const_cast<char *> ("V"), *sortn = const_cast<char *> ("N"); integer N = n, P = p, NmP = n - p, sdim, info; integer lwork = -1; double lworkopt; dgees_(jobv, sortn, nullptr, &N, M, &N, &sdim, wr, wi, Vs, &N, &lworkopt, &lwork, nullptr, &info); lwork = static_cast<integer> (lworkopt); double *work = new double[lwork]; dgees_(jobv, sortn, nullptr, &N, M, &N, &sdim, wr, wi, Vs, &N, work, &lwork, nullptr, &info); char *transn = const_cast<char *> ("n"), *transt = const_cast<char *> ("t"); double cosv, sinv; integer two = 2, inc = 1; double one = 1, zero = 0; double block[4]; for (integer i = 0; i < n; i++) { if (i + 1 < n && fabs(M[i + (i + 1) * n]) > std::numeric_limits<double>::epsilon()) { cosv = cos(M[i + (i + 1) * n]); sinv = sin(M[i + (i + 1) * n]); block[0] = cosv; block[1] = -sinv; block[2] = sinv; block[3] = cosv; dgemm_(transn, transn, &N, &two, &two, &one, Vs + i * n, &N, block, &two, &zero, VsT + i * n, &N); i++; } else { dcopy_(&N, Vs + i * n, &inc, VsT + i * n, &inc); } } dgemm_(transn, transt, &N, &N, &N, &one, VsT, &N, Vs, &N, &zero, M, &N); if (!x->TempDataExist("Perp")) { ObtainPerp(x); } const SharedSpace *SharedSpacePerp = x->ObtainReadTempData("Perp"); const double *Perp = SharedSpacePerp->ObtainReadData(); const double *xM = x->ObtainReadData(); double *resultM = result->ObtainWriteEntireData(); SharedSpace *ResultSharedPerp = new SharedSpace(2, n, n - p); double *ResultPerp = ResultSharedPerp->ObtainWriteEntireData(); dgemm_(transn, transn, &P, &P, &P, &one, const_cast<double *> (xM), &N, M, &N, &zero, resultM, &N); dgemm_(transn, transn, &P, &P, &NmP, &one, const_cast<double *> (Perp), &N, M + p, &N, &one, resultM, &N); dgemm_(transn, transn, &NmP, &P, &P, &one, const_cast<double *> (xM + p), &N, M, &N, &zero, resultM + p, &N); dgemm_(transn, transn, &NmP, &P, &NmP, &one, const_cast<double *> (Perp + p), &N, M + p, &N, &one, resultM + p, &N); dgemm_(transn, transn, &P, &NmP, &P, &one, const_cast<double *> (xM), &N, M + n * p, &N, &zero, ResultPerp, &N); dgemm_(transn, transn, &P, &NmP, &NmP, &one, const_cast<double *> (Perp), &N, M + n * p + p, &N, &one, ResultPerp, &N); dgemm_(transn, transn, &NmP, &NmP, &P, &one, const_cast<double *> (xM + p), &N, M + n * p, &N, &zero, ResultPerp + p, &N); dgemm_(transn, transn, &NmP, &NmP, &NmP, &one, const_cast<double *> (Perp + p), &N, M + n * p + p, &N, &one, ResultPerp + p, &N); result->AddToTempData("Perp", ResultSharedPerp); delete[] work; delete[] M; };
/* Subroutine */ int derred_(char *path, integer *nunit) { /* Format strings */ static char fmt_9999[] = "(1x,a6,\002 passed the tests of the error exit" "s (\002,i3,\002 tests done)\002)"; static char fmt_9998[] = "(\002 *** \002,a6,\002 failed the tests of the" " error exits ***\002)"; /* Builtin functions */ integer s_wsle(cilist *), e_wsle(void); /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Local variables */ static integer info, sdim; static doublereal a[16] /* was [4][4] */; static logical b[4]; static integer i__, j; static doublereal s[4], u[16] /* was [4][4] */, w[16]; extern /* Subroutine */ int dgees_(char *, char *, L_fp, integer *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, logical *, integer *), dgeev_(char *, char *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, integer *); static doublereal abnrm; static char c2[2]; static doublereal r1[4], r2[4]; extern /* Subroutine */ int dgesdd_(char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, integer *, integer *); static integer iw[8]; static doublereal wi[4]; static integer nt; static doublereal vl[16] /* was [4][4] */, vr[16] /* was [4][4] */, wr[4], vt[16] /* was [4][4] */; extern /* Subroutine */ int dgesvd_(char *, char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, integer *); extern logical dslect_(); extern /* Subroutine */ int dgeesx_(char *, char *, L_fp, char *, integer *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal * , integer *, integer *, integer *, logical *, integer *); extern logical lsamen_(integer *, char *, char *); extern /* Subroutine */ int dgeevx_(char *, char *, char *, char *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *, integer *), chkxer_(char *, integer *, integer *, logical *, logical *); static integer ihi, ilo; /* Fortran I/O blocks */ static cilist io___1 = { 0, 0, 0, 0, 0 }; static cilist io___24 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___25 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___26 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___27 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___28 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___29 = { 0, 0, 0, fmt_9998, 0 }; #define a_ref(a_1,a_2) a[(a_2)*4 + a_1 - 5] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University December 22, 1999 Purpose ======= DERRED tests the error exits for the eigenvalue driver routines for DOUBLE PRECISION matrices: PATH driver description ---- ------ ----------- SEV DGEEV find eigenvalues/eigenvectors for nonsymmetric A SES DGEES find eigenvalues/Schur form for nonsymmetric A SVX DGEEVX SGEEV + balancing and condition estimation SSX DGEESX SGEES + balancing and condition estimation DBD DGESVD compute SVD of an M-by-N matrix A DGESDD compute SVD of an M-by-N matrix A (by divide and conquer) Arguments ========= PATH (input) CHARACTER*3 The LAPACK path name for the routines to be tested. NUNIT (input) INTEGER The unit number for output. ===================================================================== */ infoc_1.nout = *nunit; io___1.ciunit = infoc_1.nout; s_wsle(&io___1); e_wsle(); s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2); /* Initialize A */ for (j = 1; j <= 4; ++j) { for (i__ = 1; i__ <= 4; ++i__) { a_ref(i__, j) = 0.; /* L10: */ } /* L20: */ } for (i__ = 1; i__ <= 4; ++i__) { a_ref(i__, i__) = 1.; /* L30: */ } infoc_1.ok = TRUE_; nt = 0; if (lsamen_(&c__2, c2, "EV")) { /* Test DGEEV */ s_copy(srnamc_1.srnamt, "DGEEV ", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; dgeev_("X", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, & c__1, &info); chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; dgeev_("N", "X", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, & c__1, &info); chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; dgeev_("N", "N", &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, & c__1, &info); chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; dgeev_("N", "N", &c__2, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, & c__6, &info); chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 9; dgeev_("V", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &c__1, w, & c__8, &info); chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 11; dgeev_("N", "V", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &c__1, w, & c__8, &info); chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 13; dgeev_("V", "V", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, & c__3, &info); chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 7; } else if (lsamen_(&c__2, c2, "ES")) { /* Test DGEES */ s_copy(srnamc_1.srnamt, "DGEES ", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; dgees_("X", "N", (L_fp)dslect_, &c__0, a, &c__1, &sdim, wr, wi, vl, & c__1, w, &c__1, b, &info); chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; dgees_("N", "X", (L_fp)dslect_, &c__0, a, &c__1, &sdim, wr, wi, vl, & c__1, w, &c__1, b, &info); chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; dgees_("N", "S", (L_fp)dslect_, &c_n1, a, &c__1, &sdim, wr, wi, vl, & c__1, w, &c__1, b, &info); chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; dgees_("N", "S", (L_fp)dslect_, &c__2, a, &c__1, &sdim, wr, wi, vl, & c__1, w, &c__6, b, &info); chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 11; dgees_("V", "S", (L_fp)dslect_, &c__2, a, &c__2, &sdim, wr, wi, vl, & c__1, w, &c__6, b, &info); chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 13; dgees_("N", "S", (L_fp)dslect_, &c__1, a, &c__1, &sdim, wr, wi, vl, & c__1, w, &c__2, b, &info); chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 6; } else if (lsamen_(&c__2, c2, "VX")) { /* Test DGEEVX */ s_copy(srnamc_1.srnamt, "DGEEVX", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; dgeevx_("X", "N", "N", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, & c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info); chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; dgeevx_("N", "X", "N", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, & c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info); chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; dgeevx_("N", "N", "X", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, & c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info); chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; dgeevx_("N", "N", "N", "X", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, & c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info); chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; dgeevx_("N", "N", "N", "N", &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, & c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info); chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; dgeevx_("N", "N", "N", "N", &c__2, a, &c__1, wr, wi, vl, &c__1, vr, & c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info); chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 11; dgeevx_("N", "V", "N", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, & c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__6, iw, &info); chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 13; dgeevx_("N", "N", "V", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, & c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__6, iw, &info); chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 21; dgeevx_("N", "N", "N", "N", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, & c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info); chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 21; dgeevx_("N", "V", "N", "N", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, & c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__2, iw, &info); chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 21; dgeevx_("N", "N", "V", "V", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, & c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__3, iw, &info); chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 11; } else if (lsamen_(&c__2, c2, "SX")) { /* Test DGEESX */ s_copy(srnamc_1.srnamt, "DGEESX", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; dgeesx_("X", "N", (L_fp)dslect_, "N", &c__0, a, &c__1, &sdim, wr, wi, vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info); chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; dgeesx_("N", "X", (L_fp)dslect_, "N", &c__0, a, &c__1, &sdim, wr, wi, vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info); chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; dgeesx_("N", "N", (L_fp)dslect_, "X", &c__0, a, &c__1, &sdim, wr, wi, vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info); chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; dgeesx_("N", "N", (L_fp)dslect_, "N", &c_n1, a, &c__1, &sdim, wr, wi, vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info); chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; dgeesx_("N", "N", (L_fp)dslect_, "N", &c__2, a, &c__1, &sdim, wr, wi, vl, &c__1, r1, r2, w, &c__6, iw, &c__1, b, &info); chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 12; dgeesx_("V", "N", (L_fp)dslect_, "N", &c__2, a, &c__2, &sdim, wr, wi, vl, &c__1, r1, r2, w, &c__6, iw, &c__1, b, &info); chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 16; dgeesx_("N", "N", (L_fp)dslect_, "N", &c__1, a, &c__1, &sdim, wr, wi, vl, &c__1, r1, r2, w, &c__2, iw, &c__1, b, &info); chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 7; } else if (lsamen_(&c__2, c2, "BD")) { /* Test DGESVD */ s_copy(srnamc_1.srnamt, "DGESVD", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; dgesvd_("X", "N", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, & c__1, &info); chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; dgesvd_("N", "X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, & c__1, &info); chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; dgesvd_("O", "O", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, & c__1, &info); chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; dgesvd_("N", "N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, & c__1, &info); chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; dgesvd_("N", "N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, & c__1, &info); chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; dgesvd_("N", "N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, & c__5, &info); chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 9; dgesvd_("A", "N", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, & c__5, &info); chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 11; dgesvd_("N", "A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, & c__5, &info); chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 8; if (infoc_1.ok) { io___24.ciunit = infoc_1.nout; s_wsfe(&io___24); do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6); do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer)); e_wsfe(); } else { io___25.ciunit = infoc_1.nout; s_wsfe(&io___25); e_wsfe(); } /* Test DGESDD */ s_copy(srnamc_1.srnamt, "DGESDD", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; dgesdd_("X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1, iw, &info); chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; dgesdd_("N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1, iw, &info); chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; dgesdd_("N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1, iw, &info); chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; dgesdd_("N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5, iw, &info); chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; dgesdd_("A", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &c__5, iw, &info); chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 10; dgesdd_("A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5, iw, &info); chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += -2; if (infoc_1.ok) { io___26.ciunit = infoc_1.nout; s_wsfe(&io___26); do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6); do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer)); e_wsfe(); } else { io___27.ciunit = infoc_1.nout; s_wsfe(&io___27); e_wsfe(); } } /* Print a summary line. */ if (! lsamen_(&c__2, c2, "BD")) { if (infoc_1.ok) { io___28.ciunit = infoc_1.nout; s_wsfe(&io___28); do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6); do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer)); e_wsfe(); } else { io___29.ciunit = infoc_1.nout; s_wsfe(&io___29); e_wsfe(); } } return 0; /* End of DERRED */ } /* derred_ */
int CLNAMethod::calculateCovarianceMatrixReduced() { // code snippet: transform something into particle space: // *(metabs[i]->getCompartment())->getValue()*mpModel->getQuantity2NumberFactor(); assert(mpModel); CCopasiVector< CMetab > & metabs = mpModel->getMetabolitesX(); CCopasiVector< CReaction > & reacs = mpModel->getReactions(); const CVector< C_FLOAT64 > & ParticleFlux = mpModel->getParticleFlux(); size_t numReacs = reacs.size(); // We need the number of independent metabolites determined by // reactions. size_t numMetabs = mpModel->getNumIndependentReactionMetabs(); //#ifdef DEBUG std::cout << "LNA (start)" << std::endl; std::cout << "Metabolites:" << std::endl << metabs << std::endl; std::cout << "No. of independent metabolites (head of metabolites' vector): " << numMetabs << std::endl; std::cout << "Reactions:" << std::endl << reacs << std::endl; //#endif // DEBUG size_t i, j, k, b_i, b_j; CMetab * mpMetabolite; C_FLOAT64 balance_i, balance_j, BContrib; // calculate covariances // first, set BMatrix (reduced) to zero mBMatrixReduced.resize(numMetabs, numMetabs); mBMatrixReduced = 0.0; // second, set CovarianceMatrixReduced to zero mCovarianceMatrixReduced.resize(numMetabs, numMetabs); mCovarianceMatrixReduced = 0.0; // then, calculate the contribution for each reaction // and add these contributions to the respective mBMatrix elements // only consider independent metabolites determined by reactions, // e.g. those that contribute to the reduced stoichiometry matrix. // Note: This could also be computed using mRedStoi in CModel. // However, then it would probably be less efficient for very // big systems since mRedStoi should be sparse there. for (k = 0; k < numReacs; k++) { const CCopasiVector <CChemEqElement> * balances = &reacs[k]->getChemEq().getBalances(); for (b_i = 0; b_i < balances->size(); b_i++) { mpMetabolite = const_cast < CMetab* >((*balances)[b_i]->getMetabolite()); i = metabs.getIndex(mpMetabolite); balance_i = (*balances)[b_i]->getMultiplicity(); if ((mpMetabolite->getStatus() != CModelEntity::REACTIONS) || (mpMetabolite->isDependent())) balance_i = 0.0; for (b_j = 0; b_j < balances->size(); b_j++) { mpMetabolite = const_cast < CMetab* >((*balances)[b_j]->getMetabolite()); j = metabs.getIndex(mpMetabolite); balance_j = (*balances)[b_j]->getMultiplicity(); if ((mpMetabolite->getStatus() != CModelEntity::REACTIONS) || (mpMetabolite->isDependent())) balance_j = 0.0; BContrib = ParticleFlux[k] * balance_i * balance_j; mBMatrixReduced[i][j] += BContrib; } } } // finally, solve the Lyapunov equation A*C + C*A^T + B = 0 for C // using the Bartels & Stewart algorithm (1972) // 1. (Schur) transform the Jacobian matrix A (reduced) and its transpose At // get the Jacobian (reduced) C_FLOAT64 derivationFactor = 1e-6; C_FLOAT64 resolution = 1e-12; mpModel->calculateJacobianX(mJacobianReduced, derivationFactor, resolution); //#ifdef DEBUG std::cout << "Jacobian (reduced):" << std::endl << mJacobianReduced << std::endl; //#endif // DEBUG // copy the Jacobian (reduced) into A CMatrix< C_FLOAT64 > A; A.resize(mJacobianReduced.numRows(), mJacobianReduced.numCols()); C_FLOAT64 * pA = A.array(); C_FLOAT64 * pAEnd = pA + A.size(); const C_FLOAT64 * pMatrix = mJacobianReduced.array(); for (; pA != pAEnd; ++pA, ++pMatrix) { *pA = *pMatrix; if (!finite(*pA) && !isnan(*pA)) { if (*pA > 0) *pA = std::numeric_limits< C_FLOAT64 >::max(); else *pA = - std::numeric_limits< C_FLOAT64 >::max(); } } //#ifdef DEBUG std::cout << "A:" << std::endl << A << std::endl; //#endif // DEBUG char jobvs = 'V'; // Schur vectors are computed char sort = 'N'; // Eigenvalues are not ordered C_INT n = (C_INT)A.numRows(); C_INT lda = n > 1 ? n : 1; C_INT sdim; // output CVector< C_FLOAT64 > wr_A; wr_A.resize((size_t)n); CVector< C_FLOAT64 > wi_A; wi_A.resize((size_t)n); CMatrix< C_FLOAT64> vs_A; // output (unitary matrix) C_INT ldvs_A = n; vs_A.resize((size_t)ldvs_A, (size_t)ldvs_A); CVector< C_FLOAT64 > work = 1; C_INT lwork; C_INT * pbwork = NULL; C_INT info; // LWORK workspace query lwork = -1; dgees_(&jobvs, &sort, NULL, &n, A.array(), &lda, &sdim, wr_A.array(), wi_A.array(), vs_A.array(), &ldvs_A, work.array(), &lwork, pbwork, &info); if (info != 0) { // TODO(juergen): add appropriate exception message(s)! // CCopasiMessage(CCopasiMessage::EXCEPTION, MCLNA + 1, -mInfo); } lwork = (C_INT) work[0]; work.resize((size_t)lwork); dgees_(&jobvs, &sort, NULL, &n, A.array(), // input: matrix / output: real Schur form &lda, &sdim, wr_A.array(), wi_A.array(), vs_A.array(), &ldvs_A, work.array(), &lwork, pbwork, &info); if (info != 0) { // TODO(juergen): add appropriate exception message(s)! // CCopasiMessage(CCopasiMessage::EXCEPTION, MCLNA + 1, -mInfo); } //#ifdef DEBUG std::cout << "Real Schur Form A:" << std::endl << A << std::endl; std::cout << "Unitary Matrix A:" << std::endl << vs_A << std::endl; //#endif // DEBUG // now, (Schur) transform the transposed Jacobian (reduced) // copy the transposed Jacobian (reduced) into At CMatrix< C_FLOAT64 > At; At.resize(mJacobianReduced.numCols(), mJacobianReduced.numRows()); for (i = 0; i < mJacobianReduced.numRows(); i++) { for (j = 0; j < mJacobianReduced.numCols(); j++) { At[j][i] = mJacobianReduced[i][j]; if (!finite(At[j][i]) && !isnan(At[j][i])) { if (At[j][i] > 0) At[j][i] = std::numeric_limits< C_FLOAT64 >::max(); else At[j][i] = - std::numeric_limits< C_FLOAT64 >::max(); } } } //#ifdef DEBUG std::cout << "At:" << std::endl << At << std::endl; //#endif // DEBUG jobvs = 'V'; // Schur vectors are computed sort = 'N'; // Eigenvalues are not ordered n = (C_INT)At.numRows(); lda = n > 1 ? n : 1; // C_INT sdim; // output CVector< C_FLOAT64 > wr_At; wr_At.resize((size_t)n); CVector< C_FLOAT64 > wi_At; wi_At.resize((size_t)n); CMatrix< C_FLOAT64 > vs_At; // output (unitary matrix) C_INT ldvs_At = n; vs_At.resize((size_t)ldvs_At, (size_t)ldvs_At); work = 1; // C_INT lwork; pbwork = NULL; // C_INT info; // LWORK workspace query lwork = -1; dgees_(&jobvs, &sort, NULL, &n, At.array(), &lda, &sdim, wr_At.array(), wi_At.array(), vs_At.array(), &ldvs_At, work.array(), &lwork, pbwork, &info); if (info != 0) { // TODO(juergen): add appropriate exception message(s)! // CCopasiMessage(CCopasiMessage::EXCEPTION, MCLNA + 1, -mInfo); } lwork = (C_INT) work[0]; work.resize((size_t)lwork); dgees_(&jobvs, &sort, NULL, &n, At.array(), // input: matrix / output: real Schur form &lda, &sdim, wr_At.array(), wi_At.array(), vs_At.array(), &ldvs_At, work.array(), &lwork, pbwork, &info); if (info != 0) { // TODO(juergen): add appropriate exception message(s)! // CCopasiMessage(CCopasiMessage::EXCEPTION, MCLNA + 1, -mInfo); } //#ifdef DEBUG std::cout << "Real Schur Form At:" << std::endl << At << std::endl; std::cout << "Unitary Matrix At:" << std::endl << vs_At << std::endl; //#endif // DEBUG // 2. transform the mBMatrixReduced B to new coordinates // BMatrixReduced_transformed = (unitary At)^T * mBMatrixReduced * (unitary A); char transa = 'T'; // (unitary A) will be transposed char transb = 'N'; // mBMatrixReduced will not be transposed C_FLOAT64 alpha = 1.0; C_FLOAT64 beta = 0.0; CMatrix< C_FLOAT64 > D; C_INT ldd = n; D.resize((size_t)n, (size_t)n); dgemm_(&transa, &transb, &n, &n, &n, &alpha, vs_At.array(), &n, mBMatrixReduced.array(), &n, &beta, D.array(), // output: multiplied matrix &ldd); transa = 'N'; CMatrix< C_FLOAT64 > BMatrixReduced_transformed; C_INT BMatrixReduced_transformed_d = n; BMatrixReduced_transformed.resize((size_t)n, (size_t)n); dgemm_(&transa, &transb, &n, &n, &n, &alpha, D.array(), &n, vs_A.array(), // (unitary At) &n, &beta, BMatrixReduced_transformed.array(), &BMatrixReduced_transformed_d); //#ifdef DEBUG std::cout << "Transformed B Matrix (reduced):" << std::endl << BMatrixReduced_transformed << std::endl; //#endif // DEBUG // 3. Solve the simplified Lyapunov (Sylvester) Equation char trana = 'N'; // no transpose of A char tranb = 'N'; // no transpose of B C_INT isgn = 1; // sign in the equation is "+" C_FLOAT64 scale; // output // DTRSYL solves the real Sylvester matrix equation: // // op(A)*X + X*op(B) = scale*C or // op(A)*X - X*op(B) = scale*C, // // where op(A) = A or A**T, and A and B are both upper quasi- // triangular. A is M-by-M and B is N-by-N; the right hand side C and // the solution X are M-by-N; and scale is an output scale factor, set // <= 1 to avoid overflow in X. dtrsyl_(&trana, &tranb, &isgn, &n, &n, At.array(), // Schur transform of the Jacobian (reduced) &n, A.array(), // Schur transform of the transposed Jacobian (reduced) &n, BMatrixReduced_transformed.array(), // output / input (the coordinate-transformed mBMatrix (reduced)) &n, &scale, &info); if (info != 0) { // TODO(juergen): add appropriate exception message(s)! // CCopasiMessage(CCopasiMessage::EXCEPTION, MCLNA + 1, -mInfo); } // 4. Calculate the original matrix C: -(unitary At)*BMatrixReduced_transformed*(unitary A)^T; transa = 'N'; transb = 'N'; alpha = -1.0; beta = 0.0; ldd = n; D.resize((size_t)n, (size_t)n); dgemm_(&transa, &transb, &n, &n, &n, &alpha, vs_At.array(), &n, BMatrixReduced_transformed.array(), // BMatrixReduced_transformed.array() holds the output of dtrsyl() now &n, &beta, D.array(), &ldd); transa = 'N'; transb = 'T'; alpha = 1.0; beta = 0.0; mCovarianceMatrixReduced.resize((size_t)n, (size_t)n); dgemm_(&transa, &transb, &n, &n, &n, &alpha, D.array(), &n, vs_A.array(), &n, &beta, mCovarianceMatrixReduced.array(), &n); //#ifdef DEBUG std::cout << "Covariance Matrix (reduced):" << std::endl << mCovarianceMatrixReduced << std::endl; //#endif // DEBUG return LNA_OK; }