Ejemplo n.º 1
0
/** *************************************************************************************
*****************************************************************************************
*****************************************************************************************/ 
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");*/
}
Ejemplo n.º 2
0
// 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);
	}
}
Ejemplo n.º 3
0
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;
		}
}
Ejemplo n.º 4
0
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 = &params;

    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);
}
Ejemplo n.º 5
0
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;
}
Ejemplo n.º 6
0
/*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 = &nu;
  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;
}
Ejemplo n.º 8
0
//----------------------------------------------------------------------------
int dif2p(REAL x,REAL alpha,REAL (*fp)(REAL,void*),REAL * result,REAL * abserr){

	gsl_function F;
	F.function = fp;
	F.params = &alpha;

 	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;
}
Ejemplo n.º 9
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;
}
Ejemplo n.º 10
0
//----------------------------------------------------------------------------
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 = &alpha;
	
 	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;
}
Ejemplo n.º 11
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;
  }
  
 
  
}
Ejemplo n.º 12
0
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;
}
Ejemplo n.º 13
0
/** *************************************************************************************************************************/
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);
}
Ejemplo n.º 14
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   = &params;

  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;
}
Ejemplo n.º 16
0
Archivo: fitModel.C Proyecto: anhi/ball
		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;
			}
		}
Ejemplo n.º 17
0
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);
}