void init_dln_sigma_dln_mass()
{
int k=0, nTot=0;
double result, abserr, mass;
nTot = ThMassFunc[MF_INDEX].bins;
gsl_function F;
F.function = &ln_sigma;
F.params = 0;
# pragma omp parallel for \
shared(ThMassFunc) private(mass, k, result)
for(k=0; k<nTot; k++)
{
mass = ThMassFunc[MF_INDEX].ln_mass[k];
if (k==0)
gsl_deriv_forward (&F, mass, 1e-4, &result, &abserr);
else if (k==nTot-1)
gsl_deriv_backward (&F, mass, 1e-4, &result, &abserr);
else
gsl_deriv_central (&F, mass, 1e-4, &result, &abserr);
ThMassFunc[MF_INDEX].dln_sigma_dln_mass[k]=result;
}
}
/** *************************************************************************************
*****************************************************************************************
*****************************************************************************************/
void rv_dg_pois_outer_marg_R (int Rn, double *betashortDBL, double *dgvalueshortDBL, void *params)/* void rv_dg_outer_marg_R(int n, double *betaDBL, double *dgvaluesDBL,void *params);*/
{
struct fnparams *gparams = ((struct fnparams *) params);
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;
gsl_function F;int i,j;
int haveTau=0;
double result, abserr;
double h=((struct fnparams *) gparams)->finitestepsize;
gparams->betaincTau=betaincTau;/** copy memory location */
/** copy betashort - which is marginal and therefore lacks one entry - and copy it into a complex beta */
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]);}
}
if(gsl_vector_get(betaincTau,betaincTau->size-1)<0.0){error("negative tau in rv_dg_outer_marg_R\n");}
F.function = &g_outer_pois_single;
F.params = gparams;
j=0;
for(i=0;i<Rn+1;i++){ /** each of the partial derivatives for the full non-marginal vector*/
if(i!=betaindex){/** ignore the marginal variable here - it is fixed globally outside the partial derivs*/
gparams->fixed_index=i;
if(i== Rn){haveTau=1;} else {haveTau=0;}
/** readme - evaluating f() at a negative value e.g. tau-h **/
if(!haveTau){gsl_deriv_central (&F, gsl_vector_get(betaincTau,i), h, &result, &abserr);/*Rprintf("fixed=%d val=%f\n",i,result);*/
} else { /** first try central and if this goes into negative tau area then revert to forwards **/
gsl_deriv_central(&F, gsl_vector_get(betaincTau,i), h, &result, &abserr);
if(gsl_isnan(abserr)){gsl_deriv_forward(&F, gsl_vector_get(betaincTau,i), h, &result, &abserr);}
}
dgvalueshortDBL[j++]=result;
}
}
for(i=0;i<Rn;i++){if(gsl_isnan(dgvalueshortDBL[i])){error("nan is rv_dg_pois_outer_marg\n");}}
/*}*/
/*if(betafixed>2.34){Rprintf("betaincTau=");for(i=0;i<betaincTau->size;i++){Rprintf("%f ",i,gsl_vector_get(betaincTau,i));}Rprintf("\n");
for(i=0;i<dgvalueshort->size;i++){Rprintf("deriv=%d %f\n",i,gsl_vector_get(dgvalueshort,i));}
Rprintf("error=%f\n",abserr);}*/
/*Rprintf("rv_dg_outer_marg end\n");*/
/*Rprintf("dgvals\n");
for(i=0;i<Rn;i++){Rprintf(" %10.10f ",dgvalueshortDBL[i]);}Rprintf("\n");*/
}
int div(){
gsl_function F;
F.function=&f;
F.params =0;
double h=le-3, result, abserr, x=5;
gsl_deriv_central(&F,x,h, &result,&abserr);
x=0;
gsl_deriv_forward(&F,x,h,&result,&abserr);
return result;
}
/** *************************************************************************************
*****************************************************************************************
*****************************************************************************************/
void rv_dg_outer_R (int n, double *betaDBL, double *dgvaluesDBL,void *params)
{
struct fnparams *gparams = ((struct fnparams *) params);
/** fixed covariate and precision terms **/
gsl_function F;int i;int haveTau=0;
double result, abserr;
double h=((struct fnparams *) gparams)->finitestepsize;
/*double h_adj=0.0;*//** a new h is existing h is too small **/
gsl_vector *betaincTau=((struct fnparams *) gparams)->betaincTau;/** scratch space to copy betaincTauDBL into **/
for(i=0;i<betaincTau->size;i++){gsl_vector_set(betaincTau,i,betaDBL[i]);} /** copy into gsl_vector **/
if(betaDBL[n-1]<0.0){error("negative tau in rv_dg_outer_R\n");}
/** if get tau which is negative */
F.function = &g_outer_single;
F.params = gparams;
for(i=0;i<n;i++){ /** each of the partial derivatives */
gparams->fixed_index=i;
if(i== n-1){haveTau=1;} else {haveTau=0;}
/** readme - evaluating f() at a negative value e.g. tau-h **/
if(!haveTau){gsl_deriv_central (&F, betaDBL[i], h, &result, &abserr);/*Rprintf("fixed=%d val=%f\n",i,result);*/
} else { /** first try central and if this goes into negative tau area then revert to forwards **/
gsl_deriv_central(&F, betaDBL[i], h, &result, &abserr);
if(gsl_isnan(abserr)){gsl_deriv_forward(&F, betaDBL[i], h, &result, &abserr);}
}
dgvaluesDBL[i]=result;
}
}
int
gsl_deriv_backward (const gsl_function * f, double x, double h,
double *result, double *abserr)
{
return gsl_deriv_forward (f, x, -h, result, abserr);
}
/** *************************************************************************************************************************/
double get_second_deriv_3pt(struct fnparams *gparams, int i, int j, double h, int haveTau, gsl_function *F)
{
double result1,result2,result3, abserr1,abserr2,abserr3;
gsl_vector *beta=gparams->betaincTau;
double *beta_j=&(beta->data[j]);/** pointers to the relevant enties in beta vector **/
double *beta_i=&(beta->data[i]);
const double masterbetaj=gsl_vector_get(beta,j);
/** want to call g_outer_single with varible j shifted */
if(!haveTau){/** if not tau use central differences **/
/** 2 terms for df_xj each of which need expanded. We FIX x_j at different value and then expand five point formula on xi **/
/** f(x_j-h,x_i...) etc */
*beta_j=*beta_j+1.0*h;
gsl_deriv_central(F, *beta_i, h, &result1, &abserr1);
*beta_j=masterbetaj;/** reset **/
/** f(x_j+h,x_i...) etc */
*beta_j=*beta_j-1.0*h;
gsl_deriv_central(F, *beta_i, h, &result2, &abserr2);
*beta_j=masterbetaj;/** reset **/
return((1.0/(2.0*h))*(result1-result2));
}
if(haveTau && i==j && *beta_i-1.0*h<0.0){/** want d^2f/dtau dtau and tau would be negative given using a central diff so use left end version */
/** f(x_j,x_i...) etc */
*beta_j=*beta_j;/** no change */
gsl_deriv_central(F, *beta_i, h, &result1, &abserr1);
if(gsl_isnan(abserr1)){gsl_deriv_forward (F, *beta_i, h, &result1, &abserr1);} /** in case h used trips into negative tau */
*beta_j=masterbetaj;/** reset **/
/** f(x_j+h,x_i...) etc */
*beta_j=*beta_j+h;/** no change */
gsl_deriv_central(F, *beta_i, h, &result2, &abserr2);
if(gsl_isnan(abserr2)){gsl_deriv_forward (F, *beta_i, h, &result2, &abserr2);} /** in case h used trips into negative tau */
*beta_j=masterbetaj;/** reset **/
/** f(x_j+h,x_i...) etc */
*beta_j=*beta_j+2.0*h;/** no change */
gsl_deriv_central(F, *beta_i, h, &result3, &abserr3);
if(gsl_isnan(abserr3)){gsl_deriv_forward (F, *beta_i, h, &result3, &abserr3);} /** in case h used trips into negative tau */
*beta_j=masterbetaj;/** reset **/
return((1.0/(2.0*h))*(-3.0*result1+4.0*result2-result3));
}
if(haveTau){/** want d^2f/dtau dx or d^2f/dtau dtau and in the latter we can evalute use a central difference for the first derivative */
/** f(x_j-2h,x_i...) etc */
*beta_j=*beta_j+1.0*h;
gsl_deriv_central(F, *beta_i, h, &result1, &abserr1);/** this is value of first derivative at b_j=b_j-2h */
if(gsl_isnan(abserr1)){gsl_deriv_forward (F, *beta_i, h, &result1, &abserr1);}
*beta_j=masterbetaj;/** reset **/
/** f(x_j-h,x_i...) etc */
*beta_j=*beta_j-1.0*h;
gsl_deriv_central(F, *beta_i, h, &result2, &abserr2);
if(gsl_isnan(abserr2)){gsl_deriv_forward (F, *beta_i, h, &result2, &abserr2);}
*beta_j=masterbetaj;/** reset **/
return((1.0/(2.0*h))*(result1-result2));
}
error("should never get here - hessian\n");
return(1.0);
}
