Ejemplo n.º 1
0
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_;
}
Ejemplo n.º 2
0
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_;
}
Ejemplo n.º 3
0
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_;
}
Ejemplo n.º 4
0
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;
}
Ejemplo n.º 5
0
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);
    }
}
Ejemplo n.º 6
0
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;
}
Ejemplo n.º 7
0
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;
    }
}
Ejemplo n.º 8
0
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;
}
Ejemplo n.º 9
0
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);
    }
}
Ejemplo n.º 10
0
VALUE
rb_module_new(void)
{
    VALUE mdl = class_alloc(T_MODULE, rb_cModule);
    RCLASS_M_TBL_INIT(mdl);
    return (VALUE)mdl;
}
Ejemplo n.º 11
0
VALUE
rb_module_new(void)
{
    VALUE mdl = class_alloc(T_MODULE, rb_cModule);

    RCLASS_M_TBL(mdl) = st_init_numtable();

    return (VALUE)mdl;
}
Ejemplo n.º 12
0
/*!
 * 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;
}
Ejemplo n.º 13
0
/*!
 * 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;
}
Ejemplo n.º 14
0
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_;

}
Ejemplo n.º 15
0
/* 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;
}
Ejemplo n.º 16
0
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_;

}
Ejemplo n.º 17
0
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;
    }
}
Ejemplo n.º 18
0
/**
 * 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));
	}
}
Ejemplo n.º 19
0
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_;

}
Ejemplo n.º 20
0
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");
  }
}
Ejemplo n.º 21
0
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_;
}
Ejemplo n.º 22
0
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_;
}
Ejemplo n.º 23
0
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*/
Ejemplo n.º 24
0
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_;
}
Ejemplo n.º 25
0
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_;

}