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;
}
