/** *************************************************************************************
*****************************************************************************************
*****************************************************************************************/
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");*/
}
// Write into retval the gradient of the continuous part of the objective function of prob calculated in input.
void gsl_gradient::objfun_numdiff_central(gsl_vector *retval, const problem::base &prob, const decision_vector &input, const double &step_size)
{
if (input.size() != prob.get_dimension()) {
pagmo_throw(value_error,"invalid input vector dimension in numerical differentiation of the objective function");
}
if (prob.get_f_dimension() != 1) {
pagmo_throw(value_error,"numerical differentiation of the objective function cannot work on multi-objective problems");
}
// Size of the continuous part of the problem.
const problem::base::size_type cont_size = prob.get_dimension() - prob.get_i_dimension();
// Structure to pass data to the wrapper.
objfun_numdiff_wrapper_params pars;
pars.x = input;
pars.f.resize(1);
pars.prob = &prob;
// GSL function.
gsl_function F;
F.function = &objfun_numdiff_wrapper;
F.params = (void *)&pars;
double result, abserr;
// Numerical differentiation component by component.
for (problem::base::size_type i = 0; i < cont_size; ++i) {
pars.coord = i;
gsl_deriv_central(&F,input[i],step_size,&result,&abserr);
gsl_vector_set(retval,i,result);
}
}
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 TCurveBase::derivative(const Math::Vector2 & xy, Math::Vector2 & dxdy) const
{
double abserr;
struct curve_gsl_params_s params;
gsl_function gsl_func;
gsl_func.params = ¶ms;
params.c = this;
params.x = xy.x();
params.y = xy.y();
gsl_func.function = gsl_func_sagitta_x;
gsl_deriv_central(&gsl_func, xy.x(), 1e-6, &dxdy.x(), &abserr);
gsl_func.function = gsl_func_sagitta_y;
gsl_deriv_central(&gsl_func, xy.y(), 1e-6, &dxdy.y(), &abserr);
}
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;
}
/*derivative: wrapper for the GSL derivative gsl_deriv_central(); used to
*help speed up the integration over harmonic number n
*@param n_start: Input, value of n at which the derivative is to be performed
*@param nu: Input, frequency of absorption/emission
*/
double derivative(double n_start, double nu)
{
gsl_function F;
double result;
double abserr;
F.function = gamma_integration_result;
F.params = ν
gsl_deriv_central(&F, n_start, 1e-8, &result, &abserr);
return result;
}
/**
* Function to calculate the second derivative of the Hamiltonian.
* The derivatives are taken with respect to indices idx1, idx2 */
static REAL8
XLALCalculateSphHamiltonianDeriv2Prec(
const int idx1, /**<< Derivative w.r.t. index 1 */
const int idx2, /**<< Derivative w.r.t. index 2 */
const REAL8 values[], /**<< Dynamical variables in spherical coordinates */
SpinEOBParams * params /**<< Spin EOB Parameters */
)
{
static const REAL8 STEP_SIZE = 1.0e-5;
REAL8 result;
REAL8 UNUSED absErr;
HcapSphDeriv2Params dParams;
gsl_function F;
INT4 UNUSED gslStatus;
dParams.sphValues = values;
dParams.varyParam1 = idx1;
dParams.varyParam2 = idx2;
dParams.params = params;
/*
* XLAL_PRINT_INFO( " In second deriv function: values\n" ); for ( int i = 0;
* i < 12; i++ ) { XLAL_PRINT_INFO( "%.16e ", values[i] ); } XLAL_PRINT_INFO( "\n" );
*/
F.function = GSLSpinHamiltonianDerivWrapperPrec;
F.params = &dParams;
/* GSL seemed to give weird answers - try my own code */
/*
* result = GSLSpinHamiltonianDerivWrapperPrec( values[idx1] + STEP_SIZE,
* &dParams ) - GSLSpinHamiltonianDerivWrapperPrec( values[idx1] -
* STEP_SIZE, &dParams ); XLAL_PRINT_INFO( "%.16e - %.16e / 2h\n",
* GSLSpinHamiltonianDerivWrapperPrec( values[idx1] + STEP_SIZE, &dParams
* ), GSLSpinHamiltonianDerivWrapperPrec( values[idx1] - STEP_SIZE,
* &dParams ) );
*
* result = result / ( 2.*STEP_SIZE );
*/
XLAL_CALLGSL(gslStatus = gsl_deriv_central(&F, values[idx1],
STEP_SIZE, &result, &absErr));
if (gslStatus != GSL_SUCCESS) {
XLALPrintError("XLAL Error %s - Failure in GSL function\n", __func__);
XLAL_ERROR_REAL8(XLAL_EDOM);
}
//XLAL_PRINT_INFO("Second deriv abs err = %.16e\n", absErr);
//XLAL_PRINT_INFO("RESULT = %.16e\n", result);
return result;
}
//----------------------------------------------------------------------------
int dif2p(REAL x,REAL alpha,REAL (*fp)(REAL,void*),REAL * result,REAL * abserr){
gsl_function F;
F.function = fp;
F.params = α
gsl_deriv_central (&F, x, 1e-8, result, abserr);
//gsl_deriv_forward (&F, x, 1e-8, result, abserr);
//gsl_deriv_backward (&F, x, 1e-8, result, abserr);
return 0;
}
/* This is the function that should be called by Fortran. The interface is defined
in loct_math.F90 file. */
void FC_FUNC_(oct_numerical_derivative, OCT_NUMERICAL_DERIVATIVE)
(const double *x, const double *h, double *result, double *abserr, const func_nd f)
{
gsl_function F;
param_nd_t p;
p.func = f;
F.function = &function_oct_numerical_derivative;
F.params = (void *) &p;
/* the GSL headers specify double x, double h */
gsl_deriv_central (&F, *x, *h, result, abserr);
return;
}
//----------------------------------------------------------------------------
int dif4p(REAL x,REAL p1,REAL p2,REAL p3,REAL (*fp)(REAL,void*),
REAL * result,REAL * abserr){
struct f_params_3 alpha = {p1,p2,p3};
gsl_function F;
F.function = fp;
F.params = α
gsl_deriv_central (&F, x, 1e-8, result, abserr);
//gsl_deriv_forward (&F, x, 1e-8, result, abserr);
//gsl_deriv_backward (&F, x, 1e-8, result, abserr);
return 0;
}
/** *************************************************************************************
*****************************************************************************************
*****************************************************************************************/
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;
}
}
gsl_matrix * gsl_jacobian( gsl_vector * (*function)(const gsl_vector* x, void*params), const gsl_vector *x, void*params) {
gsl_vector * fx = function(x,params);
int rows = fx->size;
int columns = x->size;
gsl_matrix * m = gsl_matrix_alloc(rows,columns);
for(int i=0;i<rows;i++)
for(int j=0;j<columns;j++) {
struct my_params_struct s;
s.function = function;
s.x0 = x;
s.i = i;
s.j = j;
s.params = params;
gsl_function F;
F.function = &my_gsl_function;
F.params = &s;
double result;
double abserr;
double h = 0.001;
int res = gsl_deriv_central( &F, gsl_vector_get(x,j), h, &result, &abserr);
gsl_matrix_set(m,i,j,result);
}
gsl_vector_free(fx);
return m;
}
/** *************************************************************************************************************************/
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);
}
void ppl_expDifferentiate(ppl_context *c, pplExpr *inExpr, int inExprCharPos, char *expr, int exprPos, char *dummy, pplObj *point, pplObj *step, pplObj *out, int dollarAllowed, int iterDepth)
{
calculusComm commlink;
pplObj *dummyVar;
pplObj dummyTemp;
gsl_function fn;
pplExpr *expr2;
int explen;
double resultReal=0, resultImag=0, dIdI, dRdI;
double resultReal_error, resultImag_error, dIdI_error, dRdI_error;
if (!ppl_unitsDimEqual(point, step))
{
strcpy(c->errStat.errBuff, "The arguments x and step to this differentiation operation are not dimensionally compatible.");
ppl_tbAdd(c,inExpr->srcLineN,inExpr->srcId,inExpr->srcFname,0,ERR_NUMERICAL,inExprCharPos,inExpr->ascii,"diff_d?() function");
return;
}
if (step->flagComplex)
{
strcpy(c->errStat.errBuff, "The argument 'step' to this differentiation operation must be a real number; supplied value is complex.");
ppl_tbAdd(c,inExpr->srcLineN,inExpr->srcId,inExpr->srcFname,0,ERR_NUMERICAL,inExprCharPos,inExpr->ascii,"diff_d?() function");
return;
}
{
int errPos=-1, errType=-1;
ppl_expCompile(c,inExpr->srcLineN,inExpr->srcId,inExpr->srcFname,expr,&explen,dollarAllowed,1,1,&expr2,&errPos,&errType,c->errStat.errBuff);
if (errPos>=0) { pplExpr_free(expr2); ppl_tbAdd(c,inExpr->srcLineN,inExpr->srcId,inExpr->srcFname,0,errType,errPos+exprPos,inExpr->ascii,"diff_d?() function"); return; }
if (explen<strlen(expr)) { strcpy(c->errStat.errBuff, "Unexpected trailing matter at the end of differentiated expression."); ppl_tbAdd(c,inExpr->srcLineN,inExpr->srcId,inExpr->srcFname,0,ERR_SYNTAX,explen,inExpr->ascii,"diff_d?() function"); pplExpr_free(expr2); return; }
}
commlink.context = c;
commlink.integrate = 0;
commlink.expr = expr2;
commlink.isFirst = 1;
commlink.testingReal = 1;
commlink.varyingReal = 1;
commlink.dollarAllowed = dollarAllowed;
commlink.iterDepth = iterDepth;
pplObjNum(&commlink.first,0,0,0);
ppl_contextGetVarPointer(c, dummy, &dummyVar, &dummyTemp);
dummyVar->objType = point->objType;
dummyVar->real = point->real;
dummyVar->imag = point->imag;
dummyVar->flagComplex = point->flagComplex;
ppl_unitsDimCpy(dummyVar, point); // Get units of dummyVar right
commlink.dummy = dummyVar;
commlink.dummyReal = dummyVar->real;
commlink.dummyImag = dummyVar->imag;
fn.function = &ppl_expEvalCalculusSlave;
fn.params = &commlink;
gsl_deriv_central(&fn, point->real, step->real, &resultReal, &resultReal_error);
pplExpr_free(expr2);
if ((!c->errStat.status) && (c->set->term_current.ComplexNumbers == SW_ONOFF_ON))
{
commlink.testingReal = 0;
gsl_deriv_central(&fn, point->real, step->real, &resultImag, &resultImag_error);
commlink.varyingReal = 0;
gsl_deriv_central(&fn, point->imag, step->real, &dIdI , &dIdI_error);
commlink.testingReal = 1;
gsl_deriv_central(&fn, point->imag, step->real, &dRdI , &dRdI_error);
if ((!ppl_dblApprox(resultReal, dIdI, 2*(resultReal_error+dIdI_error))) || (!ppl_dblApprox(resultImag, -dRdI, 2*(resultImag_error+dRdI_error))))
{ sprintf(c->errStat.errBuff, "The Cauchy-Riemann equations are not satisfied at this point in the complex plane. It does not therefore appear possible to perform complex differentiation. In the notation f(x+iy)=u+iv, the offending derivatives were: du/dx=%e, dv/dy=%e, du/dy=%e and dv/dx=%e.", resultReal, dIdI, dRdI, resultImag); ppl_tbAdd(c,inExpr->srcLineN,inExpr->srcId,inExpr->srcFname,0,ERR_NUMERICAL,exprPos,inExpr->ascii,"diff_d?() function"); return; }
}
ppl_contextRestoreVarPointer(c, dummy, &dummyTemp); // Restore old value of the dummy variable we've been using
if (!c->errStat.status)
{
int status=0, errType=-1;
point->real = 1.0; point->imag = 0.0; point->flagComplex = 0;
ppl_uaDiv( c , &commlink.first , point , out , &status, &errType, c->errStat.errBuff ); // Get units of output right
if (status) { ppl_tbAdd(c,inExpr->srcLineN,inExpr->srcId,inExpr->srcFname,0,errType,inExprCharPos,inExpr->ascii,"diff_d?() function"); return; }
out->real = resultReal;
out->imag = resultImag;
out->flagComplex = !ppl_dblEqual(resultImag, 0);
if (!out->flagComplex) out->imag=0.0; // Enforce that real numbers have positive zero imaginary components
}
if ((!gsl_finite(out->real)) || (!gsl_finite(out->imag)) || ((out->flagComplex) && (c->set->term_current.ComplexNumbers == SW_ONOFF_OFF)))
{
if (c->set->term_current.ExplicitErrors == SW_ONOFF_ON) { sprintf(c->errStat.errBuff, "Differentiated expression does not evaluate to a finite value."); ppl_tbAdd(c,inExpr->srcLineN,inExpr->srcId,inExpr->srcFname,0,ERR_NUMERICAL,exprPos,inExpr->ascii,"diff_d?() function"); return; }
else { out->real = GSL_NAN; out->imag = 0; out->flagComplex=0; }
}
return;
}
/**
* Function to calculate R.H.S. of the ODEs, given dyanmical variables,
* their derivatives and EOB parameters. Since SEOBNRv1 spin Hamiltonian
* was implemented for Cartesean coordinates while dynamical evolution was
* implemented in polar coordinates, we need to perform a transform.
* This is done in a particular transform in which
* x = r, y = z = 0, px = pr, py = pphi/r, pz = 0, and
* omega = v/r = (dy/dt)/r = (dH/dpy)/r, dr/dt = dx/dt = dH/dpx, etc.
*/
static int XLALSpinAlignedHcapDerivative(
double UNUSED t, /**< UNUSED */
const REAL8 values[], /**< dynamical varables */
REAL8 dvalues[], /**< time derivative of dynamical variables */
void *funcParams /**< EOB parameters */
)
{
static const REAL8 STEP_SIZE = 1.0e-4;
static const INT4 lMax = 8;
HcapDerivParams params;
/* Since we take numerical derivatives wrt dynamical variables */
/* but we want them wrt time, we use this temporary vector in */
/* the conversion */
REAL8 tmpDValues[6];
/* Cartesian values for calculating the Hamiltonian */
REAL8 cartValues[6];
REAL8 H; //Hamiltonian
REAL8 flux;
gsl_function F;
INT4 gslStatus;
UINT4 SpinAlignedEOBversion;
UINT4 i;
REAL8Vector rVec, pVec;
REAL8 rData[3], pData[3];
/* We need r, phi, pr, pPhi to calculate the flux */
REAL8 r;
REAL8Vector polarDynamics;
REAL8 polData[4];
REAL8 mass1, mass2, eta;
/* Spins */
REAL8Vector *s1Vec = NULL;
REAL8Vector *s2Vec = NULL;
REAL8Vector *sKerr = NULL;
REAL8Vector *sStar = NULL;
REAL8 a;
REAL8 omega;
/* EOB potential functions */
REAL8 DeltaT, DeltaR;
REAL8 csi;
/* The error in a derivative as measured by GSL */
REAL8 absErr;
/* Declare NQC coefficients */
EOBNonQCCoeffs *nqcCoeffs = NULL;
/* Set up pointers for GSL */
params.values = cartValues;
params.params = (SpinEOBParams *)funcParams;
nqcCoeffs = params.params->nqcCoeffs;
s1Vec = params.params->s1Vec;
s2Vec = params.params->s2Vec;
sKerr = params.params->sigmaKerr;
sStar = params.params->sigmaStar;
F.function = &GSLSpinAlignedHamiltonianWrapper;
F.params = ¶ms;
mass1 = params.params->eobParams->m1;
mass2 = params.params->eobParams->m2;
eta = params.params->eobParams->eta;
SpinAlignedEOBversion = params.params->seobCoeffs->SpinAlignedEOBversion;
r = values[0];
/* Since this is spin aligned, I make the assumption */
/* that the spin vector is along the z-axis. */
a = sKerr->data[2];
/* Calculate the potential functions and the tortoise coordinate factor csi,
given by Eq. 28 of Pan et al. PRD 81, 084041 (2010) */
DeltaT = XLALSimIMRSpinEOBHamiltonianDeltaT( params.params->seobCoeffs, r, eta, a );
DeltaR = XLALSimIMRSpinEOBHamiltonianDeltaR( params.params->seobCoeffs, r, eta, a );
csi = sqrt( DeltaT * DeltaR ) / (r*r + a*a);
//printf("DeltaT = %.16e, DeltaR = %.16e, a = %.16e\n",DeltaT,DeltaR,a);
//printf( "csi in derivatives function = %.16e\n", csi );
/* Populate the Cartesian values vector, using polar coordinate values */
/* We can assume phi is zero wlog */
memset( cartValues, 0, sizeof( cartValues ) );
cartValues[0] = values[0];
cartValues[3] = values[2];
cartValues[4] = values[3] / values[0];
/* Now calculate derivatives w.r.t. each Cartesian variable */
for ( i = 0; i < 6; i++ )
{
params.varyParam = i;
XLAL_CALLGSL( gslStatus = gsl_deriv_central( &F, cartValues[i],
STEP_SIZE, &tmpDValues[i], &absErr ) );
if ( gslStatus != GSL_SUCCESS )
{
XLALPrintError( "XLAL Error - %s: Failure in GSL function\n", __func__ );
XLAL_ERROR( XLAL_EFUNC );
}
}
/* Calculate the Cartesian vectors rVec and pVec */
polarDynamics.length = 4;
polarDynamics.data = polData;
memcpy( polData, values, sizeof( polData ) );
rVec.length = pVec.length = 3;
rVec.data = rData;
pVec.data = pData;
memset( rData, 0, sizeof(rData) );
memset( pData, 0, sizeof(pData) );
rData[0] = values[0];
pData[0] = values[2];
pData[1] = values[3] / values[0];
/* Calculate Hamiltonian using Cartesian vectors rVec and pVec */
H = XLALSimIMRSpinEOBHamiltonian( eta, &rVec, &pVec, s1Vec, s2Vec, sKerr, sStar, params.params->tortoise, params.params->seobCoeffs );
//printf( "csi = %.16e, ham = %.16e ( tortoise = %d)\n", csi, H, params.params->tortoise );
//exit(1);
//if ( values[0] > 1.3 && values[0] < 3.9 ) printf( "r = %e\n", values[0] );
//if ( values[0] > 1.3 && values[0] < 3.9 ) printf( "Hamiltonian = %e\n", H );
H = H * (mass1 + mass2);
/*if ( values[0] > 1.3 && values[0] < 3.9 ) printf( "Cartesian derivatives:\n%f %f %f %f %f %f\n",
tmpDValues[3], tmpDValues[4], tmpDValues[5], -tmpDValues[0], -tmpDValues[1], -tmpDValues[2] );*/
/* Now calculate omega, and hence the flux */
omega = tmpDValues[4] / r;
flux = XLALInspiralSpinFactorizedFlux( &polarDynamics, nqcCoeffs, omega, params.params, H/(mass1+mass2), lMax, SpinAlignedEOBversion );
/* Looking at the non-spinning model, I think we need to divide the flux by eta */
flux = flux / eta;
//printf( "Flux in derivatives function = %.16e\n", flux );
/* Now we can calculate the final (spherical) derivatives */
/* csi is needed because we use the tortoise co-ordinate */
/* Right hand side of Eqs. 10a - 10d of Pan et al. PRD 84, 124052 (2011) */
dvalues[0] = csi * tmpDValues[3];
dvalues[1] = omega;
/* Note: in this special coordinate setting, namely y = z = 0, dpr/dt = dpx/dt + dy/dt * py/r, where py = pphi/r */
dvalues[2] = - tmpDValues[0] + tmpDValues[4] * values[3] / (r*r);
dvalues[2] = dvalues[2] * csi - ( values[2] / values[3] ) * flux / omega;
dvalues[3] = - flux / omega;
//if ( values[0] > 1.3 && values[0] < 3.9 ) printf("Values:\n%f %f %f %f\n", values[0], values[1], values[2], values[3] );
//if ( values[0] > 1.3 && values[0] < 3.9 ) printf("Derivatives:\n%f %f %f %f\n", dvalues[0], r*dvalues[1], dvalues[2], dvalues[3] );
if ( isnan( dvalues[0] ) || isnan( dvalues[1] ) || isnan( dvalues[2] ) || isnan( dvalues[3] ) )
{
//printf( "Deriv is nan: %e %e %e %e\n", dvalues[0], dvalues[1], dvalues[2], dvalues[3] );
return 1;
}
return XLAL_SUCCESS;
}
int setDf(const gsl_vector * x, void* /*params*/, gsl_matrix * df)
{
ParsedFunction<float> f0 = (*equation);
f0(0);
if (diffEquations != NULL)
{
String constants="";
// replace all constants by their current values
for (unsigned int i = 0; i < (f0.constants_.size()-1)/2; i++)
{
constants = constants+"b"+String(i)+"="+String(gsl_vector_get(x, i))+";";
}
for (int i = 0; i < fitX->rows(); i++) // for each substance...
{
String var="";
// replace all x-variables for the current substance
for (int j = 0; j < fitX->cols(); j++)
{
var = var+"x"+String(j)+"="+String((*fitX)(i, j))+";";
}
String y="";
// replacements for y_i
for (int j = 0; j < fitY->cols(); j++)
{
y = y+"y"+String(j)+"="+String((*fitY)(i, j))+";";
}
// evaluate all differential derivatives for current substance
for (int j = 0; j < fitX->cols(); j++)
{
ParsedFunction < double > f1 = constants+var+y+(*diffEquations)[j];
double dfi = f1(0);
gsl_matrix_set (df, i, j, dfi); // set value of part. der. of current substance
}
}
return GSL_SUCCESS;
}
else /** use numerical derivation if no derivatives are specified: */
{
gsl_function F;
F.function = &getFunctionValue;
F.params = 0;
for (int i = 0; i < fitX->rows(); i++) // for all substances...
{
String y="";
// replacements for y_i
for (int j = 0; j < fitY->cols(); j++)
{
y = y+"y"+String(j)+"="+String((*fitY)(i, j))+";";
}
String var="";
for (int j = 0; j < fitX->cols(); j++)
{
var = var+"x"+String(j)+"="+String((*fitX)(i, j))+";";
}
// evaluate all differential equations for current substance
for (int j = 0; j < fitX->cols(); j++)
{
String coeff="";
for (int k = 0; k < fitX->cols(); k++)
{
if (k != j)
{
coeff = coeff+"b"+String(k)+"="+String(gsl_vector_get(x, k))+";";
}
else
{
coeff = coeff+"b"+String(k)+"="+"X;";
}
}
String es = coeff+var+y+"("+(*equation);
es = es.getSubstring(0, es.size()-1);
es = es + ")^2-y"+String(c)+";";
f = new ParsedFunction<double>(es);
double dfi; double abserr;
gsl_deriv_central (&F, (*fitX)(i, j), 1e-8, &dfi, &abserr); // finds value of \delta f / \delta x_j
if (i == 5) {cout<<"f(0) = "<<(*f)(0)<<endl;
cout<<es<<" "<<dfi<<endl;}
gsl_matrix_set (df, i, j, dfi);
delete f;
}
}
return GSL_SUCCESS;
}
}
void
test_elliss_deriv (enum se_type spkind,
size_t _nb, const cmpl ns[], double phi0,
const double ds[], double lambda,
double anlz)
{
gsl_vector *jacob_th;
cmpl_vector *jacob_n;
struct aux_param p[1];
size_t j, nb = _nb;
size_t nblyr = nb - 2;
double *myds;
cmpl *myns;
ell_ab_t e;
size_t noff;
#define TEST_CHANNEL 1
printf ("LAMBDA: %f\n", lambda);
jacob_th = gsl_vector_alloc (2 * nblyr);
jacob_n = cmpl_vector_alloc (2 * nb);
myds = emalloc (nblyr * sizeof(double));
myns = emalloc (nb * sizeof(cmpl));
mult_layer_se_jacob (spkind, nb, ns, phi0, ds, lambda, anlz,
e, jacob_th, jacob_n);
p->nb = nb;
p->spkind = spkind;
p->lambda = lambda;
p->phi0 = phi0;
p->anlz = anlz;
p->ds = myds;
p->ns = myns;
p->thickness = 1;
p->channel = TEST_CHANNEL;
noff = (p->channel == 0 ? 0 : nblyr);
for (j = 1; j < nb - 1; j++)
{
gsl_function F;
double result, abserr;
p->layer = j;
F.function = & der_aux_f;
F.params = p;
memcpy (myds, ds, nblyr * sizeof(double));
memcpy (myns, ns, nb * sizeof(cmpl));
gsl_deriv_central (&F, ds[j-1], 1e-8, &result, &abserr);
printf ("TH layer: %2i, numeric: %.6f, calcul.: %.6f, err: %f\n", j,
result, gsl_vector_get (jacob_th, noff+j-1), abserr);
}
p->thickness = 0;
p->channel = TEST_CHANNEL;
noff = (p->channel == 0 ? 0 : nb);
for (j = 0; j < nb; j++)
{
gsl_function F;
double result, abserr;
p->layer = j;
F.function = & der_aux_f;
F.params = p;
memcpy (myds, ds, nblyr * sizeof(double));
memcpy (myns, ns, nb * sizeof(cmpl));
p->real_part = 1;
gsl_deriv_central (&F, creal(ns[j]), 1e-8, &result, &abserr);
printf ("Re{n} layer: %2i, numeric: %.6f, calcul.: %.6f, err: %f\n", j,
result, creal(cmpl_vector_get (jacob_n, noff+j)), abserr);
p->real_part = 0;
gsl_deriv_central (&F, cimag(ns[j]), 1e-8, &result, &abserr);
printf ("Im{n} layer: %2i, numeric: %.6f, calcul.: %.6f, err: %f\n", j,
result, -cimag(cmpl_vector_get (jacob_n, noff+j)), abserr);
}
free (myds), free (myns);
gsl_vector_free (jacob_th);
cmpl_vector_free (jacob_n);
}
