/* solve a linear system using Cholesky, LU, and QR, with various orderings */
int demo2 (problem *Prob)
{
cs *A, *C ;
double *b, *x, *resid, t, tol ;
int k, m, n, ok, order, nb, ns, *r, *s, *rr, sprank ;
csd *D ;
if (!Prob) return (0) ;
A = Prob->A ; C = Prob->C ; b = Prob->b ; x = Prob->x ; resid = Prob->resid;
m = A->m ; n = A->n ;
tol = Prob->sym ? 0.001 : 1 ; /* partial pivoting tolerance */
D = cs_dmperm (C, 1) ; /* randomized dmperm analysis */
if (!D) return (0) ;
nb = D->nb ; r = D->r ; s = D->s ; rr = D->rr ;
sprank = rr [3] ;
for (ns = 0, k = 0 ; k < nb ; k++)
{
ns += ((r [k+1] == r [k]+1) && (s [k+1] == s [k]+1)) ;
}
printf ("blocks: %g singletons: %g structural rank: %g\n",
(double) nb, (double) ns, (double) sprank) ;
cs_dfree (D) ;
for (order = 0 ; order <= 3 ; order += 3) /* natural and amd(A'*A) */
{
if (!order && m > 1000) continue ;
printf ("QR ") ;
print_order (order) ;
rhs (x, b, m) ; /* compute right-hand side */
t = tic () ;
ok = cs_qrsol (order, C, x) ; /* min norm(Ax-b) with QR */
printf ("time: %8.2f ", toc (t)) ;
print_resid (ok, C, x, b, resid) ; /* print residual */
}
if (m != n || sprank < n) return (1) ; /* return if rect. or singular*/
for (order = 0 ; order <= 3 ; order++) /* try all orderings */
{
if (!order && m > 1000) continue ;
printf ("LU ") ;
print_order (order) ;
rhs (x, b, m) ; /* compute right-hand side */
t = tic () ;
ok = cs_lusol (order, C, x, tol) ; /* solve Ax=b with LU */
printf ("time: %8.2f ", toc (t)) ;
print_resid (ok, C, x, b, resid) ; /* print residual */
}
if (!Prob->sym) return (1) ;
for (order = 0 ; order <= 1 ; order++) /* natural and amd(A+A') */
{
if (!order && m > 1000) continue ;
printf ("Chol ") ;
print_order (order) ;
rhs (x, b, m) ; /* compute right-hand side */
t = tic () ;
ok = cs_cholsol (order, C, x) ; /* solve Ax=b with Cholesky */
printf ("time: %8.2f ", toc (t)) ;
print_resid (ok, C, x, b, resid) ; /* print residual */
}
return (1) ;
}
bool cs_divide(double *dividend, CSBuilder *divisor) {
const int sz = divisor->size();
int *x = new int[sz], *y = new int[sz];
double *v = new double[sz];
cs *a = divisor->buildCS(x,y,v);
int nRet = cs_qrsol(2,a,dividend);
cs_spfree(a);
delete[] x;
delete[] y;
delete[] v;
return 0 != nRet;
}
// called from package MatrixModels's R code
SEXP dgCMatrix_qrsol(SEXP x, SEXP y, SEXP ord)
{
/* FIXME: extend this to work in multivariate case, i.e. y a matrix with > 1 column ! */
SEXP ycp = PROTECT((TYPEOF(y) == REALSXP) ?
duplicate(y) : coerceVector(y, REALSXP));
CSP xc = AS_CSP(x); /* <--> x may be dgC* or dtC* */
int order = asInteger(ord);
#ifdef _not_yet_do_FIXME__
const char *nms[] = {"L", "coef", "Xty", "resid", ""};
SEXP ans = PROTECT(Rf_mkNamed(VECSXP, nms));
#endif
R_CheckStack();
if (order < 0 || order > 3)
error(_("dgCMatrix_qrsol(., order) needs order in {0,..,3}"));
/* --> cs_amd() --- order 0: natural, 1: Chol, 2: LU, 3: QR */
if (LENGTH(ycp) != xc->m)
error(_("Dimensions of system to be solved are inconsistent"));
/* FIXME? Note that qr_sol() would allow *under-determined systems;
* In general, we'd need LENGTH(ycp) = max(n,m)
* FIXME also: multivariate y (see above)
*/
if (xc->m < xc->n || xc->n <= 0)
error(_("dgCMatrix_qrsol(<%d x %d>-matrix) requires a 'tall' rectangular matrix"),
xc->m, xc->n);
/* cs_qrsol(): Tim Davis (2006) .. "8.2 Using a QR factorization", p.136f , calling
* ------- cs_sqr(order, ..), see p.76 */
/* MM: FIXME: write our *OWN* version of - the first case (m >= n) - of cs_qrsol()
* --------- which will (1) work with a *multivariate* y
* (2) compute coefficients properly, not overwriting RHS
*/
if (!cs_qrsol(order, xc, REAL(ycp)))
/* return value really is 0 or 1 - no more info there */
error(_("cs_qrsol() failed inside dgCMatrix_qrsol()"));
/* Solution is only in the first part of ycp -- cut its length back to n : */
ycp = lengthgets(ycp, (R_len_t) xc->n);
UNPROTECT(1);
return ycp;
}
/**
* @brief Updates the economy.
*
* @param dt Deltatick in NTIME.
*/
int economy_update( unsigned int dt )
{
int ret;
int i, j;
double *X;
double scale, offset;
/*double min, max;*/
/* Economy must be initialized. */
if (econ_initialized == 0)
return 0;
/* Create the vector to solve the system. */
X = malloc(sizeof(double)*systems_nstack);
if (X == NULL) {
WARN("Out of Memory!");
return -1;
}
/* Calculate the results for each price set. */
for (j=0; j<econ_nprices; j++) {
/* First we must load the vector with intensities. */
for (i=0; i<systems_nstack; i++)
X[i] = econ_calcSysI( dt, &systems_stack[i], j );
/* Solve the system. */
/** @TODO This should be improved to try to use better factorizations (LU/Cholesky)
* if possible or just outright try to use some other library that does fancy stuff
* like UMFPACK. Would be also interesting to see if it could be optimized so we
* store the factorization or update that instead of handling it individually. Another
* point of interest would be to split loops out to make the solving faster, however,
* this may be trickier to do (although it would surely let us use cholesky always if we
* enforce that condition). */
ret = cs_qrsol( 3, econ_G, X );
if (ret != 1)
WARN("Failed to solve the Economy System.");
/*
* Get the minimum and maximum to scale.
*/
/*
min = +HUGE_VALF;
max = -HUGE_VALF;
for (i=0; i<systems_nstack; i++) {
if (X[i] < min)
min = X[i];
if (X[i] > max)
max = X[i];
}
scale = 1. / (max - min);
offset = 0.5 - min * scale;
*/
/*
* I'm not sure I like the filtering of the results, but it would take
* much more work to get a sane system working without the need of post
* filtering.
*/
scale = 1.;
offset = 1.;
for (i=0; i<systems_nstack; i++)
systems_stack[i].prices[j] = X[i] * scale + offset;
}
/* Clean up. */
free(X);
return 0;
}
