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