int sp_num_alloc(sp_num** N, int n, ErrorMsg error_message){
int maxnz, k;
class_alloc((*N),sizeof(sp_num),error_message);
printf("calling spnumalloc");
maxnz = n*(n+1);
maxnz /=2;
(*N)->n = n;
class_call(sp_mat_alloc(&((*N)->L), n, n, maxnz, error_message),
error_message,error_message);
class_call(sp_mat_alloc(&((*N)->U), n, n, maxnz, error_message),
error_message,error_message);
class_alloc((*N)->xi,n*sizeof(int*),error_message);
/* I really want xi to be a vector of pointers to vectors. */
class_alloc((*N)->xi[0],n*n*sizeof(int),error_message);
for (k=1;k<n;k++) (*N)->xi[k] = (*N)->xi[k-1]+n;
/*Assign pointers to rows.*/
class_alloc((*N)->topvec,n*sizeof(int),error_message);
class_alloc((*N)->pinv,n*sizeof(int),error_message);
class_alloc((*N)->p,n*sizeof(int),error_message);
/* Has to be n+1 because sp_amd uses it for storage:*/
class_alloc((*N)->q,(n+1)*sizeof(int),error_message);
class_alloc((*N)->w,n*sizeof(double),error_message);
class_alloc((*N)->wamd,(8*(n+1))*sizeof(int),error_message);
return _SUCCESS_;
}
int sp_mat_alloc(sp_mat** A, int ncols, int nrows, int maxnz, ErrorMsg error_message){
int ncp = ncols+1;
printf("calling spmatalloc");
class_alloc((*A),sizeof(sp_mat),error_message);
class_alloc((*A)->Ax,maxnz*sizeof(double),error_message);
class_alloc((*A)->Ai,maxnz*sizeof(int),error_message);
class_alloc((*A)->Ap,(ncp*sizeof(int)),error_message);
(*A)->ncols = ncols;
(*A)->nrows = nrows;
(*A)->maxnz = maxnz;
return _SUCCESS_;
}
int parser_init(
struct file_content * pfc,
int size,
ErrorMsg errmsg
) {
if (size > 0) {
pfc->size=size;
class_alloc(pfc->name,size*sizeof(FileArg),errmsg);
class_alloc(pfc->value,size*sizeof(FileArg),errmsg);
class_alloc(pfc->read,size*sizeof(short),errmsg);
}
return _SUCCESS_;
}
VALUE
rb_include_class_new(VALUE module, VALUE super)
{
VALUE klass = class_alloc(T_ICLASS, rb_cClass);
if (BUILTIN_TYPE(module) == T_ICLASS) {
module = RBASIC(module)->klass;
}
if (!RCLASS_IV_TBL(module)) {
RCLASS_IV_TBL(module) = st_init_numtable();
}
if (!RCLASS_CONST_TBL(module)) {
RCLASS_CONST_TBL(module) = st_init_numtable();
}
RCLASS_IV_TBL(klass) = RCLASS_IV_TBL(module);
RCLASS_CONST_TBL(klass) = RCLASS_CONST_TBL(module);
RCLASS_M_TBL_WRAPPER(OBJ_WB_UNPROTECT(klass)) =
RCLASS_M_TBL_WRAPPER(OBJ_WB_UNPROTECT(RCLASS_ORIGIN(module)));
RCLASS_SET_SUPER(klass, super);
if (RB_TYPE_P(module, T_ICLASS)) {
RBASIC_SET_CLASS(klass, RBASIC(module)->klass);
}
else {
RBASIC_SET_CLASS(klass, module);
}
OBJ_INFECT(klass, module);
OBJ_INFECT(klass, super);
return (VALUE)klass;
}
void
rb_prepend_module(VALUE klass, VALUE module)
{
void rb_vm_check_redefinition_by_prepend(VALUE klass);
VALUE origin;
int changed = 0;
rb_frozen_class_p(klass);
Check_Type(module, T_MODULE);
OBJ_INFECT(klass, module);
origin = RCLASS_ORIGIN(klass);
if (origin == klass) {
origin = class_alloc(T_ICLASS, klass);
OBJ_WB_UNPROTECT(origin); /* TODO: conservertive shading. Need more survery. */
RCLASS_SET_SUPER(origin, RCLASS_SUPER(klass));
RCLASS_SET_SUPER(klass, origin);
RCLASS_ORIGIN(klass) = origin;
RCLASS_M_TBL_WRAPPER(origin) = RCLASS_M_TBL_WRAPPER(klass);
RCLASS_M_TBL_INIT(klass);
st_foreach(RCLASS_M_TBL(origin), move_refined_method,
(st_data_t) RCLASS_M_TBL(klass));
}
changed = include_modules_at(klass, klass, module);
if (changed < 0)
rb_raise(rb_eArgError, "cyclic prepend detected");
if (changed) {
rb_vm_check_redefinition_by_prepend(klass);
}
}
static void add_module(VALUE self, VALUE module)
{
VALUE super = RCLASS_SUPER(rb_singleton_class(self));
#ifdef RUBY_19
VALUE klass = class_alloc(T_ICLASS, rb_cClass);
#else
NEWOBJ(klass, struct RClass);
OBJSETUP(klass, rb_cClass, T_ICLASS);
#endif
if (BUILTIN_TYPE(module) == T_ICLASS) {
module = KLASS_OF(module);
}
if (!RCLASS_IV_TBL(module)) {
RCLASS_IV_TBL(module) = (void*)st_init_numtable();
}
RCLASS_IV_TBL(klass) = RCLASS_IV_TBL(module);
RCLASS_M_TBL(klass) = RCLASS_M_TBL(module);
RCLASS_SUPER(klass) = super;
if (TYPE(module) == T_ICLASS) {
KLASS_OF(klass) = KLASS_OF(module);
} else {
KLASS_OF(klass) = module;
}
OBJ_INFECT(klass, module);
OBJ_INFECT(klass, super);
RCLASS_SUPER(rb_singleton_class(self)) = (VALUE)klass;
}
VALUE
rb_singleton_class_clone(VALUE obj)
{
VALUE klass = RBASIC(obj)->klass;
if (!FL_TEST(klass, FL_SINGLETON))
return klass;
else {
struct clone_method_data data;
/* copy singleton(unnamed) class */
VALUE clone = class_alloc(RBASIC(klass)->flags, 0);
if (BUILTIN_TYPE(obj) == T_CLASS) {
RBASIC(clone)->klass = (VALUE)clone;
}
else {
RBASIC(clone)->klass = rb_singleton_class_clone(klass);
}
RCLASS_SUPER(clone) = RCLASS_SUPER(klass);
if (RCLASS_IV_TBL(klass)) {
RCLASS_IV_TBL(clone) = st_copy(RCLASS_IV_TBL(klass));
}
RCLASS_M_TBL(clone) = st_init_numtable();
data.tbl = RCLASS_M_TBL(clone);
data.klass = (VALUE)clone;
st_foreach(RCLASS_M_TBL(klass), clone_method,
(st_data_t)&data);
rb_singleton_class_attached(RBASIC(clone)->klass, (VALUE)clone);
FL_SET(clone, FL_SINGLETON);
return (VALUE)clone;
}
}
static VALUE
include_class_new(VALUE module, VALUE super)
{
VALUE klass = class_alloc(T_ICLASS, rb_cClass);
if (BUILTIN_TYPE(module) == T_ICLASS) {
module = RBASIC(module)->klass;
}
if (!RCLASS_IV_TBL(module)) {
RCLASS_IV_TBL(module) = st_init_numtable();
}
RCLASS_IV_TBL(klass) = RCLASS_IV_TBL(module);
RCLASS_M_TBL(klass) = RCLASS_M_TBL(module);
RCLASS_SUPER(klass) = super;
if (TYPE(module) == T_ICLASS) {
RBASIC(klass)->klass = RBASIC(module)->klass;
}
else {
RBASIC(klass)->klass = module;
}
OBJ_INFECT(klass, module);
OBJ_INFECT(klass, super);
return (VALUE)klass;
}
void
rb_prepend_module(VALUE klass, VALUE module)
{
void rb_vm_check_redefinition_by_prepend(VALUE klass);
VALUE origin;
int changed = 0;
rb_frozen_class_p(klass);
Check_Type(module, T_MODULE);
OBJ_INFECT(klass, module);
origin = RCLASS_ORIGIN(klass);
if (origin == klass) {
origin = class_alloc(T_ICLASS, klass);
RCLASS_SET_SUPER(origin, RCLASS_SUPER(klass));
RCLASS_SET_SUPER(klass, origin);
RCLASS_ORIGIN(klass) = origin;
RCLASS_M_TBL(origin) = RCLASS_M_TBL(klass);
RCLASS_M_TBL(klass) = st_init_numtable();
st_foreach(RCLASS_M_TBL(origin), move_refined_method,
(st_data_t) RCLASS_M_TBL(klass));
}
changed = include_modules_at(klass, klass, module);
if (changed < 0)
rb_raise(rb_eArgError, "cyclic prepend detected");
if (changed) {
rb_clear_cache();
rb_vm_check_redefinition_by_prepend(klass);
}
}
VALUE
rb_module_new(void)
{
VALUE mdl = class_alloc(T_MODULE, rb_cModule);
RCLASS_M_TBL_INIT(mdl);
return (VALUE)mdl;
}
VALUE
rb_module_new(void)
{
VALUE mdl = class_alloc(T_MODULE, rb_cModule);
RCLASS_M_TBL(mdl) = st_init_numtable();
return (VALUE)mdl;
}
/*!
* A utility function that wraps class_alloc.
*
* allocates a class and initializes safely.
* \param super a class from which the new class derives.
* \return a class object.
* \pre \a super must be a class.
* \post the metaclass of the new class is Class.
*/
VALUE
rb_class_boot(VALUE super)
{
VALUE klass = class_alloc(T_CLASS, rb_cClass);
RCLASS_SET_SUPER(klass, super);
RCLASS_M_TBL_INIT(klass);
OBJ_INFECT(klass, super);
return (VALUE)klass;
}
/*!
* A utility function that wraps class_alloc.
*
* allocates a class and initializes safely.
* \param super a class from which the new class derives.
* \return a class object.
* \pre \a super must be a class.
* \post the metaclass of the new class is Class.
*/
VALUE
rb_class_boot(VALUE super)
{
VALUE klass = class_alloc(T_CLASS, rb_cClass);
RCLASS_SUPER(klass) = super;
RCLASS_M_TBL(klass) = st_init_numtable();
OBJ_INFECT(klass, super);
return (VALUE)klass;
}
int parser_read_file(
char * filename,
struct file_content * pfc,
ErrorMsg errmsg
){
FILE * inputfile;
char line[_LINE_LENGTH_MAX_];
int counter;
int is_data;
FileArg name;
FileArg value;
class_open(inputfile,filename,"r",errmsg);
counter = 0;
while (fgets(line,_LINE_LENGTH_MAX_,inputfile) != NULL) {
class_call(parser_read_line(line,&is_data,name,value,errmsg),errmsg,errmsg);
if (is_data == _TRUE_) counter++;
}
class_test(counter == 0,
errmsg,
"No readable input in file %s",filename);
class_alloc(pfc->filename,(strlen(filename)+1)*sizeof(char),errmsg);
strcpy(pfc->filename,filename);
class_call(parser_init(pfc,counter,errmsg),
errmsg,
errmsg);
rewind(inputfile);
counter = 0;
while (fgets(line,_LINE_LENGTH_MAX_,inputfile) != NULL) {
class_call(parser_read_line(line,&is_data,name,value,errmsg),errmsg,errmsg);
if (is_data == _TRUE_) {
strcpy(pfc->name[counter],name);
strcpy(pfc->value[counter],value);
pfc->read[counter]=_FALSE_;
counter++;
}
}
fclose(inputfile);
return _SUCCESS_;
}
/* a modified version of include_class_new from class.c */
static VALUE
j_class_new(VALUE module, VALUE sup)
{
#ifdef RUBY_19
VALUE klass = class_alloc(T_ICLASS, rb_cClass);
#else
NEWOBJ(klass, struct RClass);
OBJSETUP(klass, rb_cClass, T_ICLASS);
#endif
if (BUILTIN_TYPE(module) == T_ICLASS) {
module = KLASS_OF(module);
}
if (!RCLASS_IV_TBL(module)) {
RCLASS_IV_TBL(module) = (struct st_table *)st_init_numtable();
}
/* assign iv_tbl, m_tbl and super */
RCLASS_IV_TBL(klass) = RCLASS_IV_TBL(module);
RCLASS_SUPER(klass) = sup;
if(TYPE(module) != T_OBJECT) {
RCLASS_M_TBL(klass) = RCLASS_M_TBL(module);
}
else {
RCLASS_M_TBL(klass) = RCLASS_M_TBL(CLASS_OF(module));
}
/* */
if (TYPE(module) == T_ICLASS) {
KLASS_OF(klass) = KLASS_OF(module);
}
else {
KLASS_OF(klass) = module;
}
if(TYPE(module) != T_OBJECT) {
OBJ_INFECT(klass, module);
OBJ_INFECT(klass, sup);
}
return (VALUE)klass;
}
int parser_cat(
struct file_content * pfc1,
struct file_content * pfc2,
struct file_content * pfc3,
ErrorMsg errmsg
) {
int i;
class_test(pfc1->size < 0.,
errmsg,
"size of file_content structure probably not initialized properly\n");
class_test(pfc2->size < 0.,
errmsg,
"size of file_content structure probably not initialized properly\n");
if (pfc1->size == 0) {
class_alloc(pfc3->filename,(strlen(pfc2->filename)+1)*sizeof(char),errmsg);
sprintf(pfc3->filename,"%s",pfc2->filename);
}
if (pfc2->size == 0) {
class_alloc(pfc3->filename,(strlen(pfc1->filename)+1)*sizeof(char),errmsg);
sprintf(pfc3->filename,"%s",pfc1->filename);
}
if ((pfc1->size !=0) && (pfc2->size != 0)) {
class_alloc(pfc3->filename,(strlen(pfc1->filename)+strlen(pfc2->filename)+5)*sizeof(char),errmsg);
sprintf(pfc3->filename,"%s or %s",pfc1->filename,pfc2->filename);
}
pfc3->size = pfc1->size + pfc2->size;
class_alloc(pfc3->value,pfc3->size*sizeof(FileArg),errmsg);
class_alloc(pfc3->name,pfc3->size*sizeof(FileArg),errmsg);
class_alloc(pfc3->read,pfc3->size*sizeof(short),errmsg);
for (i=0; i < pfc1->size; i++) {
strcpy(pfc3->value[i],pfc1->value[i]);
strcpy(pfc3->name[i],pfc1->name[i]);
pfc3->read[i]=pfc1->read[i];
}
for (i=0; i < pfc2->size; i++) {
strcpy(pfc3->value[i+pfc1->size],pfc2->value[i]);
strcpy(pfc3->name[i+pfc1->size],pfc2->name[i]);
pfc3->read[i+pfc1->size]=pfc2->read[i];
}
return _SUCCESS_;
}
VALUE
rb_singleton_class_clone_and_attach(VALUE obj, VALUE attach)
{
VALUE klass = RBASIC(obj)->klass;
if (!FL_TEST(klass, FL_SINGLETON))
return klass;
else {
/* copy singleton(unnamed) class */
VALUE clone = class_alloc(RBASIC(klass)->flags, 0);
if (BUILTIN_TYPE(obj) == T_CLASS) {
RBASIC_SET_CLASS(clone, clone);
}
else {
RBASIC_SET_CLASS(clone, rb_singleton_class_clone(klass));
}
RCLASS_SET_SUPER(clone, RCLASS_SUPER(klass));
RCLASS_EXT(clone)->allocator = RCLASS_EXT(klass)->allocator;
if (RCLASS_IV_TBL(klass)) {
RCLASS_IV_TBL(clone) = rb_st_copy(clone, RCLASS_IV_TBL(klass));
}
if (RCLASS_CONST_TBL(klass)) {
struct clone_const_arg arg;
RCLASS_CONST_TBL(clone) = st_init_numtable();
arg.klass = clone;
arg.tbl = RCLASS_CONST_TBL(clone);
st_foreach(RCLASS_CONST_TBL(klass), clone_const_i, (st_data_t)&arg);
}
if (attach != Qundef) {
rb_singleton_class_attached(clone, attach);
}
RCLASS_M_TBL_INIT(clone);
st_foreach(RCLASS_M_TBL(klass), clone_method_i, (st_data_t)clone);
rb_singleton_class_attached(RBASIC(clone)->klass, clone);
FL_SET(clone, FL_SINGLETON);
return clone;
}
}
/**
* Forces loading of the super class (or the implemented interfaces) of the
* class being instrumented. For this, we need to parse the constant pool
* of the class to discover the names of the classes to be force-loaded.
* We then use JNI to find the classes, which will force their loading.
*/
static void
__force_classes (
JNIEnv * jni, const char * class_name,
const unsigned char * class_bytes, jint class_byte_count
) {
assert (jni != NULL & jvm_is_started);
class_t inst_class = class_alloc (class_bytes, class_byte_count);
if (inst_class != NULL) {
if (agent_config.force_superclass) {
__force_superclass (jni, inst_class);
}
if (agent_config.force_interfaces) {
__force_interfaces (jni, inst_class);
}
class_free (inst_class);
} else {
warn ("failed to parse class %s\n", __safe (class_name));
}
}
int main(int argc, char **argv) {
struct precision pr; /* for precision parameters */
struct background ba; /* for cosmological background */
struct thermo th; /* for thermodynamics */
struct perturbs pt; /* for source functions */
struct bessels bs; /* for bessel functions */
struct transfers tr; /* for transfer functions */
struct primordial pm; /* for primordial spectra */
struct spectra sp; /* for output spectra */
struct lensing le; /* for lensed spectra */
struct output op; /* for output files */
struct spectra_nl nl; /* for calculation of non-linear spectra */
ErrorMsg errmsg;
int i,l_max,l;
struct file_content fc;
double parameter_initial,parameter_logstep;
double * parameter;
int param_num;
double *** cl;
double ** noise;
double chi2,chi2_bis;
double percentage,max_percentage;
int max_l;
int ref_run;
l_max=2500;
parser_init(&fc,4,errmsg);
strcpy(fc.name[0],"output");
strcpy(fc.value[0],"tCl,pCl");
strcpy(fc.name[1],"l_max_scalars");
sprintf(fc.value[1],"%d",l_max);
/* strcpy(fc.name[2],"perturbations_verbose"); */
/* sprintf(fc.value[2],"%d",2); */
/*******************************************************/
strcpy(fc.name[2],"lensing");
strcpy(fc.value[2],"no");
strcpy(fc.name[3],"transfer_cut_threshold_cl");
parameter_initial=1.e-7;
parameter_logstep=1.3;
param_num=30;
ref_run=0;
/*******************************************************/
class_alloc(cl,param_num*sizeof(double**),errmsg);
class_alloc(parameter,param_num*sizeof(double),errmsg);
for (i=0; i<param_num; i++) {
class_alloc(cl[i],(l_max+1)*sizeof(double*),errmsg);
class_calloc(noise,(l_max+1),sizeof(double*),errmsg);
for (l=2; l <= l_max; l++) {
class_alloc(cl[i][l],3*sizeof(double),errmsg);
class_calloc(noise[l],3,sizeof(double),errmsg);
}
}
for (i=0; i<param_num; i++) {
parameter[i] = parameter_initial * exp((double)i*log(parameter_logstep));
/* parameter[i] = parameter_initial -i; */
/* if (i==0) { */
/* sprintf(fc.value[2],"%d",tc_osc); */
/* strcpy(fc.name[3],"transfer_cut_threshold_osc"); */
/* sprintf(fc.value[3],"%g",0.013); */
/* } */
/* else { */
/* sprintf(fc.value[2],"%d",tc_cl); */
/* strcpy(fc.name[3],"transfer_cut_threshold_cl"); */
/* sprintf(fc.value[3],"%g",8.e-7); */
/* } */
/* sprintf(fc.value[2],"%g",parameter[i]); */
sprintf(fc.value[3],"%g",parameter[i]);
/* sprintf(fc.value[3],"%d",(int)parameter[i]); */
/* sprintf(fc.value[2],"%d",1); */
fprintf(stderr,"#run %d/%d with %s\n",i+1,param_num,fc.value[3]);
if (input_init(&fc,&pr,&ba,&th,&pt,&bs,&tr,&pm,&sp,&le,&op,&nl,errmsg) == _FAILURE_) {
printf("\n\nError running input_init_from_arguments \n=>%s\n",errmsg);
return _FAILURE_;
}
if (i==0) {
if (bessel_init(&pr,&bs) == _FAILURE_) {
printf("\n\nError in bessel_init \n =>%s\n",bs.error_message);
return _FAILURE_;
}
}
/* class(&pr,&ba,&th,&pt,&bs,&tr,&pm,&sp,&le,&op,l_max,cl[i],errmsg); */
class_assuming_bessels_computed(&pr,&ba,&th,&pt,&bs,&tr,&pm,&sp,&le,&op,l_max,cl[i],errmsg);
/* for (l=2; l <= 2500; l++) */
/* printf("%d %e %e %e\n",l, */
/* (l*(l+1)/2./_PI_)*cl[i][l][0], */ /* here cl is the dimensionless C_l */
/* (l*(l+1)/2./_PI_)*cl[i][l][1], */ /* multiply by pow((th.Tcmb*1.e6),2) for muK */
/* (l*(l+1)/2./_PI_)*cl[i][l][2]); */
/* printf("\n"); */
}
if (bessel_free(&bs) == _FAILURE_) {
printf("\n\nError in bessel_free \n=>%s\n",bs.error_message);
return _FAILURE_;
}
/* for (i=0; i<param_num-1; i++) { */
/* chi2=0; */
/* max_percentage = 0.; */
/* max_l = 0; */
/* for (l=2; l <= 2500; l++) { */
/* chi2 += pow(((cl[i][l][0]-cl[param_num-1][l][0])/cl[param_num-1][l][0]),2); */
/* percentage = fabs(cl[i][l][0]/cl[param_num-1][l][0]-1.)*100.; */
/* if (percentage > max_percentage) { */
/* max_percentage = percentage; */
/* max_l = l; */
/* } */
/* } */
/* chi2_simple(cl[i],cl[param_num-1],2500,&chi2_bis); */
/* fprintf(stderr,"parameter=%e chi2=%e (%e) l=%d percentage=%g\n", */
/* parameter[i],chi2,chi2_bis,max_l,max_percentage); */
/* } */
noise_planck(&ba,&th,&sp,noise,l_max);
/* for (l=2;l<=l_max;l++) { */
/* printf("%d %e %e %e %e %e %e\n",l, */
/* (l*(l+1)/2./_PI_)*cl[0][l][0]*pow(th.Tcmb*1.e6,2), */
/* (l*(l+1)/2./_PI_)*cl[0][l][1]*pow(th.Tcmb*1.e6,2), */
/* (l*(l+1)/2./_PI_)*cl[0][l][2]*pow(th.Tcmb*1.e6,2), */
/* (l*(l+1)/2./_PI_)*noise[l][0]*pow(th.Tcmb*1.e6,2), */
/* (l*(l+1)/2./_PI_)*noise[l][1]*pow(th.Tcmb*1.e6,2), */
/* (l*(l+1)/2./_PI_)*noise[l][2]*pow(th.Tcmb*1.e6,2)); */
/* } */
for (i=0; i<param_num; i++) {
chi2_planck(&sp,cl[i],cl[ref_run],noise,l_max,&chi2);
if (chi2>0.1) {
fprintf(stderr,"parameter=%e BAD: chi2=%2g \n",
parameter[i],chi2);
}
else {
fprintf(stderr,"parameter=%e OK : chi2=%e \n",
parameter[i],chi2);
}
}
return _SUCCESS_;
}
int fzero_Newton(int (*func)(double *x,
int x_size,
void *param,
double *F,
ErrorMsg error_message),
double *x_inout,
double *dxdF,
int x_size,
double tolx,
double tolF,
void *param,
int *fevals,
ErrorMsg error_message){
/**Given an initial guess x[1..n] for a root in n dimensions,
take ntrial Newton-Raphson steps to improve the root.
Stop if the root converges in either summed absolute
variable increments tolx or summed absolute function values tolf.*/
int k,i,j,*indx, ntrial=20;
double errx,errf,d,*F0,*Fdel,**Fjac,*p, *lu_work;
int has_converged = _FALSE_;
double toljac = 1e-3;
double *delx;
/** All arrays are indexed as [0, n-1] with the exception of p, indx,
lu_work and Fjac, since they are passed to ludcmp and lubksb. */
class_alloc(indx, sizeof(int)*(x_size+1), error_message);
class_alloc(p, sizeof(double)*(x_size+1), error_message);
class_alloc(lu_work, sizeof(double)*(x_size+1), error_message);
class_alloc(Fjac, sizeof(double *)*(x_size+1), error_message);
Fjac[0] = NULL;
class_alloc(Fjac[1], sizeof(double)*(x_size*x_size+1), error_message);
for (i=2; i<=x_size; i++){
Fjac[i] = Fjac[i-1] + x_size;
}
class_alloc(F0, sizeof(double)*x_size, error_message);
class_alloc(delx, sizeof(double)*x_size, error_message);
class_alloc(Fdel, sizeof(double)*x_size, error_message);
for (i=1; i<=x_size; i++){
delx[i-1] = toljac*dxdF[i-1];
}
for (k=1;k<=ntrial;k++) {
/** Compute F(x): */
/**printf("x = [%f, %f], delx = [%e, %e]\n",
x_inout[0],x_inout[1],delx[0],delx[1]);*/
class_call(func(x_inout, x_size, param, F0, error_message),
error_message, error_message);
/** printf("F0 = [%f, %f]\n",F0[0],F0[1]);*/
*fevals = *fevals + 1;
errf=0.0; //fvec and Jacobian matrix in fjac.
for (i=1; i<=x_size; i++)
errf += fabs(F0[i-1]); //Check function convergence.
if (errf <= tolF){
has_converged = _TRUE_;
break;
}
/**
if (k==1){
for (i=1; i<=x_size; i++){
delx[i-1] *= F0[i-1];
}
}
*/
/** Compute the jacobian of F: */
for (i=1; i<=x_size; i++){
if (F0[i-1]<0.0)
delx[i-1] *= -1;
x_inout[i-1] += delx[i-1];
/** printf("x = [%f, %f], delx = [%e, %e]\n",
x_inout[0],x_inout[1],delx[0],delx[1]);*/
class_call(func(x_inout, x_size, param, Fdel, error_message),
error_message, error_message);
/** printf("F = [%f, %f]\n",Fdel[0],Fdel[1]);*/
for (j=1; j<=x_size; j++)
Fjac[j][i] = (Fdel[j-1]-F0[j-1])/delx[i-1];
x_inout[i-1] -= delx[i-1];
}
*fevals = *fevals + x_size;
for (i=1; i<=x_size; i++)
p[i] = -F0[i-1]; //Right-hand side of linear equations.
ludcmp(Fjac, x_size, indx, &d, lu_work); //Solve linear equations using LU decomposition.
lubksb(Fjac, x_size, indx, p);
errx=0.0; //Check root convergence.
for (i=1; i<=x_size; i++) { //Update solution.
errx += fabs(p[i]);
x_inout[i-1] += p[i];
}
if (errx <= tolx){
has_converged = _TRUE_;
break;
}
}
free(p);
free(lu_work);
free(indx);
free(Fjac[1]);
free(Fjac);
free(F0);
free(delx);
free(Fdel);
if (has_converged == _TRUE_){
return _SUCCESS_;
}
else{
class_stop(error_message, "Newton's method failed to converge. Try improving initial guess on the parameters, decrease the tolerance requirements to Newtons method or increase the precision of the input function.\n");
}
}
int initialize_jacobian(struct jacobian *jac, int neq, ErrorMsg error_message){
int i;
if (neq>15){
jac->use_sparse = 1;
}
else{
jac->use_sparse = 0;
}
jac->max_nonzero = (int)(MAX(3*neq,0.20*neq*neq));
jac->cnzmax = 12*jac->max_nonzero/5;
/*Maximal number of non-zero entries to be considered sparse */
jac->repeated_pattern = 0;
jac->trust_sparse = 4;
/* Number of times a pattern is repeated before we trust it. */
jac->has_grouping = 0;
jac->has_pattern = 0;
jac->sparse_stuff_initialized=0;
/*Setup memory for the pointers of the dense method:*/
class_alloc(jac->dfdy,sizeof(double*)*(neq+1),error_message); /* Allocate vector of pointers to rows of matrix.*/
class_alloc(jac->dfdy[1],sizeof(double)*(neq*neq+1),error_message);
jac->dfdy[0] = NULL;
for(i=2;i<=neq;i++) jac->dfdy[i] = jac->dfdy[i-1]+neq; /* Set row pointers... */
class_alloc(jac->LU,sizeof(double*)*(neq+1),error_message); /* Allocate vector of pointers to rows of matrix.*/
class_alloc(jac->LU[1],sizeof(double)*(neq*neq+1),error_message);
jac->LU[0] = NULL;
for(i=2;i<=neq;i++) jac->LU[i] = jac->LU[i-1]+neq; /* Set row pointers... */
class_alloc(jac->LUw,sizeof(double)*(neq+1),error_message);
class_alloc(jac->jacvec,sizeof(double)*(neq+1),error_message);
class_alloc(jac->luidx,sizeof(int)*(neq+1),error_message);
/*Setup memory for the sparse method, if used: */
if (jac->use_sparse){
jac->sparse_stuff_initialized = 1;
jac->xjac=(double*)(jac->luidx+neq+1);
jac->col_group=(int*)(jac->xjac+jac->max_nonzero);
jac->col_wi=jac->col_group+neq;
jac->Cp=jac->col_wi+neq;
jac->Ci=jac->Cp+neq+1;
class_alloc(jac->xjac,sizeof(double)*jac->max_nonzero,error_message);
class_alloc(jac->col_group,sizeof(int)*neq,error_message);
class_alloc(jac->col_wi,sizeof(int)*neq,error_message);
class_alloc(jac->Cp,sizeof(int)*(neq+1),error_message);
class_alloc(jac->Ci,sizeof(int)*jac->cnzmax,error_message);
class_call(sp_num_alloc(&jac->Numerical, neq,error_message),
error_message,error_message);
class_call(sp_mat_alloc(&jac->spJ, neq, neq, jac->max_nonzero,
error_message),error_message,error_message);
}
/* Initialize jacvec to sqrt(eps):*/
for (i=1;i<=neq;i++) jac->jacvec[i]=1.490116119384765597872e-8;
return _SUCCESS_;
}
int initialize_numjac_workspace(struct numjac_workspace * nj_ws,int neq, ErrorMsg error_message){
int i,neqp=neq+1;
/* Allocate vectors and matrices: */
class_alloc(nj_ws->yscale,sizeof(double)*neqp,error_message);
class_alloc(nj_ws->del,sizeof(double)*neqp,error_message);
class_alloc(nj_ws->Difmax,sizeof(double)*neqp,error_message);
class_alloc(nj_ws->absFdelRm,sizeof(double)*neqp,error_message);
class_alloc(nj_ws->absFvalue,sizeof(double)*neqp,error_message);
class_alloc(nj_ws->absFvalueRm,sizeof(double)*neqp,error_message);
class_alloc(nj_ws->Fscale,sizeof(double)*neqp,error_message);
class_alloc(nj_ws->ffdel,sizeof(double)*neqp,error_message);
class_alloc(nj_ws->yydel,sizeof(double)*neqp,error_message);
class_alloc(nj_ws->tmp,sizeof(double)*neqp,error_message);
class_alloc(nj_ws->ydel_Fdel,sizeof(double*)*(neq+1),error_message); /* Allocate vector of pointers to rows of matrix.*/
class_alloc(nj_ws->ydel_Fdel[1],sizeof(double)*(neq*neq+1),error_message);
nj_ws->ydel_Fdel[0] = NULL;
for(i=2;i<=neq;i++) nj_ws->ydel_Fdel[i] = nj_ws->ydel_Fdel[i-1]+neq; /* Set row pointers... */
class_alloc(nj_ws->logj,sizeof(int)*neqp,error_message);
class_alloc(nj_ws->Rowmax,sizeof(int)*neqp,error_message);
/* Done allocating stuff */
return _SUCCESS_;
}
int evolver_ndf15(
int (*derivs)(double x,double * y,double * dy,
void * parameters_and_workspace, ErrorMsg error_message),
double x_ini,
double x_final,
double * y_inout,
int * used_in_output,
int neq,
void * parameters_and_workspace_for_derivs,
double rtol,
double minimum_variation,
int (*timescale_and_approximation)(double x,
void * parameters_and_workspace,
double * timescales,
ErrorMsg error_message),
double timestep_over_timescale,
double * t_vec,
int tres,
int (*output)(double x,double y[],double dy[],int index_x,void * parameters_and_workspace,
ErrorMsg error_message),
int (*print_variables)(double x, double y[], double dy[], void *parameters_and_workspace,
ErrorMsg error_message),
ErrorMsg error_message){
/* Constants: */
double G[5]={1.0,3.0/2.0,11.0/6.0,25.0/12.0,137.0/60.0};
double alpha[5]={-37.0/200,-1.0/9.0,-8.23e-2,-4.15e-2, 0};
double invGa[5],erconst[5];
double abstol = 1e-18, eps=1e-19, threshold=abstol;
int maxit=4, maxk=5;
/* Logicals: */
int Jcurrent,havrate,done,at_hmin,nofailed,gotynew,tooslow,*interpidx;
/* Storage: */
double *f0,*y,*wt,*ddfddt,*pred,*ynew,*invwt,*rhs,*psi,*difkp1,*del,*yinterp;
double *tempvec1,*tempvec2,*ypinterp,*yppinterp;
double **dif;
struct jacobian jac;
struct numjac_workspace nj_ws;
/* Method variables: */
double t,t0,tfinal,tnew=0;
double rh,htspan,absh,hmin,hmax,h,tdel;
double abshlast,hinvGak,minnrm,oldnrm=0.,newnrm;
double err,hopt,errkm1,hkm1,errit,rate=0.,temp,errkp1,hkp1,maxtmp;
int k,klast,nconhk,iter,next,kopt,tdir;
/* Misc: */
int stepstat[6],nfenj,j,ii,jj, numidx, neqp=neq+1;
int verbose=0;
/** Allocate memory . */
void * buffer;
int buffer_size;
buffer_size=
15*neqp*sizeof(double)
+neqp*sizeof(int)
+neqp*sizeof(double*)
+(7*neq+1)*sizeof(double);
class_alloc(buffer,
buffer_size,
error_message);
f0 =(double*)buffer;
wt =f0+neqp;
ddfddt =wt+neqp;
pred =ddfddt+neqp;
y =pred+neqp;
invwt =y+neqp;
rhs =invwt+neqp;
psi =rhs+neqp;
difkp1 =psi+neqp;
del =difkp1+neqp;
yinterp =del+neqp;
ypinterp =yinterp+neqp;
yppinterp=ypinterp+neqp;
tempvec1 =yppinterp+neqp;
tempvec2 =tempvec1+neqp;
interpidx=(int*)(tempvec2+neqp);
dif =(double**)(interpidx+neqp);
dif[1] =(double*)(dif+neqp);
for(j=2;j<=neq;j++) dif[j] = dif[j-1]+7; /* Set row pointers... */
dif[0] = NULL;
/* for (ii=0;ii<(7*neq+1);ii++) dif[1][ii]=0.; */
for (j=1; j<=neq; j++) {
for (ii=1;ii<=7;ii++) {
dif[j][ii]=0.;
}
}
/* class_alloc(f0,sizeof(double)*neqp,error_message); */
/* class_alloc(wt,sizeof(double)*neqp,error_message); */
/* class_alloc(ddfddt,sizeof(double)*neqp,error_message); */
/* class_alloc(pred,sizeof(double)*neqp,error_message); */
/* class_alloc(y,sizeof(double)*neqp,error_message); */
/* class_alloc(invwt,sizeof(double)*neqp,error_message); */
/* class_alloc(rhs,sizeof(double)*neqp,error_message); */
/* class_alloc(psi,sizeof(double)*neqp,error_message); */
/* class_alloc(difkp1,sizeof(double)*neqp,error_message); */
/* class_alloc(del,sizeof(double)*neqp,error_message); */
/* class_alloc(yinterp,sizeof(double)*neqp,error_message); */
/* class_alloc(ypinterp,sizeof(double)*neqp,error_message); */
/* class_alloc(yppinterp,sizeof(double)*neqp,error_message); */
/* class_alloc(tempvec1,sizeof(double)*neqp,error_message); */
/* class_alloc(tempvec2,sizeof(double)*neqp,error_message); */
/* class_alloc(interpidx,sizeof(int)*neqp,error_message); */
/* Allocate vector of pointers to rows of dif:*/
/* class_alloc(dif,sizeof(double*)*neqp,error_message); */
/* class_calloc(dif[1],(7*neq+1),sizeof(double),error_message); */
/* dif[0] = NULL; */
/* for(j=2;j<=neq;j++) dif[j] = dif[j-1]+7; */ /* Set row pointers... */
/*Set pointers:*/
ynew = y_inout-1; /* This way y_inout is always up to date. */
/*Initialize the jacobian:*/
class_call(initialize_jacobian(&jac,neq,error_message),error_message,error_message);
/* Initialize workspace for numjac: */
class_call(initialize_numjac_workspace(&nj_ws,neq,error_message),error_message,error_message);
/* Initialize some method parameters:*/
for(ii=0;ii<5;ii++){
invGa[ii] = 1.0/(G[ii]*(1.0 - alpha[ii]));
erconst[ii] = alpha[ii]*G[ii] + 1.0/(2.0+ii);
}
/* Set the relevant indices which needs to be found by interpolation. */
/* But if we want to print variables for testing purposes, just interpolate everything.. */
for(ii=1;ii<=neq;ii++){
y[ii] = y_inout[ii-1];
if (print_variables==NULL){
interpidx[ii]=used_in_output[ii-1];
}
else{
interpidx[ii]=1;
}
}
t0 = x_ini;
tfinal = x_final;
/* Some CLASS-specific stuff:*/
next=0;
while (t_vec[next] < t0) next++;
if (verbose > 1){
numidx=0;
for(ii=1;ii<=neq;ii++){
if (interpidx[ii]==_TRUE_) numidx++;
}
printf("%d/%d ",numidx,neq);
}
htspan = fabs(tfinal-t0);
for(ii=0;ii<6;ii++) stepstat[ii] = 0;
class_call((*derivs)(t0,y+1,f0+1,parameters_and_workspace_for_derivs,error_message),error_message,error_message);
stepstat[2] +=1;
if ((tfinal-t0)<0.0){
tdir = -1;
}
else{
tdir = 1;
}
hmax = (tfinal-t0)/10.0;
t = t0;
nfenj=0;
class_call(numjac((*derivs),t,y,f0,&jac,&nj_ws,abstol,neq,
&nfenj,parameters_and_workspace_for_derivs,error_message),
error_message,error_message);
stepstat[3] += 1;
stepstat[2] += nfenj;
Jcurrent = _TRUE_; /* True */
hmin = 1.e-20;//16.0*eps*fabs(t);
/*Calculate initial step */
rh = 0.0;
for(jj=1;jj<=neq;jj++){
wt[jj] = MAX(fabs(y[jj]),threshold);
/*printf("wt: %4.8f \n",wt[jj]);*/
rh = MAX(rh,1.25/sqrt(rtol)*fabs(f0[jj]/wt[jj]));
}
absh = MIN(hmax, htspan);
if (absh * rh > 1.0) absh = 1.0 / rh;
absh = MAX(absh, hmin);
h = tdir * absh;
tdel = (t + tdir*MIN(sqrt(eps)*MAX(fabs(t),fabs(t+h)),absh)) - t;
class_call((*derivs)(t+tdel,y+1,tempvec1+1,parameters_and_workspace_for_derivs,error_message),
error_message,error_message);
stepstat[2] += 1;
/*I assume that a full jacobi matrix is always calculated in the beginning...*/
for(ii=1;ii<=neq;ii++){
ddfddt[ii]=0.0;
for(jj=1;jj<=neq;jj++){
ddfddt[ii]+=(jac.dfdy[ii][jj])*f0[jj];
}
}
rh = 0.0;
for(ii=1;ii<=neq;ii++){
ddfddt[ii] += (tempvec1[ii] - f0[ii]) / tdel;
rh = MAX(rh,1.25*sqrt(0.5*fabs(ddfddt[ii]/wt[ii])/rtol));
}
absh = MIN(hmax, htspan);
if (absh * rh > 1.0) absh = 1.0 / rh;
absh = MAX(absh, hmin);
h = tdir * absh;
/* Done calculating initial step
Get ready to do the loop:*/
k = 1; /*start at order 1 with BDF1 */
klast = k;
abshlast = absh;
for(ii=1;ii<=neq;ii++) dif[ii][1] = h*f0[ii];
hinvGak = h*invGa[k-1];
nconhk = 0; /*steps taken with current h and k*/
class_call(new_linearisation(&jac,hinvGak,neq,error_message),
error_message,error_message);
stepstat[4] += 1;
havrate = _FALSE_; /*false*/
/* Doing main loop: */
done = _FALSE_;
at_hmin = _FALSE_;
while (done==_FALSE_){
hmin = minimum_variation;
maxtmp = MAX(hmin,absh);
absh = MIN(hmax, maxtmp);
if (fabs(absh-hmin)<100*eps){
/* If the stepsize has not changed */
if (at_hmin==_TRUE_){
absh = abshlast; /*required by stepsize recovery */
}
at_hmin = _TRUE_;
}
else{
at_hmin = _FALSE_;
}
h = tdir * absh;
/* Stretch the step if within 10% of tfinal-t. */
if (1.1*absh >= fabs(tfinal - t)){
h = tfinal - t;
absh = fabs(h);
done = _TRUE_;
}
if (((fabs(absh-abshlast)/absh)>1e-6)||(k!=klast)){
adjust_stepsize(dif,(absh/abshlast),neq,k);
hinvGak = h * invGa[k-1];
nconhk = 0;
class_call(new_linearisation(&jac,hinvGak,neq,error_message),
error_message,error_message);
stepstat[4] += 1;
havrate = _FALSE_;
}
/* Loop for advancing one step */
nofailed = _TRUE_;
for( ; ; ){
gotynew = _FALSE_; /* is ynew evaluated yet?*/
while(gotynew==_FALSE_){
/*Compute the constant terms in the equation for ynew.
Next FOR lop is just: psi = matmul(dif(:,1:k),(G(1:k) * invGa(k)))*/
for(ii=1;ii<=neq;ii++){
psi[ii] = 0.0;
for(jj=1;jj<=k;jj++){
psi[ii] += dif[ii][jj]*G[jj-1]*invGa[k-1];
}
}
/* Predict a solution at t+h. */
tnew = t + h;
if (done==_TRUE_){
tnew = tfinal; /*Hit end point exactly. */
}
h = tnew - t; /* Purify h. */
for(ii=1;ii<=neq;ii++){
pred[ii] = y[ii];
for(jj=1;jj<=k;jj++){
pred[ii] +=dif[ii][jj];
}
}
eqvec(pred,ynew,neq);
/*The difference, difkp1, between pred and the final accepted
ynew is equal to the backward difference of ynew of order
k+1. Initialize to zero for the iteration to compute ynew.
*/
minnrm = 0.0;
for(j=1;j<=neq;j++){
difkp1[j] = 0.0;
maxtmp = MAX(fabs(ynew[j]),fabs(y[j]));
invwt[j] = 1.0 / MAX(maxtmp,threshold);
maxtmp = 100*eps*fabs(ynew[j]*invwt[j]);
minnrm = MAX(minnrm,maxtmp);
}
/* Iterate with simplified Newton method. */
tooslow = _FALSE_;
for(iter=1;iter<=maxit;iter++){
for (ii=1;ii<=neq;ii++){
tempvec1[ii]=(psi[ii]+difkp1[ii]);
}
class_call((*derivs)(tnew,ynew+1,f0+1,parameters_and_workspace_for_derivs,error_message),
error_message,error_message);
stepstat[2] += 1;
for(j=1;j<=neq;j++){
rhs[j] = hinvGak*f0[j]-tempvec1[j];
}
/*Solve the linear system A*x=del by using the LU decomposition stored in jac.*/
if (jac.use_sparse){
sp_lusolve(jac.Numerical, rhs+1, del+1);
}
else{
eqvec(rhs,del,neq);
lubksb(jac.LU,neq,jac.luidx,del);
}
stepstat[5]+=1;
newnrm = 0.0;
for(j=1;j<=neq;j++){
maxtmp = fabs(del[j]*invwt[j]);
newnrm = MAX(newnrm,maxtmp);
}
for(j=1;j<=neq;j++){
difkp1[j] += del[j];
ynew[j] = pred[j] + difkp1[j];
}
if (newnrm <= minnrm){
gotynew = _TRUE_;
break; /* Break Newton loop */
}
else if(iter == 1){
if (havrate==_TRUE_){
errit = newnrm * rate / (1.0 - rate);
if (errit <= 0.05*rtol){
gotynew = _TRUE_;
break; /* Break Newton Loop*/
}
}
else {
rate = 0.0;
}
}
else if(newnrm > 0.9*oldnrm){
tooslow = _TRUE_;
break; /*Break Newton lop */
}
else{
rate = MAX(0.9*rate, newnrm / oldnrm);
havrate = _TRUE_;
errit = newnrm * rate / (1.0 - rate);
if (errit <= 0.5*rtol){
gotynew = _TRUE_;
break; /* exit newton */
}
else if (iter == maxit){
tooslow = _TRUE_;
break; /*exit newton */
}
else if (0.5*rtol < errit*pow(rate,(maxit-iter))){
tooslow = _TRUE_;
break; /*exit Newton */
}
}
oldnrm = newnrm;
}
if (tooslow==_TRUE_){
stepstat[1] += 1;
/* ! Speed up the iteration by forming new linearization or reducing h. */
if (Jcurrent==_FALSE_){
class_call((*derivs)(t,y+1,f0+1,parameters_and_workspace_for_derivs,error_message),
error_message,error_message);
nfenj=0;
class_call(numjac((*derivs),t,y,f0,&jac,&nj_ws,abstol,neq,
&nfenj,parameters_and_workspace_for_derivs,error_message),
error_message,error_message);
stepstat[3] += 1;
stepstat[2] += (nfenj + 1);
Jcurrent = _TRUE_;
}
else if (absh <= hmin){
class_test(absh <= hmin, error_message,
"Step size too small: step:%g, minimum:%g, in interval: [%g:%g]\n",
absh,hmin,t0,tfinal);
}
else{
abshlast = absh;
absh = MAX(0.3 * absh, hmin);
h = tdir * absh;
done = _FALSE_;
adjust_stepsize(dif,(absh/abshlast),neq,k);
hinvGak = h * invGa[k-1];
nconhk = 0;
}
/* A new linearisation is needed in both cases */
class_call(new_linearisation(&jac,hinvGak,neq,error_message),
error_message,error_message);
stepstat[4] += 1;
havrate = _FALSE_;
}
}
/*end of while loop for getting ynew
difkp1 is now the backward difference of ynew of order k+1. */
err = 0.0;
for(jj=1;jj<=neq;jj++){
err = MAX(err,fabs(difkp1[jj]*invwt[jj]));
}
err = err * erconst[k-1];
if (err>rtol){
/*Step failed */
stepstat[1]+= 1;
if (absh <= hmin){ //BEN FLAG: I REMOVED THIS FOR NO GOOD REASON!/
class_test(absh <= hmin, error_message,
"Step size too small: step:%g, minimum:%g, in interval: [%g:%g]\n",
absh,hmin,t0,tfinal);
}
abshlast = absh;
if (nofailed==_TRUE_){
nofailed = _FALSE_;
hopt = absh * MAX(0.1, 0.833*pow((rtol/err),(1.0/(k+1))));
if (k > 1){
errkm1 = 0.0;
for(jj=1;jj<=neq;jj++){
errkm1 = MAX(errkm1,fabs((dif[jj][k]+difkp1[jj])*invwt[jj]));
}
errkm1 = errkm1*erconst[k-2];
hkm1 = absh * MAX(0.1, 0.769*pow((rtol/errkm1),(1.0/k)));
if (hkm1 > hopt){
hopt = MIN(absh,hkm1); /* don't allow step size increase */
k = k - 1;
}
}
absh = MAX(hmin, hopt);
}
else{
absh = MAX(hmin, 0.5 * absh);
}
h = tdir * absh;
if (absh < abshlast){
done = _FALSE_;
}
adjust_stepsize(dif,(absh/abshlast),neq,k);
hinvGak = h * invGa[k-1];
nconhk = 0;
class_call(new_linearisation(&jac,hinvGak,neq,error_message),
error_message,error_message);
stepstat[4] += 1;
havrate = _FALSE_;
}
else {
break; /* Succesfull step */
}
}
/* End of conditionless FOR loop */
stepstat[0] += 1;
/* Update dif: */
for(jj=1;jj<=neq;jj++){
dif[jj][k+2] = difkp1[jj] - dif[jj][k+1];
dif[jj][k+1] = difkp1[jj];
}
for(j=k;j>=1;j--){
for(ii=1;ii<=neq;ii++){
dif[ii][j] += dif[ii][j+1];
}
}
/** Output **/
while ((next<tres)&&(tdir * (tnew - t_vec[next]) >= 0.0)){
/* Do we need to write output? */
if (tnew==t_vec[next]){
class_call((*output)(t_vec[next],ynew+1,f0+1,next,parameters_and_workspace_for_derivs,error_message),
error_message,error_message);
// MODIFICATION BY LUC
// All print_variables have been moved to the end of time step
/*
if (print_variables != NULL){
class_call((*print_variables)(t_vec[next],ynew+1,f0+1,
parameters_and_workspace_for_derivs,error_message),
error_message,error_message);
}
*/
}
else {
/*Interpolate if we have overshot sample values*/
interp_from_dif(t_vec[next],tnew,ynew,h,dif,k,yinterp,ypinterp,yppinterp,interpidx,neq,2);
class_call((*output)(t_vec[next],yinterp+1,ypinterp+1,next,parameters_and_workspace_for_derivs,
error_message),error_message,error_message);
}
next++;
}
/** End of output **/
if (done==_TRUE_) {
break;
}
klast = k;
abshlast = absh;
nconhk = MIN(nconhk+1,maxk+2);
if (nconhk >= k + 2){
temp = 1.2*pow((err/rtol),(1.0/(k+1.0)));
if (temp > 0.1){
hopt = absh / temp;
}
else {
hopt = 10*absh;
}
kopt = k;
if (k > 1){
errkm1 = 0.0;
for(jj=1;jj<=neq;jj++){
errkm1 = MAX(errkm1,fabs(dif[jj][k]*invwt[jj]));
}
errkm1 = errkm1*erconst[k-2];
temp = 1.3*pow((errkm1/rtol),(1.0/k));
if (temp > 0.1){
hkm1 = absh / temp;
}
else {
hkm1 = 10*absh;
}
if (hkm1 > hopt){
hopt = hkm1;
kopt = k - 1;
}
}
if (k < maxk){
errkp1 = 0.0;
for(jj=1;jj<=neq;jj++){
errkp1 = MAX(errkp1,fabs(dif[jj][k+2]*invwt[jj]));
}
errkp1 = errkp1*erconst[k];
temp = 1.4*pow((errkp1/rtol),(1.0/(k+2.0)));
if (temp > 0.1){
hkp1 = absh / temp;
}
else {
hkp1 = 10*absh;
}
if (hkp1 > hopt){
hopt = hkp1;
kopt = k + 1;
}
}
if (hopt > absh){
absh = hopt;
if (k!=kopt){
k = kopt;
}
}
}
/* Advance the integration one step. */
t = tnew;
eqvec(ynew,y,neq);
Jcurrent = _FALSE_;
// MODIFICATION BY LUC
if (print_variables!=NULL){
class_call((*derivs)(tnew,
ynew+1,
f0+1,
parameters_and_workspace_for_derivs,error_message),
error_message,
error_message);
class_call((*print_variables)(tnew,ynew+1,f0+1,
parameters_and_workspace_for_derivs,error_message),
error_message,error_message);
}
// end of modification
}
/* a last call is compulsory to ensure that all quantitites in
y,dy,parameters_and_workspace_for_derivs are updated to the
last point in the covered range */
class_call(
(*derivs)(tnew,
ynew+1,
f0+1,
parameters_and_workspace_for_derivs,error_message),
error_message,
error_message);
if (verbose > 0){
printf("\n End of evolver. Next=%d, t=%e and tnew=%e.",next,t,tnew);
printf("\n Statistics: [%d %d %d %d %d %d] \n",stepstat[0],stepstat[1],
stepstat[2],stepstat[3],stepstat[4],stepstat[5]);
}
/** Deallocate memory */
free(buffer);
/* free(f0); */
/* free(wt); */
/* free(ddfddt); */
/* free(pred); */
/* free(y); */
/* free(invwt); */
/* free(rhs); */
/* free(psi); */
/* free(difkp1); */
/* free(del); */
/* free(yinterp); */
/* free(ypinterp); */
/* free(yppinterp); */
/* free(tempvec1); */
/* free(tempvec2); */
/* free(interpidx); */
/* free(dif[1]); */
/* free(dif); */
uninitialize_jacobian(&jac);
uninitialize_numjac_workspace(&nj_ws);
return _SUCCESS_;
} /*End of program*/
int parser_read_list_of_strings(
struct file_content * pfc,
char * name,
int * size,
char ** pointer_to_list,
int * found,
ErrorMsg errmsg
) {
int index;
int i;
char * string;
char * substring;
FileArg string_with_one_value;
char * list;
/* intialize the 'found' flag to false */
* found = _FALSE_;
/* search parameter */
index=0;
while ((index < pfc->size) && (strcmp(pfc->name[index],name) != 0))
index++;
/* if parameter not found, return with 'found' flag still equal to false */
if (index == pfc->size)
return _SUCCESS_;
/* count number of comas and compute size = number of comas + 1 */
i = 0;
string = pfc->value[index];
do {
i ++;
substring = strchr(string,',');
string = substring+1;
} while(substring != NULL);
*size = i;
/* free and re-allocate array of values */
class_alloc(list,*size*sizeof(FileArg),errmsg);
*pointer_to_list = list;
/* read one string between each comas */
i = 0;
string = pfc->value[index];
do {
i ++;
substring = strchr(string,',');
if (substring == NULL) {
strcpy(string_with_one_value,string);
}
else {
strncpy(string_with_one_value,string,(substring-string));
string_with_one_value[substring-string]='\0';
}
strcpy(list+(i-1)*_ARGUMENT_LENGTH_MAX_,string_with_one_value);
//Insert EOL character:
*(list+i*_ARGUMENT_LENGTH_MAX_-1) = '\n';
string = substring+1;
} while(substring != NULL);
/* if parameter read correctly, set 'found' flag to true, as well as the flag
associated with this parameter in the file_content structure */
* found = _TRUE_;
pfc->read[index] = _TRUE_;
/* check for multiple entries of the same parameter. If another occurence is
found,
return an error. */
for (i=index+1; i < pfc->size; i++) {
class_test(strcmp(pfc->name[i],name) == 0,
errmsg,
"multiple entry of parameter %s in file %s\n",name,pfc->filename);
}
/* if everything proceeded normally, return with 'found' flag equal to true */
return _SUCCESS_;
}
int main(int argc, char **argv) {
struct precision pr; /* for precision parameters */
struct background ba; /* for cosmological background */
struct thermo th; /* for thermodynamics */
struct perturbs pt; /* for source functions */
struct bessels bs; /* for bessel functions */
struct transfers tr; /* for transfer functions */
struct primordial pm; /* for primordial spectra */
struct spectra sp; /* for output spectra */
struct lensing le; /* for lensing spectra */
struct output op; /* for output files */
struct spectra_nl nl; /* for calculation of non-linear spectra */
ErrorMsg errmsg;
if (input_init_from_arguments(argc, argv,&pr,&ba,&th,&pt,&bs,&tr,&pm,&sp,&le,&op,&nl,errmsg) == _FAILURE_) {
printf("\n\nError running input_init_from_arguments \n=>%s\n",errmsg);
return _FAILURE_;
}
if (background_init(&pr,&ba) == _FAILURE_) {
printf("\n\nError running background_init \n=>%s\n",ba.error_message);
return _FAILURE_;
}
if (thermodynamics_init(&pr,&ba,&th) == _FAILURE_) {
printf("\n\nError in thermodynamics_init \n=>%s\n",th.error_message);
return _FAILURE_;
}
if (perturb_init(&pr,&ba,&th,&pt) == _FAILURE_) {
printf("\n\nError in perturb_init \n=>%s\n",pt.error_message);
return _FAILURE_;
}
if (bessel_init(&pr,&bs) == _FAILURE_) {
printf("\n\nError in bessel_init \n =>%s\n",bs.error_message);
return _FAILURE_;
}
if (transfer_init(&pr,&ba,&th,&pt,&bs,&tr) == _FAILURE_) {
printf("\n\nError in transfer_init \n=>%s\n",tr.error_message);
return _FAILURE_;
}
if (primordial_init(&pr,&pt,&pm) == _FAILURE_) {
printf("\n\nError in primordial_init \n=>%s\n",pm.error_message);
return _FAILURE_;
}
if (spectra_init(&ba,&pt,&tr,&pm,&sp) == _FAILURE_) {
printf("\n\nError in spectra_init \n=>%s\n",sp.error_message);
return _FAILURE_;
}
if (output_init(&ba,&pt,&sp,&op) == _FAILURE_) {
printf("\n\nError in output_init \n=>%s\n",op.error_message);
return _FAILURE_;
}
/****** done ******/
int index_mode=0;
int index_eta;
int index_ic=0;
int index_k;
double delta_rho_bc,rho_bc;
double delta_i,rho_i;
double P_bc;
int last_index_back;
double * pvecback_long;
double k,pk;
FILE * output;
double z,eta;
double * tki;
if(pt.has_matter_transfers == _FALSE_) {
printf("You need to switch on mTk calculation for this code\n");
return _FAILURE_;
}
output=fopen("output/Pcb.dat","w");
class_alloc(pvecback_long,sizeof(double)*ba.bg_size,errmsg);
class_alloc(tki,sizeof(double)*sp.ln_k_size*sp.tr_size,errmsg);
z=0.;
if(background_eta_of_z(&ba,z,&eta) == _FAILURE_) {
printf("\n\nError running background_eta_of_z \n=>%s\n",ba.error_message);
return _FAILURE_;
}
if(background_at_eta(&ba,
eta,
long_info,
normal,
&last_index_back,
pvecback_long) == _FAILURE_) {
printf("\n\nError running background_at_eta \n=>%s\n",ba.error_message);
return _FAILURE_;
}
if (spectra_tk_at_z(&ba,&sp,z,tki) == _FAILURE_) {
printf("\n\nError in spectra_tk_at_z \n=>%s\n",sp.error_message);
return _FAILURE_;
}
for (index_k=0; index_k<sp.ln_k_size; index_k++) {
k=exp(sp.ln_k[index_k]);
delta_rho_bc=0.;
rho_bc=0.;
/* T_b(k,eta) */
delta_i = tki[index_k*sp.tr_size+sp.index_tr_b];
rho_i = pvecback_long[ba.index_bg_rho_b];
delta_rho_bc += rho_i * delta_i;
rho_bc += rho_i;
/* T_cdm(k,eta) */
if (ba.has_cdm == _TRUE_) {
delta_i = tki[index_k*sp.tr_size+sp.index_tr_cdm];
rho_i = pvecback_long[ba.index_bg_rho_cdm];
delta_rho_bc += rho_i * delta_i;
rho_bc += rho_i;
}
if (primordial_spectrum_at_k(&pm,index_mode,linear,k,&pk) == _FAILURE_) {
printf("\n\nError in primordial_spectrum_at_k \n=>%s\n",pm.error_message);
return _FAILURE_;
}
P_bc=pk*pow(delta_rho_bc/rho_bc,2)*2.*_PI_*_PI_/k/k/k;
fprintf(output,"%e %e\n",k,P_bc);
}
/******************/
if (spectra_free(&sp) == _FAILURE_) {
printf("\n\nError in spectra_free \n=>%s\n",sp.error_message);
return _FAILURE_;
}
if (primordial_free(&pm) == _FAILURE_) {
printf("\n\nError in primordial_free \n=>%s\n",pm.error_message);
return _FAILURE_;
}
if (transfer_free(&tr) == _FAILURE_) {
printf("\n\nError in transfer_free \n=>%s\n",tr.error_message);
return _FAILURE_;
}
if (bessel_free(&bs) == _FAILURE_) {
printf("\n\nError in bessel_free \n=>%s\n",bs.error_message);
return _FAILURE_;
}
if (perturb_free(&pt) == _FAILURE_) {
printf("\n\nError in perturb_free \n=>%s\n",pt.error_message);
return _FAILURE_;
}
if (thermodynamics_free(&th) == _FAILURE_) {
printf("\n\nError in thermodynamics_free \n=>%s\n",th.error_message);
return _FAILURE_;
}
if (background_free(&ba) == _FAILURE_) {
printf("\n\nError in background_free \n=>%s\n",ba.error_message);
return _FAILURE_;
}
return _SUCCESS_;
}