static int
dogleg_preloop(const void * vtrust_state, void * vstate)
{
int status;
const gsl_multifit_nlinear_trust_state *trust_state =
(const gsl_multifit_nlinear_trust_state *) vtrust_state;
dogleg_state_t *state = (dogleg_state_t *) vstate;
const gsl_multifit_nlinear_parameters *params = trust_state->params;
double u;
double alpha; /* ||g||^2 / ||Jg||^2 */
/* initialize linear least squares solver */
status = (params->solver->init)(trust_state, trust_state->solver_state);
if (status)
return status;
/* prepare the linear solver to compute Gauss-Newton step */
status = (params->solver->presolve)(0.0, trust_state, trust_state->solver_state);
if (status)
return status;
/* solve: J dx_gn = -f for Gauss-Newton step */
status = (params->solver->solve)(trust_state->f,
state->dx_gn,
trust_state,
trust_state->solver_state);
if (status)
return status;
/* now calculate the steepest descent step */
/* compute workp = D^{-1} g and its norm */
gsl_vector_memcpy(state->workp, trust_state->g);
gsl_vector_div(state->workp, trust_state->diag);
state->norm_Dinvg = gsl_blas_dnrm2(state->workp);
/* compute workp = D^{-2} g */
gsl_vector_div(state->workp, trust_state->diag);
/* compute: workn = J D^{-2} g */
gsl_blas_dgemv(CblasNoTrans, 1.0, trust_state->J, state->workp, 0.0, state->workn);
state->norm_JDinv2g = gsl_blas_dnrm2(state->workn);
u = state->norm_Dinvg / state->norm_JDinv2g;
alpha = u * u;
/* dx_sd = -alpha D^{-2} g */
gsl_vector_memcpy(state->dx_sd, state->workp);
gsl_vector_scale(state->dx_sd, -alpha);
state->norm_Dgn = scaled_enorm(trust_state->diag, state->dx_gn);
state->norm_Dsd = scaled_enorm(trust_state->diag, state->dx_sd);
return GSL_SUCCESS;
}
int
gsl_multifit_linear_genform1 (const gsl_vector * L,
const gsl_vector * cs,
gsl_vector * c,
gsl_multifit_linear_workspace * work)
{
if (L->size > work->pmax)
{
GSL_ERROR("L vector does not match workspace", GSL_EBADLEN);
}
else if (L->size != cs->size)
{
GSL_ERROR("cs vector does not match L", GSL_EBADLEN);
}
else if (L->size != c->size)
{
GSL_ERROR("c vector does not match L", GSL_EBADLEN);
}
else
{
/* compute true solution vector c = L^{-1} c~ */
gsl_vector_memcpy(c, cs);
gsl_vector_div(c, L);
return GSL_SUCCESS;
}
}
int
gsl_linalg_pcholesky_svx(const gsl_matrix * LDLT,
const gsl_permutation * p,
gsl_vector * x)
{
if (LDLT->size1 != LDLT->size2)
{
GSL_ERROR ("LDLT matrix must be square", GSL_ENOTSQR);
}
else if (LDLT->size1 != p->size)
{
GSL_ERROR ("matrix size must match permutation size", GSL_EBADLEN);
}
else if (LDLT->size2 != x->size)
{
GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
}
else
{
gsl_vector_const_view D = gsl_matrix_const_diagonal(LDLT);
/* x := P b */
gsl_permute_vector(p, x);
/* solve: L w = P b */
gsl_blas_dtrsv(CblasLower, CblasNoTrans, CblasUnit, LDLT, x);
/* solve: D y = w */
gsl_vector_div(x, &D.vector);
/* solve: L^T z = y */
gsl_blas_dtrsv(CblasLower, CblasTrans, CblasUnit, LDLT, x);
/* compute: x = P^T z */
gsl_permute_vector_inverse(p, x);
return GSL_SUCCESS;
}
}
static int
multifit_wlinear_svd (const gsl_matrix * X,
const gsl_vector * w,
const gsl_vector * y,
double tol,
int balance,
size_t * rank,
gsl_vector * c,
gsl_matrix * cov,
double *chisq, gsl_multifit_linear_workspace * work)
{
if (X->size1 != y->size)
{
GSL_ERROR
("number of observations in y does not match rows of matrix X",
GSL_EBADLEN);
}
else if (X->size2 != c->size)
{
GSL_ERROR ("number of parameters c does not match columns of matrix X",
GSL_EBADLEN);
}
else if (w->size != y->size)
{
GSL_ERROR ("number of weights does not match number of observations",
GSL_EBADLEN);
}
else if (cov->size1 != cov->size2)
{
GSL_ERROR ("covariance matrix is not square", GSL_ENOTSQR);
}
else if (c->size != cov->size1)
{
GSL_ERROR
("number of parameters does not match size of covariance matrix",
GSL_EBADLEN);
}
else if (X->size1 != work->n || X->size2 != work->p)
{
GSL_ERROR
("size of workspace does not match size of observation matrix",
GSL_EBADLEN);
}
else
{
const size_t n = X->size1;
const size_t p = X->size2;
size_t i, j, p_eff;
gsl_matrix *A = work->A;
gsl_matrix *Q = work->Q;
gsl_matrix *QSI = work->QSI;
gsl_vector *S = work->S;
gsl_vector *t = work->t;
gsl_vector *xt = work->xt;
gsl_vector *D = work->D;
/* Scale X, A = sqrt(w) X */
gsl_matrix_memcpy (A, X);
for (i = 0; i < n; i++)
{
double wi = gsl_vector_get (w, i);
if (wi < 0)
wi = 0;
{
gsl_vector_view row = gsl_matrix_row (A, i);
gsl_vector_scale (&row.vector, sqrt (wi));
}
}
/* Balance the columns of the matrix A if requested */
if (balance)
{
gsl_linalg_balance_columns (A, D);
}
else
{
gsl_vector_set_all (D, 1.0);
}
/* Decompose A into U S Q^T */
gsl_linalg_SV_decomp_mod (A, QSI, Q, S, xt);
/* Solve sqrt(w) y = A c for c, by first computing t = sqrt(w) y */
for (i = 0; i < n; i++)
{
double wi = gsl_vector_get (w, i);
double yi = gsl_vector_get (y, i);
if (wi < 0)
wi = 0;
gsl_vector_set (t, i, sqrt (wi) * yi);
}
gsl_blas_dgemv (CblasTrans, 1.0, A, t, 0.0, xt);
/* Scale the matrix Q, Q' = Q S^-1 */
gsl_matrix_memcpy (QSI, Q);
{
double alpha0 = gsl_vector_get (S, 0);
p_eff = 0;
for (j = 0; j < p; j++)
{
gsl_vector_view column = gsl_matrix_column (QSI, j);
double alpha = gsl_vector_get (S, j);
if (alpha <= tol * alpha0) {
alpha = 0.0;
} else {
alpha = 1.0 / alpha;
p_eff++;
}
gsl_vector_scale (&column.vector, alpha);
}
*rank = p_eff;
}
gsl_vector_set_zero (c);
/* Solution */
gsl_blas_dgemv (CblasNoTrans, 1.0, QSI, xt, 0.0, c);
/* Unscale the balancing factors */
gsl_vector_div (c, D);
/* Compute chisq, from residual r = y - X c */
{
double r2 = 0;
for (i = 0; i < n; i++)
{
double yi = gsl_vector_get (y, i);
double wi = gsl_vector_get (w, i);
gsl_vector_const_view row = gsl_matrix_const_row (X, i);
double y_est, ri;
gsl_blas_ddot (&row.vector, c, &y_est);
ri = yi - y_est;
r2 += wi * ri * ri;
}
*chisq = r2;
/* Form covariance matrix cov = (X^T W X)^-1 = (Q S^-1) (Q S^-1)^T */
for (i = 0; i < p; i++)
{
gsl_vector_view row_i = gsl_matrix_row (QSI, i);
double d_i = gsl_vector_get (D, i);
for (j = i; j < p; j++)
{
gsl_vector_view row_j = gsl_matrix_row (QSI, j);
double d_j = gsl_vector_get (D, j);
double s;
gsl_blas_ddot (&row_i.vector, &row_j.vector, &s);
gsl_matrix_set (cov, i, j, s / (d_i * d_j));
gsl_matrix_set (cov, j, i, s / (d_i * d_j));
}
}
}
return GSL_SUCCESS;
}
}
int
gsl_multifit_linear_svd (const gsl_matrix * X,
const gsl_vector * y,
double tol,
size_t * rank,
gsl_vector * c,
gsl_matrix * cov,
double *chisq, gsl_multifit_linear_workspace * work)
{
if (X->size1 != y->size)
{
GSL_ERROR
("number of observations in y does not match rows of matrix X",
GSL_EBADLEN);
}
else if (X->size2 != c->size)
{
GSL_ERROR ("number of parameters c does not match columns of matrix X",
GSL_EBADLEN);
}
else if (cov->size1 != cov->size2)
{
GSL_ERROR ("covariance matrix is not square", GSL_ENOTSQR);
}
else if (c->size != cov->size1)
{
GSL_ERROR
("number of parameters does not match size of covariance matrix",
GSL_EBADLEN);
}
else if (X->size1 != work->n || X->size2 != work->p)
{
GSL_ERROR
("size of workspace does not match size of observation matrix",
GSL_EBADLEN);
}
else if (tol <= 0)
{
GSL_ERROR ("tolerance must be positive", GSL_EINVAL);
}
else
{
const size_t n = X->size1;
const size_t p = X->size2;
size_t i, j, p_eff;
gsl_matrix *A = work->A;
gsl_matrix *Q = work->Q;
gsl_matrix *QSI = work->QSI;
gsl_vector *S = work->S;
gsl_vector *xt = work->xt;
gsl_vector *D = work->D;
/* Copy X to workspace, A <= X */
gsl_matrix_memcpy (A, X);
/* Balance the columns of the matrix A */
gsl_linalg_balance_columns (A, D);
/* Decompose A into U S Q^T */
gsl_linalg_SV_decomp_mod (A, QSI, Q, S, xt);
/* Solve y = A c for c */
gsl_blas_dgemv (CblasTrans, 1.0, A, y, 0.0, xt);
/* Scale the matrix Q, Q' = Q S^-1 */
gsl_matrix_memcpy (QSI, Q);
{
double alpha0 = gsl_vector_get (S, 0);
p_eff = 0;
for (j = 0; j < p; j++)
{
gsl_vector_view column = gsl_matrix_column (QSI, j);
double alpha = gsl_vector_get (S, j);
if (alpha <= tol * alpha0) {
alpha = 0.0;
} else {
alpha = 1.0 / alpha;
p_eff++;
}
gsl_vector_scale (&column.vector, alpha);
}
*rank = p_eff;
}
gsl_vector_set_zero (c);
gsl_blas_dgemv (CblasNoTrans, 1.0, QSI, xt, 0.0, c);
/* Unscale the balancing factors */
gsl_vector_div (c, D);
/* Compute chisq, from residual r = y - X c */
{
double s2 = 0, r2 = 0;
for (i = 0; i < n; i++)
{
double yi = gsl_vector_get (y, i);
gsl_vector_const_view row = gsl_matrix_const_row (X, i);
double y_est, ri;
gsl_blas_ddot (&row.vector, c, &y_est);
ri = yi - y_est;
r2 += ri * ri;
}
s2 = r2 / (n - p_eff); /* p_eff == rank */
*chisq = r2;
/* Form variance-covariance matrix cov = s2 * (Q S^-1) (Q S^-1)^T */
for (i = 0; i < p; i++)
{
gsl_vector_view row_i = gsl_matrix_row (QSI, i);
double d_i = gsl_vector_get (D, i);
for (j = i; j < p; j++)
{
gsl_vector_view row_j = gsl_matrix_row (QSI, j);
double d_j = gsl_vector_get (D, j);
double s;
gsl_blas_ddot (&row_i.vector, &row_j.vector, &s);
gsl_matrix_set (cov, i, j, s * s2 / (d_i * d_j));
gsl_matrix_set (cov, j, i, s * s2 / (d_i * d_j));
}
}
}
return GSL_SUCCESS;
}
}
int lseShurComplement(gsl_matrix * A, gsl_matrix * C,
gsl_vector * b, gsl_vector * d,
gsl_vector * x, gsl_vector * lambda, double * sigma)
{
int i;
double xi;
gsl_vector *c0, *S, *tau;
gsl_matrix *CT, *U;
gsl_permutation *perm;
gsl_vector_view row, cp;
gsl_matrix_view R;
if (A->size2 != C->size2) return -1;
if (A->size2 != x->size) return -1;
if (A->size1 < A->size2) return -1;
if (b != NULL && A->size1 != b->size) return -1;
if (C->size1 != d->size) return -1;
if (C->size1 != lambda->size) return -1;
c0 = gsl_vector_alloc(x->size);
gsl_matrix_get_row(c0, C, 0);
/* Cholesky factorization of A^T A = R^T R via QRPT decomposition */
perm = gsl_permutation_alloc(x->size);
tau = gsl_vector_alloc(x->size);
gsl_linalg_QRPT_decomp(A, tau, perm, &i, x);
/* cp = R^{-T} P A^T b = Q^T b */
if (b != NULL) {
gsl_linalg_QR_QTvec(A, tau, b);
cp = gsl_vector_subvector(b, 0, x->size);
}
gsl_vector_free(tau);
/* C P -> C */
R = gsl_matrix_submatrix(A, 0, 0, A->size2, A->size2);
for (i = 0; i < C->size1; ++i) {
row = gsl_matrix_row(C, i);
gsl_permute_vector(perm, &row.vector);
}
/* Compute C inv(R) -> C */
gsl_blas_dtrsm(CblasRight, CblasUpper, CblasNoTrans, CblasNonUnit, 1.0,
&R.matrix, C);
/* The Schur complement D = C C^T,
Compute SVD of D = U S^2 U^T by SVD of C^T = V S U^T */
CT = gsl_matrix_alloc(C->size2, C->size1);
gsl_matrix_transpose_memcpy(CT, C);
U = gsl_matrix_alloc(CT->size2, CT->size2);
S = gsl_vector_alloc(CT->size2);
gsl_linalg_SV_decomp(CT, U, S, lambda);
/* Right hand side of the Shur complement system
d - C (A^T A)^-1 A^T b = d - C cp -> d
(with C P R^-1 -> C and R^-T P^T A^T b -> cp) */
if (b != NULL) {
gsl_blas_dgemv(CblasNoTrans, -1.0, C, &cp.vector, 1.0, d);
}
/* Calculate S U^T lambda, where -lambda is the Lagrange multiplier */
gsl_blas_dgemv(CblasTrans, 1.0, U, d, 0.0, lambda);
gsl_vector_div(lambda, S);
/* Calculate sigma = || A x ||_2 = || x ||_2 (before inv(R) x -> x) */
*sigma = gsl_blas_dnrm2(lambda);
/* Compute inv(R)^T C^T lambda = C^T lambda (with C inv(R) ->C) */
gsl_blas_dgemv(CblasNoTrans, 1.0, CT, lambda, 0.0, x);
/* x = inv(A^T A) C^T lambda = inv(R) [inv(R)^T C^T lambda] */
if (R.matrix.data[R.matrix.size1 * R.matrix.size2 - 1] != 0.0) {
gsl_blas_dtrsv(CblasUpper, CblasNoTrans, CblasNonUnit, &R.matrix, x);
}
else { /* Special case when A is singular */
gsl_vector_set_basis(x, x->size - 1);
*sigma = 0.0;
}
/* Permute back, 1-step iterative refinement on first constraint */
gsl_permute_vector_inverse(perm, x);
gsl_blas_ddot(x, c0, &xi);
gsl_vector_scale(x, d->data[0] / xi);
/* get the real lambda from S U^T lambda previously stored in lambda */
gsl_vector_div(lambda, S);
gsl_vector_memcpy(S, lambda);
gsl_blas_dgemv(CblasNoTrans, 1.0, U, S, 0.0, lambda);
gsl_vector_free(c0);
gsl_vector_free(S);
gsl_matrix_free(U);
gsl_matrix_free(CT);
gsl_permutation_free(perm);
return 0;
}
/** **************************************************************************************************************/
double g_outer_R (int Rn, double *betaincTauDBL, void *params) /*typedef double optimfn(int n, double *par, void *ex);*/
{
int i,j;
double term1=0.0,singlegrp=0.0;
const datamatrix *designdata = ((struct fnparams *) params)->designdata;/** all design data inc Y and priors **/
const gsl_vector *priormean = designdata->priormean;
const gsl_vector *priorsd = designdata->priorsd;
const gsl_vector *priorgamshape = designdata->priorgamshape;
const gsl_vector *priorgamscale = designdata->priorgamscale;
gsl_vector *beta = ((struct fnparams *) params)->beta;/** does not include precision */
gsl_vector *vectmp1= ((struct fnparams *) params)->vectmp1;/** numparams long*/
gsl_vector *vectmp2 =((struct fnparams *) params)->vectmp2;/** numparams long*/
gsl_vector *betaincTau=((struct fnparams *) params)->betaincTau;/** to copy betaincTauDBL into **/
double epsabs_inner=((struct fnparams *) params)->epsabs_inner;/** absolute error in internal laplace est */
int maxiters_inner=((struct fnparams *) params)->maxiters_inner;/** number of steps for inner root finder */
int verbose=((struct fnparams *) params)->verbose;/** */
int n_betas= (designdata->datamatrix_noRV)->size2;/** number of mean terms excl rv and precision **/
int n=(designdata->datamatrix_noRV)->size1;/** total number of obs **/
double term2=0.0,term3=0.0,term4=0.0,gval=0.0;
/*Rprintf("%d %d\n",n_betas,betaincTau->size);*/
double tau;
for(i=0;i<betaincTau->size;i++){gsl_vector_set(betaincTau,i,betaincTauDBL[i]);} /** copy R double array into gsl vect **/
/*Rprintf("got = %f %f %f\n",gsl_vector_get(betaincTau,0),gsl_vector_get(betaincTau,1),gsl_vector_get(betaincTau,2));*/
tau=gsl_vector_get(betaincTau,n_betas);/** extract the tau-precision from *beta - last entry */
/*Rprintf("g_outer_ tau=%f\n",tau);*/
if(tau<0.0){Rprintf("tau negative in g_outer!\n");error("");}
/** beta are the parameters values at which the function is to be evaluated **/
/** gvalue is the return value - a single double */
/** STOP - NEED TO copy betaincTau into shorter beta since last entry is tau = precision */
for(i=0;i<n_betas;i++){gsl_vector_set(beta,i,gsl_vector_get(betaincTau,i));/*Rprintf("passed beta=%f\n",gsl_vector_get(beta,i));*/
}
/** part 1 - the integrals over each group of observations - use laplace for this and that is taken care of in g_inner */
/** first we want to evaluate each of the integrals for each data group **/
for(j=0;j<designdata->numUnqGrps;j++){/** for each data group **/
/*j=0;*/
/* Rprintf("processing group %d\n",j+1);
Rprintf("tau in loop=%f\n",gsl_vector_get(betaincTau,n_betas));*/
singlegrp=g_inner(betaincTau,designdata,j, epsabs_inner,maxiters_inner,verbose);
if(gsl_isnan(singlegrp)){error("nan in g_inner\n");}
term1+= singlegrp;
}
/** NOTE: uncomment next line as useful for debugging as this should be the same as logLik value from lme4 */
/* Rprintf("total loglike=%e\n",term1);*/
/*Rprintf("term1 in g_outer=%f\n",term1);*/
/** part 2 the priors for the means **/
term2=0; for(i=0;i<n_betas;i++){term2+=-log(sqrt(2.0*M_PI)*gsl_vector_get(priorsd,i));}
/** Calc this in parts: R code "term3<- sum( (-1/(2*sd.loc*sd.loc))*(mybeta-mean.loc)*(mybeta-mean.loc) );" **/
gsl_vector_memcpy(vectmp1,beta);/** copy beta to temp vec */
gsl_vector_memcpy(vectmp2,priormean);
gsl_vector_scale(vectmp2,-1.0);
gsl_vector_add(vectmp1,vectmp2);/** vectmp1= beta-mean**/
gsl_vector_memcpy(vectmp2,vectmp1);/** copy vectmp1 to vectmp2 **/
gsl_vector_mul(vectmp2,vectmp1);/** square all elements in vectmp1 and store in vectmp2 */
gsl_vector_memcpy(vectmp1,priorsd);
gsl_vector_mul(vectmp1,priorsd);/** square all elements in priorsd and store in vectmp1 */
gsl_vector_div(vectmp2,vectmp1);/** vectmp2/vectmp1 and store in vectmp2 **/
gsl_vector_scale(vectmp2,-0.5); /** scale by -1/2 */
gsl_vector_set_all(vectmp1,1.0); /** ones vector */
gsl_blas_ddot (vectmp2, vectmp1, &term3);/** DOT product simply to calcu sum value */
/** part 3 the prior for the precision tau **/
term4= -gsl_vector_get(priorgamshape,0)*log(gsl_vector_get(priorgamscale,0))
-gsl_sf_lngamma(gsl_vector_get(priorgamshape,0))
+(gsl_vector_get(priorgamshape,0)-1)*log(tau)
-(tau/gsl_vector_get(priorgamscale,0));
gval=(-1.0/n)*(term1+term2+term3+term4);
/** NO PRIOR */
/* Rprintf("WARNING - NO PRIOR\n");*/
#ifdef NOPRIOR
gval=(-1.0/n)*(term1);
#endif
if(gsl_isnan(gval)){error("g_outer_R\n");}
/*Rprintf("g_outer_final=%f term1=%f term2=%f term3=%f term4=%f total=%f %d\n",gval,term1,term2,term3,term4,term1+term2+term3+term4,n); */
return(gval);/** negative since its a minimiser */
}
void KFKSDS_steady (int *dim, double *sy, double *sZ, double *sT, double *sH,
double *sR, double *sV, double *sQ, double *sa0, double *sP0,
double *tol, int *maxiter, double *ksconvfactor,
double *mll, double *epshat, double *vareps,
double *etahat, double *vareta,
double *sumepsmisc, double *sumetamisc)
{
int i, ip1, n = dim[0], m = dim[2], ir = dim[3], convref, nmconvref, nm1 = n-1;
int irsod = ir * sizeof(double);
//double v[n], f[n], invf[n], vof[n];
std::vector<double> v(n), f(n), invf(n), vof(n);
sumepsmisc[0] = 0.0;
gsl_vector * sum_eta_misc = gsl_vector_calloc(ir);
gsl_vector * etahat_sq = gsl_vector_alloc(ir);
gsl_vector_view Z = gsl_vector_view_array(sZ, m);
gsl_vector * Z_cp = gsl_vector_alloc(m);
gsl_matrix * K = gsl_matrix_alloc(n, m);
gsl_vector_view K_irow;
gsl_matrix_view Q = gsl_matrix_view_array(sQ, m, m);
gsl_matrix_view V = gsl_matrix_view_array(sV, ir, ir);
gsl_matrix_view R = gsl_matrix_view_array(sR, m, ir);
gsl_matrix * r = gsl_matrix_alloc(n + 1, m);
gsl_vector_view r_row_t;
gsl_vector_view r_row_tp1 = gsl_matrix_row(r, n);
gsl_vector_set_zero(&r_row_tp1.vector);
std::vector<gsl_matrix*> L(n);
std::vector<gsl_matrix*> N(n+1);
N.at(n) = gsl_matrix_calloc(m, m);
gsl_vector_view Ndiag;
gsl_vector_view Qdiag = gsl_matrix_diagonal(&Q.matrix);
gsl_vector * Qdiag_msq = gsl_vector_alloc(m);
gsl_vector_memcpy(Qdiag_msq, &Qdiag.vector);
gsl_vector_mul(Qdiag_msq, &Qdiag.vector);
gsl_vector_scale(Qdiag_msq, -1.0);
gsl_vector * sum_vareta = gsl_vector_calloc(m);
KF_steady(dim, sy, sZ, sT, sH,
sR, sV, sQ, sa0, sP0,
mll, &v, &f, &invf, &vof, K, &L, tol, maxiter);
convref = dim[5];
if (convref == -1) {
convref = n;
} else
convref = ceil(convref * ksconvfactor[0]);
nmconvref = n - convref;
gsl_vector_view vaux;
gsl_matrix * Mmm = gsl_matrix_alloc(m, m);
gsl_matrix * ZtZ = gsl_matrix_alloc(m, m);
gsl_matrix_view maux1, maux2;
maux1 = gsl_matrix_view_array(gsl_vector_ptr(&Z.vector, 0), m, 1);
gsl_vector_memcpy(Z_cp, &Z.vector);
maux2 = gsl_matrix_view_array(gsl_vector_ptr(Z_cp, 0), 1, m);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, &maux1.matrix,
&maux2.matrix, 0.0, ZtZ);
gsl_vector * var_eps = gsl_vector_alloc(n);
double msHsq = -1.0 * pow(*sH, 2);
vaux = gsl_vector_view_array(&f[0], n);
gsl_vector_set_all(var_eps, msHsq);
gsl_vector_div(var_eps, &vaux.vector);
gsl_vector_add_constant(var_eps, *sH);
gsl_matrix * eta_hat = gsl_matrix_alloc(n, ir);
gsl_matrix * Mrm = gsl_matrix_alloc(ir, m);
gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, &V.matrix, &R.matrix, 0.0, Mrm);
for (i = n-1; i > -1; i--)
{
ip1 = i + 1;
if (i != n-1) //the case i=n-1 was initialized above
r_row_tp1 = gsl_matrix_row(r, ip1);
r_row_t = gsl_matrix_row(r, i);
gsl_blas_dgemv(CblasTrans, 1.0, L.at(i), &r_row_tp1.vector,
0.0, &r_row_t.vector);
gsl_vector_memcpy(Z_cp, &Z.vector);
gsl_vector_scale(Z_cp, vof[i]);
gsl_vector_add(&r_row_t.vector, Z_cp);
N.at(i) = gsl_matrix_alloc(m, m);
if (i < convref || i > nmconvref)
{
gsl_matrix_memcpy(N.at(i), ZtZ);
gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, L.at(i), N.at(ip1), 0.0, Mmm);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Mmm, L.at(i), invf[i], N.at(i));
} else {
gsl_matrix_memcpy(N.at(i), N.at(ip1));
}
if (dim[6] == 0 || dim[6] == 1)
{
if (i < convref || i == nm1) {
K_irow = gsl_matrix_row(K, i);
}
gsl_blas_ddot(&K_irow.vector, &r_row_tp1.vector, &epshat[i]);
epshat[i] -= vof[i];
epshat[i] *= -*sH;
if (i < convref || i > nmconvref)
{
maux1 = gsl_matrix_view_array(gsl_vector_ptr(&K_irow.vector, 0), 1, m);
maux2 = gsl_matrix_view_array(gsl_vector_ptr(Z_cp, 0), 1, m);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, &maux1.matrix, N.at(ip1),
0.0, &maux2.matrix);
vaux = gsl_vector_view_array(gsl_vector_ptr(var_eps, i), 1);
gsl_blas_dgemv(CblasNoTrans, msHsq, &maux2.matrix, &K_irow.vector,
1.0, &vaux.vector);
vareps[i] = gsl_vector_get(&vaux.vector, 0);
} else {
vareps[i] = vareps[ip1];
}
sumepsmisc[0] += epshat[i] * epshat[i] + vareps[i];
}
if (dim[6] == 0 || dim[6] == 2)
{
vaux = gsl_matrix_row(eta_hat, i);
gsl_blas_dgemv(CblasNoTrans, 1.0, Mrm, &r_row_tp1.vector,
0.0, &vaux.vector);
memcpy(&etahat[i*ir], (&vaux.vector)->data, irsod);
if (i != n-1)
{
gsl_vector_memcpy(etahat_sq, &vaux.vector);
gsl_vector_mul(etahat_sq, etahat_sq);
gsl_vector_add(sum_eta_misc, etahat_sq);
}
if (i != n-1)
{
if (i < convref || i > nmconvref)
{
Ndiag = gsl_matrix_diagonal(N.at(ip1));
gsl_vector_memcpy(Z_cp, &Ndiag.vector);
gsl_vector_mul(Z_cp, Qdiag_msq);
gsl_vector_add(Z_cp, &Qdiag.vector);
gsl_vector_set_zero(sum_vareta);
gsl_vector_add(sum_vareta, Z_cp);
}
gsl_blas_dgemv(CblasTrans, 1.0, &R.matrix, sum_vareta, 1.0, sum_eta_misc);
}
}
gsl_matrix_free(L.at(i));
gsl_matrix_free(N.at(ip1));
}
gsl_matrix_free(N.at(0));
if (dim[6] == 0 || dim[6] == 2)
{
memcpy(&sumetamisc[0], sum_eta_misc->data, irsod);
}
gsl_vector_free(Z_cp);
gsl_vector_free(var_eps);
gsl_vector_free(Qdiag_msq);
gsl_vector_free(sum_vareta);
gsl_vector_free(sum_eta_misc);
gsl_vector_free(etahat_sq);
gsl_matrix_free(eta_hat);
gsl_matrix_free(Mrm);
gsl_matrix_free(r);
gsl_matrix_free(K);
gsl_matrix_free(ZtZ);
gsl_matrix_free(Mmm);
}
int Holling2(double t, const double y[], double ydot[], void *params){
double alpha = 0.3; // respiration
double lambda = 0.65; // ecologic efficiency
double hand = 0.35; // handling time
double beta = 0.5; // intraspecific competition
double aij = 6.0; // attack rate
//double migratingPop = 0.01;
int i, j,l = 0; // Hilfsvariablen
double rowsum = 0;
//double colsum = 0;
// int test = 0;
//
// if(test<5)
// {
// printf("Richtiges Holling");
// }
// test++;
//-- Struktur zerlegen-------------------------------------------------------------------------------------------------------------------------------
struct foodweb *nicheweb = (struct foodweb *)params; // pointer cast from (void*) to (struct foodweb*)
//printf("t in Holling 2=%f\n", t);
gsl_vector *network = (nicheweb->network); // Inhalt: A+linksA+Y+linksY+Massen+Trophische_Level = (Rnum+S)²+1+Y²+1+(Rnum+S)+S
int S = nicheweb->S;
int Y = nicheweb->Y;
int Rnum = nicheweb->Rnum;
//double d = nicheweb->d;
int Z = nicheweb->Z;
//double dij = pow(10, d);
double Bmigr = gsl_vector_get(network, (Rnum+S)*(S+Rnum)+1+Y*Y+1+(Rnum+S)+S);
//printf("Bmigr ist %f\n", Bmigr);
double nu,mu, tau;
int SpeciesNumber;
tau = gsl_vector_get(nicheweb->migrPara,0);
mu = gsl_vector_get(nicheweb->migrPara,1);
// if((int)nu!=0)
// {
// printf("nu ist nicht null sondern %f\n",nu);
// }
nu = gsl_vector_get(nicheweb->migrPara,2);
SpeciesNumber = gsl_vector_get(nicheweb->migrPara,3);
double tlast = gsl_vector_get(nicheweb->migrPara,4);
// if(SpeciesNumber!= 0)
// {
// //printf("SpeciesNumber %i\n", SpeciesNumber);
// }
//printf("t oben %f\n",t);
//int len = (Rnum+S)*(Rnum+S)+2+Y*Y+(Rnum+S)+S;
gsl_vector_view A_view = gsl_vector_subvector(network, 0, (Rnum+S)*(Rnum+S)); // Fressmatrix A als Vektor
gsl_matrix_view EA_mat = gsl_matrix_view_vector(&A_view.vector, (Rnum+S), (Rnum+S)); // A als Matrix_view
gsl_matrix *EAmat = &EA_mat.matrix; // A als Matrix
gsl_vector_view D_view = gsl_vector_subvector(network, (Rnum+S)*(Rnum+S)+1, Y*Y); // Migrationsmatrix D als Vektor
gsl_matrix_view ED_mat = gsl_matrix_view_vector(&D_view.vector, Y, Y); // D als Matrixview
gsl_matrix *EDmat = &ED_mat.matrix; // D als Matrix
gsl_vector_view M_vec = gsl_vector_subvector(network, ((Rnum+S)*(Rnum+S))+1+(Y*Y)+1, (Rnum+S)); // Massenvektor
gsl_vector *Mvec = &M_vec.vector;
//-- verändere zu dem gewünschten Zeitpunkt Migrationsmatrix
if( (t > tau) && (tlast < tau))
{
//printf("mu ist %f\n", gsl_vector_get(nicheweb->migrPara,1));
//printf("nu ist %f\n", nu);
gsl_vector_set(nicheweb->migrPara,4,t);
//printf("Setze Link für gewünschte Migration\n");
// printf("t oben %f\n",t);
// printf("tlast oben %f\n",tlast);
gsl_matrix_set(EDmat, nu, mu, 1.);
//int m;
// for(l = 0; l< Y;l++)
// {
// for(m=0;m<Y;m++)
// {
// printf("%f\t",gsl_matrix_get(EDmat,l,m));
// }
// printf("\n");
// }
}
else
{
gsl_matrix_set_zero(EDmat);
}
// printf("\ncheckpoint Holling2 I\n");
// printf("\nS = %i\n", S);
// printf("\nS + Rnum = %i\n", S+Rnum);
//
// printf("\nSize A_view = %i\n", (int)A_view.vector.size);
// printf("\nSize D_view = %i\n", (int)D_view.vector.size);
// printf("\nSize M_vec = %i\n", (int)M_vec.vector.size);
// for(i=0; i<(Rnum+S)*Y; i++){
// printf("\ny = %f\n", y[i]);
// }
// for(i=0; i<(Rnum+S)*Y; i++){
// printf("\nydot = %f\n", ydot[i]);
// }
//--zusätzliche Variablen anlegen-------------------------------------------------------------------------------------------------------------
double ytemp[(Rnum+S)*Y];
for(i=0; i<(Rnum+S)*Y; i++) ytemp[i] = y[i]; // temp array mit Kopie der Startwerte
for(i=0; i<(Rnum+S)*Y; i++) ydot[i] = 0; // Ergebnis, in das evolve_apply schreibt
gsl_vector_view yfddot_vec = gsl_vector_view_array(ydot, (Rnum+S)*Y); //Notiz: vector_view_array etc. arbeiten auf den original Daten der ihnen zugeordneten Arrays/Vektoren!
gsl_vector *yfddotvec = &yfddot_vec.vector; // zum einfacheren Rechnen ydot über vector_view_array ansprechen
gsl_vector_view yfd_vec = gsl_vector_view_array(ytemp, (Rnum+S)*Y);
gsl_vector *yfdvec = &yfd_vec.vector; // Startwerte der Populationen
//-- neue Objekte zum Rechnen anlegen--------------------------------------------------------------------------------------------------------
gsl_matrix *AFgsl = gsl_matrix_calloc(Rnum+S, Rnum+S); // matrix of foraging efforts
// gsl_matrix *ADgsl = gsl_matrix_calloc(Y,Y); // matrix of migration efforts
gsl_matrix *Emat = gsl_matrix_calloc(Rnum+S, Rnum+S); // gsl objects for calculations of populations
gsl_vector *tvec = gsl_vector_calloc(Rnum+S);
gsl_vector *rvec = gsl_vector_calloc(Rnum+S);
gsl_vector *svec = gsl_vector_calloc(Rnum+S);
// gsl_matrix *Dmat = gsl_matrix_calloc(Y,Y); // gsl objects for calculations of migration
// gsl_vector *d1vec = gsl_vector_calloc(Y);
gsl_vector *d2vec = gsl_vector_calloc(Y);
gsl_vector *d3vec = gsl_vector_calloc(Y);
// printf("\ncheckpoint Holling2 III\n");
//-- Einzelne Patches lösen------------------------------------------------------------------------------------------------------------
for(l=0; l<Y; l++) // start of patch solving
{
gsl_matrix_set_zero(AFgsl); // Objekte zum Rechnen vor jedem Patch nullen
gsl_matrix_set_zero(Emat);
gsl_vector_set_zero(tvec);
gsl_vector_set_zero(rvec);
gsl_vector_set_zero(svec);
gsl_vector_view ydot_vec = gsl_vector_subvector(yfddotvec, (Rnum+S)*l, (Rnum+S)); // enthält ydot von Patch l
gsl_vector *ydotvec = &ydot_vec.vector;
gsl_vector_view y_vec = gsl_vector_subvector(yfdvec, (Rnum+S)*l, (Rnum+S)); // enthält Startwerte der Population in l
gsl_vector *yvec = &y_vec.vector;
gsl_matrix_memcpy(AFgsl, EAmat);
for(i=0; i<Rnum+S; i++)
{
gsl_vector_view rowA = gsl_matrix_row(AFgsl,i);
rowsum = gsl_blas_dasum(&rowA.vector);
if(rowsum !=0 )
{
for(j=0; j<Rnum+S; j++)
gsl_matrix_set(AFgsl, i, j, (gsl_matrix_get(AFgsl,i,j)/rowsum)); // normiere Beute Afgsl = A(Beutelinks auf 1 normiert) = f(i,j)
}
}
gsl_matrix_memcpy(Emat, EAmat); // Emat = A
gsl_matrix_scale(Emat, aij); // Emat(i,j) = a(i,j)
gsl_matrix_mul_elements(Emat, AFgsl); // Emat(i,j) = a(i,j)*f(i,j)
gsl_vector_memcpy(svec, yvec); // s(i) = y(i)
gsl_vector_scale(svec, hand); // s(i) = y(i)*h
gsl_blas_dgemv(CblasNoTrans, 1, Emat, svec, 0, rvec); // r(i) = Sum_k h*a(i,k)*f(i,k)*y(k)
gsl_vector_add_constant(rvec, 1); // r(i) = 1+Sum_k h*a(i,k)*f(i,k)*y(k)
gsl_vector_memcpy(tvec, Mvec); // t(i) = masse(i)^(-0.25)
gsl_vector_div(tvec, rvec); // t(i) = masse(i)^(-0.25)/(1+Sum_k h*a(i,k)*f(i,k)*y(k))
gsl_vector_mul(tvec, yvec); // t(i) = masse(i)^(-0.25)*y(i)/(1+Sum_k h*a(i,k)*f(i,k)*y(k))
gsl_blas_dgemv(CblasTrans, 1, Emat, tvec, 0, rvec); // r(i) = Sum_j a(j,i)*f(j,i)*t(j)
gsl_vector_mul(rvec, yvec); // r(i) = Sum_j a(j,i)*f(j,i)*t(j)*y(i) [rvec: Praedation]
gsl_blas_dgemv(CblasNoTrans, lambda, Emat, yvec, 0, ydotvec); // ydot(i) = Sum_j lambda*a(i,j)*f(i,j)*y(j)
gsl_vector_mul(ydotvec, tvec); // ydot(i) = Sum_j lambda*a(i,j)*f(i,j)*y(j)*t(i)
gsl_vector_memcpy(svec, Mvec);
gsl_vector_scale(svec, alpha); // s(i) = alpha*masse^(-0.25) [svec=Respiration bzw. Mortalitaet]
gsl_vector_memcpy(tvec, Mvec);
gsl_vector_scale(tvec, beta); // t(i) = beta*masse^(-0.25)
gsl_vector_mul(tvec, yvec); // t(i) = beta*y(i)
gsl_vector_add(svec, tvec); // s(i) = alpha*masse^(-0.25)+beta*y(i)
gsl_vector_mul(svec, yvec); // s(i) = alpha*masse^(-0.25)*y(i)+beta*y(i)*y(i)
gsl_vector_add(svec, rvec); // [svec: Respiration, competition und Praedation]
gsl_vector_sub(ydotvec, svec); // ydot(i) = Fressen-Respiration-Competition-Praedation
for(i=0; i<Rnum; i++)
gsl_vector_set(ydotvec, i, 0.0); // konstante Ressourcen
}// Ende Einzelpatch, Ergebnis steht in ydotvec
// printf("\ncheckpoint Holling2 IV\n");
//-- Migration lösen---------------------------------------------------------------------------------------------------------
gsl_vector *ydottest = gsl_vector_calloc(Y);
double ydotmigr = gsl_vector_get(nicheweb->migrPara, 5);
// int count=0,m;
// for(l = 0; l< Y;l++)
// {
// for(m=0;m<Y;m++)
// {
// count += gsl_matrix_get(EDmat,l,m);
// }
// }
// if(count!=0)
// {
// //printf("count %i\n",count);
// //printf("t unten %f\n",t);
// //printf("tau %f\n",tau);
// for(l = 0; l< Y;l++)
// {
// for(m=0;m<Y;m++)
// {
// printf("%f\t",gsl_matrix_get(EDmat,l,m));
// }
// printf("\n");
// }
// }
double max = gsl_matrix_max(EDmat);
for(l = Rnum; l< Rnum+S; l++) // start of migration solving
{
if(l == SpeciesNumber+Rnum && max !=0 )
{
//printf("max ist %f\n",max);
//printf("l ist %i\n",l);
// gsl_matrix_set_zero(ADgsl); // reset gsl objects for every patch
// gsl_matrix_set_zero(Dmat);
// gsl_vector_set_zero(d1vec);
gsl_vector_set_zero(d2vec);
gsl_vector_set_zero(d3vec);
gsl_vector_set_zero(ydottest);
// Untervektor von yfddot (enthält ydot[]) mit offset l (Rnum...Rnum+S) und Abstand zwischen den Elementen (stride) von Rnum+S.
// Dies ergibt gerade die Größe einer Spezies in jedem Patch in einem Vektor
gsl_vector_view dydot_vec = gsl_vector_subvector_with_stride(yfddotvec, l, (Rnum+S), Y); // ydot[]
gsl_vector *dydotvec = &dydot_vec.vector;
/*
gsl_vector_view dy_vec = gsl_vector_subvector_with_stride(yfdvec, l, (Rnum+S), Y); // Startgrößen der Spezies pro Patch
gsl_vector *dyvec = &dy_vec.vector;
*/
// gsl_matrix_memcpy(ADgsl, EDmat); // ADgsl = D
//
// if(nicheweb->M == 1) // umschalten w: patchwise (Abwanderung aus jedem Patch gleich), sonst linkwise (Abwanderung pro link gleich)
// {
// for(i=0; i<Y; i++)
// {
// gsl_vector_view colD = gsl_matrix_column(ADgsl, i); // Spalte i aus Migrationsmatrix
// colsum = gsl_blas_dasum(&colD.vector);
// if(colsum!=0)
// {
// for(j=0;j<Y;j++)
// gsl_matrix_set(ADgsl,j,i,(gsl_matrix_get(ADgsl,j,i)/colsum)); // ADgsl: D mit normierten Links
// }
// }
// }
//
// gsl_matrix_memcpy(Dmat, EDmat); // Dmat = D
// gsl_matrix_scale(Dmat, dij); // Dmat(i,j) = d(i,j) (Migrationsstärke)
// gsl_matrix_mul_elements(Dmat, ADgsl); // Dmat(i,j) = d(i,j)*xi(i,j) (skalierte und normierte Migrationsmatrix)
//
// gsl_vector_set_all(d1vec, 1/gsl_vector_get(Mvec, l)); // d1(i)= m(l)^0.25
// gsl_vector_mul(d1vec, dyvec); // d1(i)= m(l)^0.25*y(i)
// gsl_blas_dgemv(CblasNoTrans, 1, Dmat, d1vec, 0, d2vec); // d2(i)= Sum_j d(i,j)*xi(i,j)*m(l)^0.25*y(j)
//
// gsl_vector_set_all(d1vec, 1); // d1(i)= 1
// gsl_blas_dgemv(CblasTrans, 1, Dmat, d1vec, 0, d3vec); // d3(i)= Sum_j d(i,j)*xi(i,j)
// gsl_vector_scale(d3vec, 1/gsl_vector_get(Mvec,l)); // d3(i)= Sum_j d(i,j)*xi(i,j)*m(l)^0.25
// gsl_vector_mul(d3vec, dyvec); // d3(i)= Sum_j d(i,j)*xi(i,j)*m(l)^0.25*y(i)
//
gsl_vector_set(d2vec,nu,Bmigr);
gsl_vector_set(d3vec,mu,Bmigr);
gsl_vector_add(ydottest,d2vec);
gsl_vector_sub(ydottest,d3vec);
//printf("d2vec ist %f\n",gsl_vector_get(d2vec,0));
//printf("d3vec ist %f\n",gsl_vector_get(d3vec,0));
//if(gsl_vector_get(ydottest,mu)!=0)
//{
ydotmigr += gsl_vector_get(ydottest,nu);
// printf("ydotmigr ist %f\n",ydotmigr);
gsl_vector_set(nicheweb->migrPara,5,ydotmigr);
// if(ydotmigr !=0)
// {
// printf("ydottest aufaddiert ist %f\n",ydotmigr);
// printf("ydottest aufaddiert ist %f\n",gsl_vector_get(nicheweb->migrPara,5));
// }
gsl_vector_add(dydotvec, d2vec); //
gsl_vector_sub(dydotvec, d3vec); // Ergebnis in dydotvec (also ydot[]) = Sum_j d(i,j)*xi(i,j)*m(l)^0.25*y(j) - Sum_j d(i,j)*xi(i,j)*m(l)^0.25*y(i)
}
}// Patch i gewinnt das was aus allen j Patches zuwandert und verliert was von i auswandert
//printf("ydot ist %f\n",gsl_vector_get(ydottest,0));
//printf("\ncheckpoint Holling2 V\n");
/*
for(i=0; i<(Rnum+S)*Y; i++){
printf("\ny = %f\tydot=%f\n", y[i], ydot[i]);
}
*/
//--check for fixed point attractor-----------------------------------------------------------------------------------
if(t>7800){
gsl_vector_set(nicheweb->fixpunkte, 0, 0);
gsl_vector_set(nicheweb->fixpunkte, 1, 0);
gsl_vector_set(nicheweb->fixpunkte, 2, 0);
int fix0 = (int)gsl_vector_get(nicheweb->fixpunkte, 0);
int fix1 = (int)gsl_vector_get(nicheweb->fixpunkte, 1);
int fix2 = (int)gsl_vector_get(nicheweb->fixpunkte, 2);
//printf("t unten = %f\n", t);
for(i=0; i<(Rnum+S)*Y; i++)
{
if(y[i] <= 0)
{
fix0++;
fix1++;
fix2++;
}
else
{
if((ydot[i]/y[i]<0.0001) || (ydot[i]<0.0001)) fix0++;
if(ydot[i]/y[i]<0.0001) fix1++;
if(ydot[i]<0.0001) fix2++;
}
}
if(fix0==(Rnum+S)*Y) gsl_vector_set(nicheweb->fixpunkte, 3, 1);
if(fix1==(Rnum+S)*Y) gsl_vector_set(nicheweb->fixpunkte, 4, 1);
if(fix2==(Rnum+S)*Y) gsl_vector_set(nicheweb->fixpunkte, 5, 1);
}
//--Speicher leeren-----------------------------------------------------------------------------------------------------
gsl_matrix_free(Emat);
// gsl_matrix_free(Dmat);
gsl_matrix_free(AFgsl);
// gsl_matrix_free(ADgsl);
gsl_vector_free(tvec);
gsl_vector_free(rvec);
gsl_vector_free(svec);
// gsl_vector_free(d1vec);
gsl_vector_free(d2vec);
gsl_vector_free(d3vec);
gsl_vector_free(ydottest);
// printf("\nCheckpoint Holling2 VI\n");
return GSL_SUCCESS;
}
/** *************************************************************************************
*****************************************************************************************
*****************************************************************************************/
double g_pois_outer_marg_R (int Rn, double *betashortDBL, void *params) /** double g_outer_marg_R(int Rn, double *betaincTauDBL, void *params);*/
{
/** betashort is full beta vector (inc precision) bu then minus one term **/
int i,j;
double term1=0.0,singlegrp=0.0;
const datamatrix *designdata = ((struct fnparams *) params)->designdata;/** all design data inc Y and priors **/
const gsl_vector *priormean = designdata->priormean;
const gsl_vector *priorsd = designdata->priorsd;
const gsl_vector *priorgamshape = designdata->priorgamshape;
const gsl_vector *priorgamscale = designdata->priorgamscale;
gsl_vector *beta = ((struct fnparams *) params)->beta;/** does not include precision */
gsl_vector *vectmp1= ((struct fnparams *) params)->vectmp1;/** numparams long*/
gsl_vector *vectmp2 =((struct fnparams *) params)->vectmp2;/** numparams long*/
double epsabs_inner=((struct fnparams *) params)->epsabs_inner;/** absolute error in internal laplace est */
int maxiters_inner=((struct fnparams *) params)->maxiters_inner;/** number of steps for inner root finder */
int verbose=((struct fnparams *) params)->verbose;/** */
int n_betas= (designdata->datamatrix_noRV)->size2;/** number of mean terms excl rv and precision **/
int n=(designdata->datamatrix_noRV)->size1;/** total number of obs **/
/** this is extra stuff to deal with the fixed beta **/
gsl_vector *betaincTau = ((struct fnparams *) params)->betafull;/** will hold "full beta vector" inc precision **/
double betafixed = ((struct fnparams *) params)->betafixed;/** the fixed beta value passed through**/
int betaindex = ((struct fnparams *) params)->betaindex;
double term2=0.0,term3=0.0,term4=0.0,gval=0.0;
double tau;
if(betaindex==0){gsl_vector_set(betaincTau,0,betafixed);
for(i=1;i<betaincTau->size;i++){gsl_vector_set(betaincTau,i,betashortDBL[i-1]);}}
if(betaindex==(betaincTau->size-1)){gsl_vector_set(betaincTau,betaincTau->size-1,betafixed);
for(i=0;i<betaincTau->size-1;i++){gsl_vector_set(betaincTau,i,betashortDBL[i]);}}
if(betaindex>0 && betaindex<(betaincTau->size-1)){
for(i=0;i<betaindex;i++){gsl_vector_set(betaincTau,i,betashortDBL[i]);}
gsl_vector_set(betaincTau,betaindex,betafixed);
for(i=betaindex+1;i<betaincTau->size;i++){gsl_vector_set(betaincTau,i,betashortDBL[i-1]);}
}
/*Rprintf("passed:\n");
for(i=0;i<betaincTau->size;i++){Rprintf("%10.10f ",gsl_vector_get(betaincTau,i));}Rprintf("\n");
*/
tau=gsl_vector_get(betaincTau,n_betas);/** extract the tau-precision from *beta - last entry */
/*if(tau<0){Rprintf("negative tau in g_outer\n");return(DBL_MAX);}*/
if(tau<0.0){Rprintf("tau negative in g_outer!\n");error("");}
/** beta are the parameters values at which the function is to be evaluated **/
/** gvalue is the return value - a single double */
/** STOP - NEED TO copy betaincTau into shorter beta since last entry is tau = precision */
for(i=0;i<n_betas;i++){gsl_vector_set(beta,i,gsl_vector_get(betaincTau,i));/*Rprintf("passed beta=%f\n",gsl_vector_get(beta,i));*/
}
/** part 1 - the integrals over each group of observations - use laplace for this and that is taken care of in g_inner */
/** first we want to evaluate each of the integrals for each data group **/
for(j=0;j<designdata->numUnqGrps;j++){/** for each data group **/
/*j=0;*/
/*Rprintf("processing group %d\n",j+1);*/
singlegrp=g_pois_inner(betaincTau,designdata,j,epsabs_inner,maxiters_inner,verbose);
if(gsl_isnan(singlegrp)){error("nan in g_inner\n");}
term1+= singlegrp;
}
/*Rprintf("term1 in g_outer=%f\n",term1);*/
/** part 2 the priors for the means **/
term2=0; for(i=0;i<n_betas;i++){term2+=-log(sqrt(2.0*M_PI)*gsl_vector_get(priorsd,i));}
/** Calc this in parts: R code "term3<- sum( (-1/(2*sd.loc*sd.loc))*(mybeta-mean.loc)*(mybeta-mean.loc) );" **/
gsl_vector_memcpy(vectmp1,beta);/** copy beta to temp vec */
gsl_vector_memcpy(vectmp2,priormean);
gsl_vector_scale(vectmp2,-1.0);
gsl_vector_add(vectmp1,vectmp2);/** vectmp1= beta-mean**/
gsl_vector_memcpy(vectmp2,vectmp1);/** copy vectmp1 to vectmp2 **/
gsl_vector_mul(vectmp2,vectmp1);/** square all elements in vectmp1 and store in vectmp2 */
gsl_vector_memcpy(vectmp1,priorsd);
gsl_vector_mul(vectmp1,priorsd);/** square all elements in priorsd and store in vectmp1 */
gsl_vector_div(vectmp2,vectmp1);/** vectmp2/vectmp1 and store in vectmp2 **/
gsl_vector_scale(vectmp2,-0.5); /** scale by -1/2 */
gsl_vector_set_all(vectmp1,1.0); /** ones vector */
gsl_blas_ddot (vectmp2, vectmp1, &term3);/** DOT product simply to calcu sum value */
/** part 3 the prior for the precision tau **/
term4= -gsl_vector_get(priorgamshape,0)*log(gsl_vector_get(priorgamscale,0))
-gsl_sf_lngamma(gsl_vector_get(priorgamshape,0))
+(gsl_vector_get(priorgamshape,0)-1)*log(tau)
-(tau/gsl_vector_get(priorgamscale,0));
gval=(-1.0/n)*(term1+term2+term3+term4);
if(gsl_isnan(gval)){error("g_pois_outer_R\n");}
/*Rprintf("gvalue=%10.10f\n",gval);*/
return(gval);/** negative since its a minimiser */
}
double* intraguildPred(struct foodweb nicheweb, const double y[], double* intraPred)
{
int i,j,l;
int S = nicheweb.S;
int Y = nicheweb.Y;
int Rnum = nicheweb.Rnum;
gsl_vector *network = nicheweb.network; // Inhalt: A+linksA+Y+linksY+Massen+Trophische_Level = (Rnum+S)²+1+Y²+1+(Rnum+S)+S
double lambda = nicheweb.lambda;
double aij = nicheweb.aij;
double hand = nicheweb.hand;
/* Massen rausholen */
gsl_vector_view A_view = gsl_vector_subvector(network, 0, (Rnum+S)*(Rnum+S)); // Fressmatrix A als Vektor
gsl_matrix_view EA_mat = gsl_matrix_view_vector(&A_view.vector, (Rnum+S), (Rnum+S)); // A als Matrix_view
gsl_matrix *EAmat = &EA_mat.matrix; // A als Matrix
gsl_vector_view M_vec = gsl_vector_subvector(network, ((Rnum+S)*(Rnum+S))+1+(Y*Y)+1, (Rnum+S)); // Massenvektor
gsl_vector *Mvec = &M_vec.vector; // massvector: M(i)=m^(-0.25)
double ytemp[(Rnum+S)*Y]; // tempvector for populations and efforts
for(i=0;i<(Rnum+S)*Y;i++)
ytemp[i]=y[i];
/* Alles view_array */
/* Auslesen von ytemp = y[]; sind Population */
gsl_vector_view yfd_vec=gsl_vector_view_array(ytemp,(Rnum+S)*Y);
gsl_vector *yfdvec=&yfd_vec.vector; // populations and efforts for later use
/* Initialisierungen */
gsl_matrix *AFgsl=gsl_matrix_calloc(Rnum+S, Rnum+S); // matrix of foraging efforts
gsl_matrix *Emat=gsl_matrix_calloc(Rnum+S, Rnum+S); // gsl objects for calculations of populations
gsl_vector *tvec=gsl_vector_calloc(Rnum+S);
gsl_vector *rvec=gsl_vector_calloc(Rnum+S);
gsl_vector *svec=gsl_vector_calloc(Rnum+S);
gsl_vector *intraPredTemp=gsl_vector_calloc(Rnum+S);
for(l=0;l<Y;l++) // start of patch solving
{
/* Initialisierungen */
gsl_matrix_set_zero(AFgsl); // reset gsl objects for every patch
gsl_matrix_set_zero(Emat);
gsl_vector_set_zero(tvec);
gsl_vector_set_zero(rvec);
gsl_vector_set_zero(svec);
/* Je Vektoren von (Res+S) Elementen */
/* yfdvec enthält die Population */
gsl_vector_view y_vec=gsl_vector_subvector(yfdvec,(Rnum+S)*l,(Rnum+S));
gsl_vector *yvecint=&y_vec.vector;
/* Kopie von EAmat erstellen */
gsl_matrix_memcpy(AFgsl,EAmat);
for(i=0;i<Rnum+S;i++)
{
/* Nehme i-te Zeile aus A */
gsl_vector_view tempp=gsl_matrix_row(AFgsl,i);
/* Summiere Absolutwerte der Zeile */
double temp1;
temp1=gsl_blas_dasum(&tempp.vector);
if(temp1!=0)
{
/* Teile die Einträge, die nicht- Null sind durch Anzahl an nicht-Nullen in dieser Zeile*/
/* und setzte diesen Wert dann an den entsprechenden Platz */
/* Man erhält also eine prozentuale Verbindung */
for(j=0;j<Rnum+S;j++)
gsl_matrix_set(AFgsl,i,j,(gsl_matrix_get(AFgsl,i,j)/temp1));
}
}
/* aij ist Attackrate; AFgsl ist jetzt normiert- also fij */
gsl_matrix_memcpy(Emat,EAmat);
gsl_matrix_scale(Emat,aij); // Emat(i,j) = a(i,j)
gsl_matrix_mul_elements(Emat,AFgsl); // Emat(i,j) = a(i,j)*f(i,j)
/* hand = handling time */
/* Berechnung wie aus Paper */
gsl_vector_set(yvecint,0,0);
printf("y: %f\n",gsl_vector_get(yvecint,0));
gsl_vector_memcpy(svec,yvecint); // s(i)=y(i)
gsl_vector_scale(svec, hand); // s(i)=y(i)*h
gsl_blas_dgemv(CblasNoTrans,1,Emat,svec,0,rvec); // r(i)=Sum_k h*a(i,k)*f(i,k)*y(k)
gsl_vector_add_constant(rvec,1); // r(i)=1+Sum_k h*a(i,k)*f(i,k)*y(k)
gsl_vector_memcpy(tvec,Mvec); // t(i)=masse(i)^(-0.25)
gsl_vector_div(tvec,rvec); // t(i)=masse(i)^(-0.25)/(1+Sum_k h*a(i,k)*f(i,k)*y(k))
gsl_vector_mul(tvec,yvecint); // t(i)=masse(i)^(-0.25)*y(i)/(1+Sum_k h*a(i,k)*f(i,k)*y(k))
gsl_blas_dgemv(CblasNoTrans,lambda,Emat,yvecint,0,intraPredTemp); // ydot(i)=Sum_j lambda*a(i,j)*f(i,j)*y(j)
gsl_vector_mul(intraPredTemp,tvec);
intraPred[l] = gsl_blas_dasum(intraPredTemp);
}
/* Speicher befreien */
gsl_matrix_free(Emat);
gsl_matrix_free(AFgsl);
gsl_vector_free(tvec);
gsl_vector_free(rvec);
gsl_vector_free(svec);
gsl_vector_free(intraPredTemp);
return 0;
}
static int
cgst_step(const void * vtrust_state, const double delta,
gsl_vector * dx, void * vstate)
{
int status;
const gsl_multilarge_nlinear_trust_state *trust_state =
(const gsl_multilarge_nlinear_trust_state *) vtrust_state;
cgst_state_t *state = (cgst_state_t *) vstate;
const gsl_vector * x = trust_state->x;
const gsl_vector * f = trust_state->f;
const gsl_vector * swts = trust_state->sqrt_wts;
const gsl_vector * diag = trust_state->diag;
const gsl_multilarge_nlinear_parameters * params = trust_state->params;
gsl_multilarge_nlinear_fdf * fdf = trust_state->fdf;
double alpha, beta, u;
double norm_Jd; /* || J D^{-1} d_i || */
double norm_r; /* || r_i || */
double norm_rp1; /* || r_{i+1} || */
size_t i;
/* Step 1 of [1], section 2; scale gradient as
*
* g~ = D^{-1} g
*
* for better numerical stability
*/
for (i = 0; i < state->p; ++i)
{
double gi = gsl_vector_get(trust_state->g, i);
double di = gsl_vector_get(trust_state->diag, i);
gsl_vector_set(state->z, i, 0.0);
gsl_vector_set(state->r, i, -gi / di);
gsl_vector_set(state->d, i, -gi / di);
gsl_vector_set(state->workp, i, gi / di);
}
/* compute || g~ || */
state->norm_g = gsl_blas_dnrm2(state->workp);
for (i = 0; i < state->cgmaxit; ++i)
{
/* workp := D^{-1} d_i */
gsl_vector_memcpy(state->workp, state->d);
gsl_vector_div(state->workp, trust_state->diag);
/* workn := J D^{-1} d_i */
status = gsl_multilarge_nlinear_eval_df(CblasNoTrans, x, f, state->workp,
swts, params->h_df, params->fdtype,
fdf, state->workn, NULL);
if (status)
return status;
/* compute || J D^{-1} d_i || */
norm_Jd = gsl_blas_dnrm2(state->workn);
/* Step 2 of [1], section 2 */
if (norm_Jd == 0.0)
{
double tau = cgst_calc_tau(state->z, state->d, delta);
/* dx = z_i + tau*d_i */
scaled_addition(1.0, state->z, tau, state->d, dx);
gsl_vector_div(dx, diag);
return GSL_SUCCESS;
}
/* Step 3 of [1], section 2 */
norm_r = gsl_blas_dnrm2(state->r);
u = norm_r / norm_Jd;
alpha = u * u;
/* workp <= z_{i+1} = z_i + alpha_i*d_i */
scaled_addition(1.0, state->z, alpha, state->d, state->workp);
u = gsl_blas_dnrm2(state->workp);
if (u >= delta)
{
double tau = cgst_calc_tau(state->z, state->d, delta);
/* dx = z_i + tau*d_i */
scaled_addition(1.0, state->z, tau, state->d, dx);
gsl_vector_div(dx, diag);
return GSL_SUCCESS;
}
/* store z_{i+1} */
gsl_vector_memcpy(state->z, state->workp);
/* Step 4 of [1], section 2 */
/* compute: workp := alpha B d_i = alpha D^{-1} J^T J D^{-1} d_i,
* where J D^{-1} d_i is already stored in workn */
status = gsl_multilarge_nlinear_eval_df(CblasTrans, x, f, state->workn,
swts, params->h_df, params->fdtype,
fdf, state->workp, NULL);
if (status)
return status;
gsl_vector_div(state->workp, trust_state->diag);
gsl_vector_scale(state->workp, alpha);
/* r_{i+1} = r_i - alpha*B*d_i */
gsl_vector_sub(state->r, state->workp);
norm_rp1 = gsl_blas_dnrm2(state->r);
u = norm_rp1 / state->norm_g;
if (u < state->cgtol)
{
gsl_vector_memcpy(dx, state->z);
gsl_vector_div(dx, diag);
return GSL_SUCCESS;
}
/* Step 5 of [1], section 2 */
/* compute u = ||r_{i+1}|| / || r_i|| */
u = norm_rp1 / norm_r;
beta = u * u;
/* compute: d_{i+1} = rt_{i+1} + beta*d_i */
scaled_addition(1.0, state->r, beta, state->d, state->d);
}
/* failed to converge, return current estimate */
gsl_vector_memcpy(dx, state->z);
gsl_vector_div(dx, diag);
return GSL_EMAXITER;
}
/**
* needs:
* params file
* BURN_IN_ITERATIONS
* first line in calibration_result
* BETA_ALIGNMENT
* BETA_0
* SKIP_CALIBRATE_ALLCHAINS
**
* does:
* calibrate remaining chains (beta < 1)
* writes all betas, stepwidths and start values in file calibration_result
**
* provides:
* stepwidths of first chain (calibration_result)
* new params file (params_suggest)
* new start values (calibration_result)
**/
void calibrate_rest() {
int n_beta = N_BETA;
const double desired_acceptance_rate = TARGET_ACCEPTANCE_RATE;
const double max_ar_deviation = MAX_AR_DEVIATION;
double beta_0 = BETA_0;
const unsigned long burn_in_iterations = BURN_IN_ITERATIONS;
const unsigned long iter_limit = ITER_LIMIT;
const double mul = MUL;
unsigned int n_par;
int i;
gsl_vector * stepwidth_factors;
mcmc ** chains = setup_chains();
read_calibration_file(chains, 1);
printf("Calibrating chains\n");
fflush(stdout);
n_par = get_n_par(chains[0]);
stepwidth_factors = gsl_vector_alloc(n_par);
gsl_vector_set_all(stepwidth_factors, 1);
i = 1;
if (n_beta > 1) {
if (beta_0 < 0)
set_beta(chains[i], get_chain_beta(i, n_beta, calc_beta_0(
chains[0], stepwidth_factors)));
else
set_beta(chains[i], get_chain_beta(i, n_beta, beta_0));
gsl_vector_free(get_steps(chains[i]));
chains[i]->params_step = dup_vector(get_steps(chains[0]));
gsl_vector_scale(get_steps(chains[i]), pow(get_beta(chains[i]), -0.5));
set_params(chains[i], dup_vector(get_params_best(chains[0])));
calc_model(chains[i], NULL);
mcmc_check(chains[i]);
printf("Calibrating second chain to infer stepwidth factor\n");
printf("\tChain %2d - ", i);
printf("beta = %f\tsteps: ", get_beta(chains[i]));
dump_vectorln(get_steps(chains[i]));
fflush(stdout);
markov_chain_calibrate(chains[i], burn_in_iterations,
desired_acceptance_rate, max_ar_deviation, iter_limit, mul,
DEFAULT_ADJUST_STEP);
gsl_vector_scale(stepwidth_factors, pow(get_beta(chains[i]), -0.5));
gsl_vector_mul(stepwidth_factors, get_steps(chains[0]));
gsl_vector_div(stepwidth_factors, get_steps(chains[i]));
mem_free(chains[i]->additional_data);
}
printf("stepwidth factors: ");
dump_vectorln(stepwidth_factors);
if (beta_0 < 0) {
beta_0 = calc_beta_0(chains[0], stepwidth_factors);
printf("automatic beta_0: %f\n", beta_0);
}
fflush(stdout);
#pragma omp parallel for
for (i = 1; i < n_beta; i++) {
printf("\tChain %2d - ", i);
fflush(stdout);
chains[i]->additional_data
= mem_malloc(sizeof(parallel_tempering_mcmc));
set_beta(chains[i], get_chain_beta(i, n_beta, beta_0));
gsl_vector_free(get_steps(chains[i]));
chains[i]->params_step = dup_vector(get_steps(chains[0]));
gsl_vector_scale(get_steps(chains[i]), pow(get_beta(chains[i]), -0.5));
gsl_vector_mul(get_steps(chains[i]), stepwidth_factors);
set_params(chains[i], dup_vector(get_params_best(chains[0])));
calc_model(chains[i], NULL);
mcmc_check(chains[i]);
printf("beta = %f\tsteps: ", get_beta(chains[i]));
dump_vectorln(get_steps(chains[i]));
fflush(stdout);
#ifndef SKIP_CALIBRATE_ALLCHAINS
markov_chain_calibrate(chains[i], burn_in_iterations,
desired_acceptance_rate, max_ar_deviation, iter_limit, mul,
DEFAULT_ADJUST_STEP);
#else
burn_in(chains[i], burn_in_iterations);
#endif
}
gsl_vector_free(stepwidth_factors);
fflush(stdout);
printf("all chains calibrated.\n");
for (i = 0; i < n_beta; i++) {
printf("\tChain %2d - beta = %f \tsteps: ", i, get_beta(chains[i]));
dump_vectorln(get_steps(chains[i]));
}
write_calibration_summary(chains, n_beta);
write_calibrations_file(chains, n_beta);
}
/** **************************************************************************************************************/
double g_outer_gaus_single (double x, void *params)
{
int i,j;
double term1=0.0;
const datamatrix *designdata = ((struct fnparams *) params)->designdata;/** all design data inc Y and priors **/
gsl_vector *betaincTau = ((struct fnparams *) params)->betaincTau;/** include precision */
int fixed_beta =((struct fnparams *) params)->fixed_index;/** which parameter is to be treated as fixed */
const gsl_vector *priormean = designdata->priormean;
const gsl_vector *priorsd = designdata->priorsd;
const gsl_vector *priorgamshape = designdata->priorgamshape;
const gsl_vector *priorgamscale = designdata->priorgamscale;
gsl_vector *beta = ((struct fnparams *) params)->beta;/** does not include precision */
gsl_vector *vectmp1= ((struct fnparams *) params)->vectmp1;/** numparams long*/
gsl_vector *vectmp2 =((struct fnparams *) params)->vectmp2;/** numparams long*/
double epsabs_inner=((struct fnparams *) params)->epsabs_inner;/** absolute error in internal laplace est */
int maxiters_inner=((struct fnparams *) params)->maxiters_inner;/** number of steps for inner root finder */
int verbose=((struct fnparams *) params)->verbose;/** */
int n_betas= (designdata->datamatrix_noRV)->size2;/** number of mean terms excl rv and precision **/
int n=(designdata->datamatrix_noRV)->size1;/** total number of obs **/
double term2=0.0,term3=0.0,term4=0.0,gval=0.0, term5=0.0;
/*Rprintf("%d %d\n",n_betas,betaincTau->size);*/
double tau_rv,tau_resid, copyBeta=0.0;
/** need to replace variable fixed_beta with x **/
copyBeta=gsl_vector_get(betaincTau,fixed_beta);/** store value so can reset later */
gsl_vector_set(betaincTau,fixed_beta,x);
tau_rv=gsl_vector_get(betaincTau,betaincTau->size-2);/** extract the tau-precision from *beta - last entry */
/*Rprintf("g_outer_rv tau=%f\n",tau_rv);*/
tau_resid=gsl_vector_get(betaincTau,betaincTau->size-1);/** extract the tau-precision from *beta - last entry */
/*Rprintf("g_outer_resid tau=%f\n",tau_resid);*/
if(tau_rv<=0.0){/*Rprintf("tau_rv negative=%e in g_outer_gaus_single!\n",tau_rv);*/
/** aborting so re-copy value of beta changed back to what it was since passed by memory **/
/** this might legitimately occur when trying to use a central difference - which is caught by testing for isnan */
gsl_vector_set(betaincTau,fixed_beta,copyBeta);
return(GSL_NAN);
/*error("");*/}
if(tau_resid<=0.0){/*Rprintf("tau_resid negative=%e in g_outer_gaus_single!\n",tau_resid);*/
/** aborting so re-copy value of beta changed back to what it was since passed by memory **/
/** this might legitimately occur when trying to use a central difference - which is caught by testing for isnan */
gsl_vector_set(betaincTau,fixed_beta,copyBeta);
return(GSL_NAN);
/*error("");*/}
/** beta are the parameters values at which the function is to be evaluated **/
/** gvalue is the return value - a single double */
/** STOP - NEED TO copy betaincTau into shorter beta since last two entries are group precision then residual precision */
for(i=0;i<n_betas;i++){gsl_vector_set(beta,i,gsl_vector_get(betaincTau,i));/*Rprintf("passed beta=%f\n",gsl_vector_get(beta,i));*/
}
/** part 1 - the integrals over each group of observations - use laplace for this and that is taken care of in g_inner */
/** first we want to evaluate each of the integrals for each data group **/
for(j=0;j<designdata->numUnqGrps;j++){/** for each data group **/
/*j=0;*/
/*Rprintf("processing group %d\n",j+1);*/
term1+= g_inner_gaus(betaincTau,designdata,j, epsabs_inner,maxiters_inner,verbose);
}
/*Rprintf("term1 in g_outer=%f\n",term1);*/
/** part 2 the priors for the means **/
term2=0; for(i=0;i<n_betas;i++){term2+=-log(sqrt(2.0*M_PI)*gsl_vector_get(priorsd,i));}
/** Calc this in parts: R code "term3<- sum( (-1/(2*sd.loc*sd.loc))*(mybeta-mean.loc)*(mybeta-mean.loc) );" **/
gsl_vector_memcpy(vectmp1,beta);/** copy beta to temp vec */
gsl_vector_memcpy(vectmp2,priormean);
gsl_vector_scale(vectmp2,-1.0);
gsl_vector_add(vectmp1,vectmp2);/** vectmp1= beta-mean**/
gsl_vector_memcpy(vectmp2,vectmp1);/** copy vectmp1 to vectmp2 **/
gsl_vector_mul(vectmp2,vectmp1);/** square all elements in vectmp1 and store in vectmp2 */
gsl_vector_memcpy(vectmp1,priorsd);
gsl_vector_mul(vectmp1,priorsd);/** square all elements in priorsd and store in vectmp1 */
gsl_vector_div(vectmp2,vectmp1);/** vectmp2/vectmp1 and store in vectmp2 **/
gsl_vector_scale(vectmp2,-0.5); /** scale by -1/2 */
gsl_vector_set_all(vectmp1,1.0); /** ones vector */
gsl_blas_ddot (vectmp2, vectmp1, &term3);/** DOT product simply to calcu sum value */
/** part 3 the prior for the group precision tau_rv **/
term4= -gsl_vector_get(priorgamshape,0)*log(gsl_vector_get(priorgamscale,0))
-gsl_sf_lngamma(gsl_vector_get(priorgamshape,0))
+(gsl_vector_get(priorgamshape,0)-1)*log(tau_rv)
-(tau_rv/gsl_vector_get(priorgamscale,0));
/** part 4 the prior for the residual precision tau_resid **/
term5= -gsl_vector_get(priorgamshape,0)*log(gsl_vector_get(priorgamscale,0))
-gsl_sf_lngamma(gsl_vector_get(priorgamshape,0))
+(gsl_vector_get(priorgamshape,0)-1)*log(tau_resid)
-(tau_resid/gsl_vector_get(priorgamscale,0));
gval=(-1.0/n)*(term1+term2+term3+term4+term5);
/** NO PRIOR */
/* Rprintf("WARNING - NO PRIOR\n");*/
#ifdef NOPRIOR
gval=(-1.0/n)*(term1);
#endif
/** finally re-copy value of beta changed back to what it was since passed by memory **/
gsl_vector_set(betaincTau,fixed_beta,copyBeta);
if(gsl_isnan(gval)){error("g_outer_gaus_single\n");}
/*Rprintf("g_outer_final=%f term1=%f term2=%f term3=%f term4=%f term5=%f total=%f %d\n",gval,term1,term2,term3,term4,term5,term1+term2+term3+term4,n);*/
return(gval);/** negative since its a minimiser */
}
