Esempio n. 1
0
int GlmTest::resampAnovaCase(glm *model, gsl_matrix *bT, gsl_matrix *bX,
                             gsl_matrix *bO, unsigned int i) {
  gsl_set_error_handler_off();
  int status, isValid = TRUE;

  unsigned int j, id, nP;
  gsl_vector_view yj, xj, oj;
  nP = model->Xref->size2;
  gsl_matrix *tXX = gsl_matrix_alloc(nP, nP);
  unsigned int nRows = tm->nRows;

  while (isValid == TRUE) {
    for (j = 0; j < nRows; j++) {
      if (bootID != NULL)
        id = (unsigned int)gsl_matrix_get(bootID, i, j);
      else {
        if (tm->reprand == TRUE)
          id = (unsigned int)gsl_rng_uniform_int(rnd, nRows);
        else
          id = (unsigned int)nRows * Rf_runif(0, 1);
      }
      // resample Y and X and offset
      yj = gsl_matrix_row(model->Yref, id);
      xj = gsl_matrix_row(model->Xref, id);
      oj = gsl_matrix_row(model->Eta, id);
      // oj = gsl_matrix_row(model->Oref, id);
      gsl_matrix_set_row(bT, j, &yj.vector);
      gsl_matrix_set_row(bX, j, &xj.vector);
      gsl_matrix_set_row(bO, j, &oj.vector);
    }
    gsl_matrix_set_identity(tXX);
    gsl_blas_dsyrk(CblasLower, CblasTrans, 1.0, bX, 0.0, tXX);
    status = gsl_linalg_cholesky_decomp(tXX);
    if (status != GSL_EDOM)
      break;
  }

  gsl_matrix_free(tXX);

  return SUCCESS;
}
/* Initialise RMHMC kernel with initial parameters x.
 * Arguments:
 *	kernel:		a pointer to the RMHMC kernel structure.
 *	x:			an array of N doubles with initial parameters. N must be 
 *				equal to kernel->N.
 * Result:
 * returns 0 for success and non-zero for error.
 */
static int rmhmc_kernel_init(mcmc_kernel* kernel, const double* x){
	int res,i,n;
	n = kernel->N;
	
	rmhmc_params* params = (rmhmc_params*)kernel->kernel_params;
	/* copy x to the kernel x state */
	for ( i=0; i < n; i++)
		kernel->x[i] = x[i];
	
	rmhmc_model* model = kernel->model_function;
	
	/* call user function to update all required quantities */
	res = model->PosteriorAll(x, model->m_params, &(params->fx), params->dfx, params->cholMx, params->dMx);
		
	/* TODO: write a proper error handler */
	if (res != 0){
		fprintf(stderr,"rmhmc_kernel_init: Likelihood function failed\n");
		return 1;
	}
	
	/* calculate cholesky factor for current metric */
	gsl_matrix_view cholMx_v = gsl_matrix_view_array(params->cholMx,n,n); 
	
	gsl_error_handler_t* old_handle =  gsl_set_error_handler_off();
	res = gsl_linalg_cholesky_decomp( &cholMx_v.matrix );
	if (res != 0){
		fprintf(stderr,"Error: matrix not positive definite in rmhmc_init.\n");
		return -1;
	}
	gsl_set_error_handler(old_handle);

	/* calculate inverse for current metric */
	gsl_matrix_view invMx_v = gsl_matrix_view_array(params->invMx,n,n);
	gsl_matrix_memcpy(&invMx_v.matrix, &cholMx_v.matrix );
	gsl_linalg_cholesky_invert(&invMx_v.matrix);
	
	/* calculate trace terms from equation (15) in Girolami and Calderhead (2011) */
	calculateTraceTerms(n, params->invMx, params->dMx, params->tr_invM_dM);
	
	return 0;
}
Esempio n. 3
0
double Matrix::determinant()
{
	int rows = numRows();
	int cols = numCols();

	if (rows != cols){
		QMessageBox::critical((ApplicationWindow *)applicationWindow(), tr("QtiPlot - Error"),
				tr("Calculation failed, the matrix is not square!"));
		return GSL_POSINF;
	}

	gsl_set_error_handler_off();

	gsl_matrix *A = gsl_matrix_alloc(rows, cols);
    gsl_permutation * p = gsl_permutation_alloc(rows);
	if (!A || !p){
		QApplication::restoreOverrideCursor();
		QMessageBox::critical((ApplicationWindow *)applicationWindow(),
				tr("QtiPlot") + " - " + tr("Memory Allocation Error"),
				tr("Not enough memory, operation aborted!"));
		return 0.0;
	}

	QApplication::setOverrideCursor(QCursor(Qt::WaitCursor));

	double *data = d_matrix_model->dataVector();
	int i, cell = 0;
	for(i=0; i<rows; i++)
		for(int j=0; j<cols; j++)
			gsl_matrix_set(A, i, j, data[cell++]);


	gsl_linalg_LU_decomp(A, p, &i);
	double det = gsl_linalg_LU_det(A, i);

	gsl_matrix_free(A);
	gsl_permutation_free(p);

	QApplication::restoreOverrideCursor();
	return det;
}
Esempio n. 4
0
int test_main(int, char* [])
{
#ifdef TEST_GSL
   gsl_set_error_handler_off();
#endif
   BOOST_MATH_CONTROL_FP;

#ifndef BOOST_MATH_BUGGY_LARGE_FLOAT_CONSTANTS
   test_hankel(0.1F, "float");
#endif
   test_hankel(0.1, "double");
#ifndef BOOST_MATH_NO_LONG_DOUBLE_MATH_FUNCTIONS
   test_hankel(0.1L, "long double");
#else
   std::cout << "<note>The long double tests have been disabled on this platform "
      "either because the long double overloads of the usual math functions are "
      "not available at all, or because they are too inaccurate for these tests "
      "to pass.</note>" << std::cout;
#endif
   return 0;
}
Esempio n. 5
0
int gsl_svd(
	const struct tc_mat *A,
	struct tc_mat *U,
	struct tc_mat *D,
	struct tc_mat *V)
{
	if (!A || !U || !D || !V)
		return -1;
	if ((U->nr != A->nr) || (U->nc != A->nc))
		tc_mat_resize(U, A->nr, A->nc);
	if ((V->nr != A->nc) || (V->nc != A->nc))
		tc_mat_resize(V, A->nc, A->nc);
	if ((D->nr != A->nc) || (D->nc != A->nc))
		tc_mat_resize(D, A->nc, A->nc);
	gsl_vector *gwork = gsl_vector_alloc(A->nc);
	gsl_vector *gS = gsl_vector_alloc(A->nc);
	gsl_matrix *gA = gsl_matrix_alloc(A->nr, A->nc);
	gsl_matrix *gV = gsl_matrix_alloc(A->nc, A->nc);
	for(uint32_t i=0; i < A->nr; i++)
		for(uint32_t j=0; j < A->nc; j++)
			gsl_matrix_set(gA, i, j, A->a[i][j]);
	gsl_set_error_handler_off();
	int status = gsl_linalg_SV_decomp(gA, gV, gS, gwork);
	if (status != GSL_SUCCESS)
		return -2;
	for(uint32_t i=0; i < U->nr; i++)
		for(uint32_t j=0; j < U->nc; j++)
			U->a[i][j] = gsl_matrix_get(gA, i, j);
	for(uint32_t i=0; i < D->nr; i++)
		for(uint32_t j=0; j < D->nc; j++)
			D->a[i][j] = (i==j)? gsl_vector_get(gS, i): 0.0;
	for(uint32_t i=0; i < V->nr; i++)
		for(uint32_t j=0; j < V->nc; j++)
			V->a[i][j] = gsl_matrix_get(gV, i, j);
	gsl_vector_free(gwork);
	gsl_vector_free(gS);
	gsl_matrix_free(gA);
	gsl_matrix_free(gV);
	return 0;
}
Esempio n. 6
0
/** Initialisation method
 */
void Fit1D::init()
{
  declareProperty(new WorkspaceProperty<MatrixWorkspace>("InputWorkspace","",Direction::Input), "Name of the input Workspace");

  auto mustBePositive = boost::make_shared<BoundedValidator<int> >();
  mustBePositive->setLower(0);
  declareProperty("WorkspaceIndex",0, mustBePositive,
    "The Workspace to fit, uses the workspace numbering of the spectra (default 0)");
  declareProperty("StartX", EMPTY_DBL(),
    "A value of x in, or on the low x boundary of, the first bin to include in\n"
    "the fit (default lowest value of x)" );
  declareProperty("EndX", EMPTY_DBL(),
    "A value in, or on the high x boundary of, the last bin the fitting range\n"
    "(default the highest value of x)" );

  size_t i0 = getProperties().size();

  // declare parameters specific to a given fitting function
  declareParameters();

  // load the name of these specific parameter into a vector for later use
  const std::vector< Property* > props = getProperties();
  for ( size_t i = i0; i < props.size(); i++ )
  {
    m_parameterNames.push_back(props[i]->name());
  }

  declareProperty("Fix","","A list of comma separated parameter names which should be fixed in the fit");
  declareProperty("MaxIterations", 500, mustBePositive,
    "Stop after this number of iterations if a good fit is not found" );
  declareProperty("OutputStatus","", Direction::Output);
  declareProperty("OutputChi2overDoF",0.0, Direction::Output);

  // Disable default gsl error handler (which is to call abort!)
  gsl_set_error_handler_off();

  declareAdditionalProperties();

  declareProperty("Output","","If not empty OutputParameters TableWorksace and OutputWorkspace will be created.");
}
Esempio n. 7
0
double gslInt_diffusion( double E,  double ri, double r){			// int over Ep
	double E_scaled = (int)(E/c.scale);
	double vE = c.vlookup[E_scaled];
	//std::cout <<"E_scaled = " << E_scaled << std::endl;
	//std::cout << c.n << " , " <<p.mx <<" ";
	//double Ep = (p.mx + E) /2;
	//std::cout <<E <<" -> vE = "<< vE << std::endl;
	//double scale = 0.001;
	//double Es = (int)(E*c.n/p.mx);
	//std::cout <<  sqrt(vE)/mpc2cm*1000 << "   "<<sqrt(c.vlookup[ E*c.n/p.mx ])/mpc2cm*1000 <<std::endl;;
	//std::cout << Es << " LUT = " << sqrt(c.vlookup[ Es ])/mpc2cm*1000 << std::endl;
	//double rootdv =sqrt(c.vlookup[E*c.n/p.mx]) ;//0.035*mpc2cm ;//sqrt(c.vlookup[ Es ]); //gives max value for rootdv//root_dv(Ep, vE); //

	//std::cout << "umax:  " << umax << std::endl;
		
	gsl_integration_workspace * w 
		= gsl_integration_workspace_alloc (1000);

	double result, error;

	std::vector<double> diffusionParams (4);

	diffusionParams[0] = E;
	diffusionParams[1] = ri;
	diffusionParams[2] = vE;
	diffusionParams[3] = r;

	gsl_function F;
	F.function = &ddiffusion;
	F.params = &diffusionParams; 								//pass Ep to rootdv(), pass r from dndeeq as well, 
	gsl_set_error_handler_off();
	gsl_integration_qags (&F, E, p.mx, 0, 1e-1, 1000, 
	                    w, &result, &error); 
//std::cout << "result = " << result <<std::endl;
	gsl_integration_workspace_free (w);

	return result;

}
Esempio n. 8
0
void FC_FUNC_(oct_1dminimize, OCT_1DMINIMIZE)(double *a, double *b, double *m, func1 f, int *status)
{
  int iter = 0;
  int max_iter = 100;
  const gsl_min_fminimizer_type *T;
  gsl_min_fminimizer *s;
  gsl_function F;
  param_f1_t p;

  p.func = f;

  F.function = &fn1;
  F.params = (void *) &p;

  T = gsl_min_fminimizer_brent;
  s = gsl_min_fminimizer_alloc (T);

  *status = gsl_min_fminimizer_set (s, &F, *m, *a, *b);

  gsl_set_error_handler_off();

  do
    {
      iter++;
      *status = gsl_min_fminimizer_iterate (s);

      *m = gsl_min_fminimizer_x_minimum (s);
      *a = gsl_min_fminimizer_x_lower (s);
      *b = gsl_min_fminimizer_x_upper (s);

      *status = gsl_min_test_interval (*a, *b, 0.00001, 0.0);

      /*if (*status == GSL_SUCCESS) printf ("Converged:\n");*/
      /*printf ("%5d [%.7f, %.7f] %.7f \n", iter, *a, *b,*m);*/
    }
  while (*status == GSL_CONTINUE && iter < max_iter);
  gsl_min_fminimizer_free(s);

}
double epidemicGrowthRate(const double theta[numParam], const double r0time, double * eigenvec)
{

  gsl_matrix * Fmat = gsl_matrix_calloc(NG*(DS-1)*RG, NG*(DS-1)*RG);
  gsl_matrix * Vmat = gsl_matrix_calloc(NG*(DS-1)*RG, NG*(DS-1)*RG);

  createNGM(theta, r0time, Fmat, Vmat);
  gsl_matrix_sub(Fmat, Vmat);

  gsl_eigen_nonsymmv_workspace * w = gsl_eigen_nonsymmv_alloc(NG*(DS-1)*RG);
  gsl_vector_complex * eval = gsl_vector_complex_alloc(NG*(DS-1)*RG);
  gsl_matrix_complex * evec = gsl_matrix_complex_alloc(NG*(DS-1)*RG, NG*(DS-1)*RG);

  gsl_set_error_handler_off();
  gsl_eigen_nonsymmv(Fmat, eval, evec, w);

  size_t growth_rate_idx = 0;
  double growth_rate = -INFINITY;
  for(size_t i = 0; i < NG*(DS-1)*RG; i++){
    if(GSL_REAL(gsl_vector_complex_get(eval, i)) > growth_rate){
      growth_rate_idx = i;
      growth_rate = GSL_REAL(gsl_vector_complex_get(eval, i));
    }
  }

  if(eigenvec != NULL){
    for(size_t i = 0; i < NG*(DS-1)*RG; i++)
      eigenvec[i] = GSL_REAL(gsl_matrix_complex_get(evec, i, growth_rate_idx));
  }

  gsl_matrix_free(Fmat);
  gsl_matrix_free(Vmat);
  gsl_vector_complex_free(eval);
  gsl_matrix_complex_free(evec);
  gsl_eigen_nonsymmv_free(w);

  return growth_rate;
}
Esempio n. 10
0
double sncp_model::propose_new_parameters(double alpha,double z,double  previous_height, double bound,double norm){

  gsl_error_handler_t * old_handler = gsl_set_error_handler_off();
  double new_value=NAN;
  int count =0;
  while(new_value!=new_value){
    double u = gsl_ran_flat(m_r,0,1);
    u*=norm;

    new_value = gsl_cdf_gamma_Pinv(u,alpha,1.0/(double)z); 

    //if(new_value!=new_value)
    //  cout<<u<<" "<<norm<<" "<<bound<<" "<<alpha<<" "<<z<<" "<<previous_height<<endl;
    
    count++;
    if(count>20 and bound>0){
      new_value=(previous_height+bound)/2;
      //cout<<new_value<<endl;
    }
  }
  gsl_set_error_handler(old_handler);
  return new_value;
}
Esempio n. 11
0
int test_main(int, char* [])
{
#ifdef TEST_GSL
    gsl_set_error_handler_off();
#endif
    expected_results();
    BOOST_MATH_CONTROL_FP;

    test_bessel(0.1F, "float");
    test_bessel(0.1, "double");
#ifndef BOOST_MATH_NO_LONG_DOUBLE_MATH_FUNCTIONS
    test_bessel(0.1L, "long double");
#ifndef BOOST_MATH_NO_REAL_CONCEPT_TESTS
    test_bessel(boost::math::concepts::real_concept(0.1), "real_concept");
#endif
#else
    std::cout << "<note>The long double tests have been disabled on this platform "
              "either because the long double overloads of the usual math functions are "
              "not available at all, or because they are too inaccurate for these tests "
              "to pass.</note>" << std::cout;
#endif
    return 0;
}
Esempio n. 12
0
void conf(Args *args, Result *result){
  const gsl_root_fsolver_type *solverType;
  gsl_root_fsolver *s;
  gsl_function fun;
  double xLo, xHi;
  int status;

  /* preliminaries */
  gsl_set_error_handler_off();
  fun.function = &confFun;
  fun.params = result;
  solverType = gsl_root_fsolver_brent;
  s = gsl_root_fsolver_alloc(solverType);
  /* search for lower bound of delta */
  result->type = 2;
  if(result->de < 0)
    xLo = -1;
  else
    xLo = 0;
  xHi = result->de;
  status = gsl_root_fsolver_set(s,&fun,xLo,xHi);
  if(status){
    printf("WARNING: Lower confidence limit of \\Delta cannot be estimated; setting it to -1.\n");
    result->dLo = -1.0;
  }else
    result->dLo = iterate(args, s, xLo, xHi);
  /* search for upper bound of delta */
  xLo = result->de;
  xHi = 1.0;
  status = gsl_root_fsolver_set(s,&fun,xLo,xHi);
  if(status){
    printf("WARNING: Upper confidence limit of \\Delta cannot be estimated; setting it to 1.\n");
    result->dUp = 1;
  }else
    result->dUp = iterate(args, s, xLo, xHi);
  gsl_root_fsolver_free(s);
}
Esempio n. 13
0
/* --------------------- Interface to Fortran ---------------------- */
double FC_FUNC_(c_poisson_cutoff_1d_0d, C_POISSON_CUTOFF_1D_0D)
     (double *g, double *a, double *rc)
{
  double result, error;
  struct parameters_1d_0d params;
  const size_t wrk_size = 5000;
  const double epsilon_abs = 1e-3;
  const double epsilon_rel = 1e-3;
  int status;
  gsl_integration_workspace * ws;
  gsl_function F;

  if((*g) <= 0.0){return 2.0*asinh((*rc)/(*a));};
  if((*g)*(*rc) > 100.0*M_PI){return 2.0*gsl_sf_bessel_K0((*a)*(*g));};

  gsl_set_error_handler_off();

  ws = gsl_integration_workspace_alloc (wrk_size);

  params.g = *g;
  params.a = *a;

  F.function = &cutoff_1d_0d;
  F.params = &params;

  status = gsl_integration_qag(&F, 0.0, (*rc)*(*g), epsilon_abs, epsilon_rel, 
    wrk_size, 3, ws, &result, &error);

  gsl_integration_workspace_free (ws);

  if(status){
    return 0.0;
  }else{
    return result;
  }

}
/** Initialisation method
*/
void DiffractionEventCalibrateDetectors::init() {
  declareProperty(make_unique<WorkspaceProperty<EventWorkspace>>(
                      "InputWorkspace", "", Direction::Input,
                      boost::make_shared<InstrumentValidator>()),
                  "The workspace containing the geometry to be calibrated.");

  declareProperty("Params", "",
                  "A comma separated list of first bin boundary, width, last "
                  "bin boundary. Optionally "
                  "this can be followed by a comma and more widths and last "
                  "boundary pairs. "
                  "Use bin boundaries close to peak you wish to maximize. "
                  "Negative width values indicate logarithmic binning.");

  auto mustBePositive = boost::make_shared<BoundedValidator<int>>();
  declareProperty(
      "MaxIterations", 10, mustBePositive,
      "Stop after this number of iterations if a good fit is not found");

  auto dblmustBePositive = boost::make_shared<BoundedValidator<double>>();
  declareProperty("LocationOfPeakToOptimize", 2.0308, dblmustBePositive,
                  "Optimize this location of peak by moving detectors");

  declareProperty(make_unique<API::FileProperty>(
                      "DetCalFilename", "", API::FileProperty::Save, ".DetCal"),
                  "The output filename of the ISAW DetCal file");

  declareProperty(
      make_unique<PropertyWithValue<std::string>>("BankName", "",
                                                  Direction::Input),
      "Optional: To only calibrate one bank. Any bank whose name does not "
      "match the given string will have no events.");

  // Disable default gsl error handler (which is to call abort!)
  gsl_set_error_handler_off();
}
Esempio n. 15
0
//Main program
int main(int argc, char *argv[])
{
   
  INT4 ii, jj;               //counter variables
   
   //Turn off gsl error handler
   gsl_set_error_handler_off();
   
   //Initiate command line interpreter and config file loader
   struct gengetopt_args_info args_info;
   struct cmdline_parser_params *configparams;
   configparams = cmdline_parser_params_create();  //initialize parameters structure
   configparams->check_required = 0;  //don't check for required values at the step
   if ( cmdline_parser_ext(argc, argv, &args_info, configparams) ) {
       fprintf(stderr, "%s: cmdline_parser_ext() failed.\n", __func__);
       XLAL_ERROR(XLAL_FAILURE);
   }
   configparams->initialize = 0;  //don't reinitialize the parameters structure
   if ( args_info.config_given && cmdline_parser_config_file(args_info.config_arg, &args_info, configparams) ) {
      fprintf(stderr, "%s: cmdline_parser_config_file() failed.\n", __func__);
      XLAL_ERROR(XLAL_FAILURE);
   }
   //Check required
   if ( cmdline_parser_required(&args_info, argv[0]) ) {
      fprintf(stderr, "%s: cmdline_parser_required() failed.\n", __func__);
      XLAL_ERROR(XLAL_FAILURE);
   }
   
   //Set lalDebugLevel to user input or 0 if no input
   
   //Allocate input parameters structure memory
   inputParamsStruct *inputParams = new_inputParams(args_info.IFO_given);
   if (inputParams==NULL) {
      fprintf(stderr, "%s: new_inputParams() failed.\n", __func__);
      XLAL_ERROR(XLAL_EFUNC);
   }
   
   //Read TwoSpect input parameters
   if ( (readTwoSpectInputParams(inputParams, args_info)) != 0 ) {
      fprintf(stderr, "%s: readTwoSpectInputParams() failed.\n", __func__);
      XLAL_ERROR(XLAL_EFUNC);
   }
   
   //Initialize ephemeris data structure
   EphemerisData *edat = XLALInitBarycenter(earth_ephemeris, sun_ephemeris);
   if (edat==NULL) {
      fprintf(stderr, "%s: XLALInitBarycenter() failed.\n", __func__);
      XLAL_ERROR(XLAL_EFUNC);
   }
   
   //Maximum detector velocity in units of c from start of observation time - Tcoh to end of observation + Tcoh
   REAL4 detectorVmax = CompDetectorVmax(inputParams->searchstarttime-inputParams->Tcoh, inputParams->Tcoh, inputParams->SFToverlap, inputParams->Tobs+2.0*inputParams->Tcoh, inputParams->det[0], edat);
   if (xlalErrno!=0) {
      fprintf(stderr, "%s: CompDetectorVmax() failed.\n", __func__);
      XLAL_ERROR(XLAL_EFUNC);
   }
   
   //Assume maximum bin shift possible
   inputParams->maxbinshift = (INT4)round(detectorVmax * (inputParams->fmin+0.5*inputParams->fspan) * inputParams->Tcoh)+1;

   //Read in the T-F data from SFTs
   fprintf(stderr, "Loading in SFTs... ");
   REAL8 tfnormalization = 2.0/inputParams->Tcoh/(args_info.avesqrtSh_arg*args_info.avesqrtSh_arg);
   REAL4Vector *tfdata = readInSFTs(inputParams, &(tfnormalization));
   if (tfdata==NULL) {
      fprintf(stderr, "\n%s: readInSFTs() failed.\n", __func__);
      XLAL_ERROR(XLAL_EFUNC);
   }
   fprintf(stderr, "done\n");
   
   //Removing bad SFTs using K-S test and Kuiper's test
   if (inputParams->markBadSFTs!=0 && inputParams->signalOnly==0) {
      fprintf(stderr, "Marking and removing bad SFTs... ");
      INT4 numffts = (INT4)floor(inputParams->Tobs/(inputParams->Tcoh-inputParams->SFToverlap)-1);    //Number of FFTs
      INT4 numfbins = (INT4)(round(inputParams->fspan*inputParams->Tcoh+2.0*inputParams->dfmax*inputParams->Tcoh)+12+1)+2*inputParams->maxbinshift+inputParams->blksize-1;     //Number of frequency bins
      REAL4Vector *tempvect = XLALCreateREAL4Vector(numfbins);
      if (tempvect==NULL) {
         fprintf(stderr, "%s: XLALCreateREAL4Vector(%d) failed.\n", __func__, numfbins);
         XLAL_ERROR(XLAL_EFUNC);
      }
      REAL8 ksthreshold = 1.358/(sqrt(numfbins)+0.12+0.11/sqrt(numfbins));
      REAL8 kuiperthreshold = 1.747/(sqrt(numfbins)+0.155+0.24/sqrt(numfbins));
      //fprintf(stderr, "%f %f\n", ksthreshold, kuiperthreshold);
      INT4 badsfts = 0, badsfts0 = 0, kuiperoverlap1 = 0, kuiperoverlap2 = 0, totalsfts = 0;
      FILE *OUTPUT = fopen("./output/kskoutput.dat","a");
      for (ii=0; ii<numffts; ii++) {
         if (tfdata->data[ii*numfbins]!=0.0) {
            totalsfts++;
            memcpy(tempvect->data, &(tfdata->data[ii*numfbins]), sizeof(REAL4)*tempvect->length);
            qsort(tempvect->data, tempvect->length, sizeof(REAL4), qsort_REAL4_compar);
            REAL4 vector_median = 0.0;
            if (tempvect->length % 2 != 1) vector_median = 0.5*(tempvect->data[(INT4)(0.5*tempvect->length)-1] + tempvect->data[(INT4)(0.5*tempvect->length)]);
            else vector_median = tempvect->data[(INT4)(0.5*tempvect->length)];
            REAL4 vector_mean = (REAL4)(vector_median/LAL_LN2);

            REAL8 ksvalue = 0.0, testval1, testval2, testval;
            REAL8 oneoverlength = 1.0/tempvect->length;
            for (jj=0; jj<(INT4)tempvect->length; jj++) {
               testval1 = fabs((1.0+jj)*oneoverlength - gsl_cdf_exponential_P(tempvect->data[jj], vector_mean));
               testval2 = fabs(jj*oneoverlength - gsl_cdf_exponential_P(tempvect->data[jj], vector_mean));
               testval = fmax(testval1, testval2);
               if (testval>ksvalue) ksvalue = testval;
            }

            REAL8 loval = 0.0, hival = 0.0;
            for (jj=0; jj<(INT4)tempvect->length; jj++) {
              testval1 = (1.0+jj)*oneoverlength - gsl_cdf_exponential_P(tempvect->data[jj], vector_mean);
              testval2 = jj*oneoverlength - gsl_cdf_exponential_P(tempvect->data[jj], vector_mean);
              if (hival<testval1) hival = testval1;
              if (loval<testval2) loval = testval2;
            }
            REAL8 kuiperval1 = hival + loval;

            loval = -1.0, hival = -1.0;
            for (jj=0; jj<(INT4)tempvect->length; jj++) {
              testval1 = (1.0+jj)*oneoverlength - gsl_cdf_exponential_P(tempvect->data[jj], vector_mean);
              testval2 = jj*oneoverlength - gsl_cdf_exponential_P(tempvect->data[jj], vector_mean);
              if (hival<testval1) hival = testval1;
              if (hival<testval2) hival = testval2;
              if (loval<-testval1) loval = -testval1;
              if (loval<-testval2) loval = -testval2;
            }
            REAL8 kuiperval = hival + loval;

            //fprintf(OUTPUT, "%g %g %g\n", ksvalue, kuiperval1, kuiperval);

            if (ksvalue>ksthreshold || kuiperval1>kuiperthreshold) badsfts0++;
            if (ksvalue>ksthreshold || kuiperval>kuiperthreshold) badsfts++;
            if (kuiperval1>kuiperthreshold && kuiperval>kuiperthreshold) kuiperoverlap1++;
            if (kuiperval1>kuiperthreshold || kuiperval>kuiperthreshold) kuiperoverlap2++;

         }
      }
      fprintf(OUTPUT, "%f %d %d %d %d\n", inputParams->fmin, badsfts0, badsfts, kuiperoverlap1, kuiperoverlap2);
      fclose(OUTPUT);
      fprintf(stderr, "Fraction excluded in K-S and Kuiper's tests = %f\n", (REAL4)badsfts/(REAL4)totalsfts);
      XLALDestroyREAL4Vector(tempvect);
   }

   XLALDestroyREAL4Vector(tfdata);
   XLALDestroyEphemerisData(edat);
   cmdline_parser_free(&args_info);
   free_inputParams(inputParams);

   return 0;

}
Esempio n. 16
0
/**
 * MAIN function
 * Generates samples of B-stat and F-stat according to their pdfs for given signal-params.
 */
int main(int argc,char *argv[])
{
  UserInput_t XLAL_INIT_DECL(uvar);
  ConfigVariables XLAL_INIT_DECL(cfg);		/**< various derived configuration settings */

  vrbflg = 1;	/* verbose error-messages */
  LogSetLevel(lalDebugLevel);

  /* turn off default GSL error handler */
  gsl_set_error_handler_off ();

  /* ----- register and read all user-variables ----- */
  LogSetLevel(lalDebugLevel);

  if ( XLALInitUserVars( &uvar ) != XLAL_SUCCESS ) {
    LogPrintf ( LOG_CRITICAL, "%s: XLALInitUserVars() failed with errno=%d\n", __func__, xlalErrno );
    return 1;
  }

  /* do ALL cmdline and cfgfile handling */
  if ( XLALUserVarReadAllInput ( argc, argv ) != XLAL_SUCCESS ) {
    LogPrintf ( LOG_CRITICAL, "%s: XLALUserVarReadAllInput() failed with errno=%d\n", __func__, xlalErrno );
    return 1;
  }

  if (uvar.help)	/* if help was requested, we're done here */
    return 0;

  if ( uvar.version ) {
    /* output verbose VCS version string if requested */
    CHAR *vcs;
    if ( (vcs = XLALGetVersionString (lalDebugLevel)) == NULL ) {
      LogPrintf ( LOG_CRITICAL, "%s:XLALGetVersionString(%d) failed with errno=%d.\n", __func__, lalDebugLevel, xlalErrno );
      return 1;
    }
    printf ( "%s\n", vcs );
    XLALFree ( vcs );
    return 0;
  }

  /* ---------- Initialize code-setup ---------- */
  if ( XLALInitCode( &cfg, &uvar ) != XLAL_SUCCESS ) {
    LogPrintf (LOG_CRITICAL, "%s: XLALInitCode() failed with error = %d\n", __func__, xlalErrno );
    XLAL_ERROR ( XLAL_EFUNC );
  }

  /* ----- prepare stats output ----- */
  FILE *fpTransientStats = NULL;
  if ( uvar.outputStats )
    {
      if ( (fpTransientStats = fopen (uvar.outputStats, "wb")) == NULL)
	{
	  LogPrintf (LOG_CRITICAL, "Error opening file '%s' for writing..\n\n", uvar.outputStats );
	  XLAL_ERROR ( XLAL_EIO );
	}
      fprintf (fpTransientStats, "%s", cfg.logString );		/* write search log comment */
      if ( write_transientCandidate_to_fp ( fpTransientStats, NULL ) != XLAL_SUCCESS ) { /* write header-line comment */
        XLAL_ERROR ( XLAL_EFUNC );
      }
    } /* if outputStats */

  /* ----- prepare injection params output ----- */
  FILE *fpInjParams = NULL;
  if ( uvar.outputInjParams )
    {
      if ( (fpInjParams = fopen (uvar.outputInjParams, "wb")) == NULL)
	{
	  LogPrintf (LOG_CRITICAL, "Error opening file '%s' for writing..\n\n", uvar.outputInjParams );
	  XLAL_ERROR ( XLAL_EIO );
	}
      fprintf (fpInjParams, "%s", cfg.logString );		/* write search log comment */
      if ( write_InjParams_to_fp ( fpInjParams, NULL, 0, 0, 0 ) != XLAL_SUCCESS ) { /* write header-line comment - options outputMmunuX and numDetectors not supported here, so pass defaults to deactivate them */
        XLAL_ERROR ( XLAL_EFUNC );
      }
    } /* if outputInjParams */

  /* ----- main MC loop over numDraws trials ---------- */
  multiAMBuffer_t XLAL_INIT_DECL(multiAMBuffer);	  /* prepare AM-buffer */
  INT4 i;

  for ( i=0; i < uvar.numDraws; i ++ )
    {
      InjParams_t XLAL_INIT_DECL(injParamsDrawn);

      /* ----- generate signal random draws from ranges and generate Fstat atoms */
      MultiFstatAtomVector *multiAtoms;
      multiAtoms = XLALSynthesizeTransientAtoms ( &injParamsDrawn, cfg.skypos, cfg.AmpPrior, cfg.transientInjectRange, cfg.multiDetStates, cfg.SignalOnly, &multiAMBuffer, cfg.rng, -1, NULL ); // options lineX and noise_weights not supported here, so pass defaults to deactivate them
      if ( multiAtoms ==NULL ) {
        LogPrintf ( LOG_CRITICAL, "%s: XLALSynthesizeTransientAtoms() failed with xlalErrno = %d\n", __func__, xlalErrno );
        XLAL_ERROR ( XLAL_EFUNC );
      }

      /* ----- if requested, output signal injection parameters into file */
      if ( fpInjParams && (write_InjParams_to_fp ( fpInjParams, &injParamsDrawn, uvar.dataStartGPS, 0, 0 ) ) != XLAL_SUCCESS ) { // options outputMmunuX and numDetectors not supported here, so pass defaults to deactivate them
        XLAL_ERROR ( XLAL_EFUNC );
      } /* if fpInjParams & failure*/


      /* ----- add meta-info on current transient-CW candidate */
      transientCandidate_t XLAL_INIT_DECL(cand);
      cand.doppler.Alpha = multiAMBuffer.skypos.longitude;
      cand.doppler.Delta = multiAMBuffer.skypos.latitude;
      cand.windowRange   = cfg.transientSearchRange;

      /* ----- if needed: compute transient-Bstat search statistic on these atoms */
      if ( fpTransientStats || uvar.outputFstatMap || uvar.outputPosteriors )
        {
          /* compute Fstat map F_mn over {t0, tau} */
          if ( (cand.FstatMap = XLALComputeTransientFstatMap ( multiAtoms, cand.windowRange, uvar.useFReg)) == NULL ) {
            XLALPrintError ("%s: XLALComputeTransientFstatMap() failed with xlalErrno = %d.\n", __func__, xlalErrno );
            XLAL_ERROR ( XLAL_EFUNC );
          }
        } /* if we'll need the Fstat-map F_mn */

      /* ----- if requested compute marginalized Bayes factor */
      if ( fpTransientStats )
        {
          cand.logBstat = XLALComputeTransientBstat ( cand.windowRange, cand.FstatMap );
          UINT4 err = xlalErrno;
          if ( err ) {
            XLALPrintError ("%s: XLALComputeTransientBstat() failed with xlalErrno = %d\n", __func__, err );
            XLAL_ERROR ( XLAL_EFUNC );
          }

          if ( uvar.SignalOnly )
            {
              cand.FstatMap->maxF += 2;
              cand.logBstat += 2;
            }

        } /* if Bstat requested */

      /* ----- if requested, compute parameter posteriors for {t0, tau} */
      pdf1D_t *pdf_t0  = NULL;
      pdf1D_t *pdf_tau = NULL;
      if ( fpTransientStats || uvar.outputPosteriors )
        {
          if ( (pdf_t0 = XLALComputeTransientPosterior_t0 ( cand.windowRange, cand.FstatMap )) == NULL ) {
            XLALPrintError ("%s: failed to compute t0-posterior\n", __func__ );
            XLAL_ERROR ( XLAL_EFUNC );
          }
          if ( (pdf_tau = XLALComputeTransientPosterior_tau ( cand.windowRange, cand.FstatMap )) == NULL ) {
            XLALPrintError ("%s: failed to compute tau-posterior\n", __func__ );
            XLAL_ERROR ( XLAL_EFUNC );
          }
          /* get maximum-posterior estimate (MP) from the modes of these pdfs */
          cand.t0_MP = XLALFindModeOfPDF1D ( pdf_t0 );
          if ( xlalErrno ) {
            XLALPrintError ("%s: mode-estimation failed for pdf_t0. xlalErrno = %d\n", __func__, xlalErrno );
            XLAL_ERROR ( XLAL_EFUNC );
          }
          cand.tau_MP =  XLALFindModeOfPDF1D ( pdf_tau );
          if ( xlalErrno ) {
            XLALPrintError ("%s: mode-estimation failed for pdf_tau. xlalErrno = %d\n", __func__, xlalErrno );
            XLAL_ERROR ( XLAL_EFUNC );
          }

        } // if posteriors required

      /* ----- if requested, compute Ftotal over full data-span */
      if ( uvar.computeFtotal )
        {
          transientFstatMap_t *FtotalMap;
          /* prepare special window to cover all the data with one F-stat calculation == Ftotal */
          transientWindowRange_t XLAL_INIT_DECL(winRangeAll);
          winRangeAll.type = TRANSIENT_NONE;

          BOOLEAN useFReg = false;
          if ( (FtotalMap = XLALComputeTransientFstatMap ( multiAtoms, winRangeAll, useFReg)) == NULL ) {
            XLALPrintError ("%s: XLALComputeTransientFstatMap() failed with xlalErrno = %d.\n", __func__, xlalErrno );
            XLAL_ERROR ( XLAL_EFUNC );
          }

          /* we only use twoFtotal = 2 * maxF from this single-Fstat calculation */
          REAL8 twoFtotal = 2.0 * FtotalMap->maxF;
          if ( uvar.SignalOnly )
            twoFtotal += 4;

          /* ugly hack: lacking a good container for twoFtotal, we borrow fkdot[3] for this here ;) [only used for paper-MCs] */
          cand.doppler.fkdot[3] = twoFtotal;

          /* good riddance .. */
          XLALDestroyTransientFstatMap ( FtotalMap );

        } /* if computeFtotal */

      /* ----- if requested, output atoms-vector into file */
      if ( uvar.outputAtoms )
        {

          FILE *fpAtoms;
          char *fnameAtoms;
          UINT4 len = strlen ( uvar.outputAtoms ) + 20;
          if ( (fnameAtoms = XLALCalloc ( 1, len )) == NULL ) {
            XLALPrintError ("%s: failed to XLALCalloc ( 1, %d )\n", __func__, len );
            XLAL_ERROR ( XLAL_EFUNC );
          }
          sprintf ( fnameAtoms, "%s_%04d_of_%04d.dat", uvar.outputAtoms, i + 1, uvar.numDraws );

          if ( ( fpAtoms = fopen ( fnameAtoms, "wb" )) == NULL ) {
            XLALPrintError ("%s: failed to open atoms-output file '%s' for writing.\n", __func__, fnameAtoms );
            XLAL_ERROR ( XLAL_EFUNC );
          }
	  fprintf ( fpAtoms, "%s", cfg.logString );	/* output header info */

	  if ( write_MultiFstatAtoms_to_fp ( fpAtoms, multiAtoms ) != XLAL_SUCCESS ) {
            XLALPrintError ("%s: failed to write atoms to output file '%s'. xlalErrno = %d\n", __func__, fnameAtoms, xlalErrno );
            XLAL_ERROR ( XLAL_EFUNC );
          }

          XLALFree ( fnameAtoms );
	  fclose (fpAtoms);
        } /* if outputAtoms */

      /* ----- if requested, output Fstat-map over {t0, tau} */
      if ( uvar.outputFstatMap )
        {
          FILE *fpFstatMap;
          char *fnameFstatMap;
          UINT4 len = strlen ( uvar.outputFstatMap ) + 20;
          if ( (fnameFstatMap = XLALCalloc ( 1, len )) == NULL ) {
            XLALPrintError ("%s: failed to XLALCalloc ( 1, %d )\n", __func__, len );
            XLAL_ERROR ( XLAL_EFUNC );
          }
          sprintf ( fnameFstatMap, "%s_%04d_of_%04d.dat", uvar.outputFstatMap, i + 1, uvar.numDraws );

          if ( ( fpFstatMap = fopen ( fnameFstatMap, "wb" )) == NULL ) {
            XLALPrintError ("%s: failed to open Fstat-map output file '%s' for writing.\n", __func__, fnameFstatMap );
            XLAL_ERROR ( XLAL_EFUNC );
          }
	  fprintf ( fpFstatMap, "%s", cfg.logString );	/* output header info */

          fprintf (fpFstatMap, "\nFstat_mn = \\\n" );
          if ( XLALfprintfGSLmatrix ( fpFstatMap, "%.9g", cand.FstatMap->F_mn ) != XLAL_SUCCESS ) {
            XLALPrintError ("%s: XLALfprintfGSLmatrix() failed.\n", __func__ );
            XLAL_ERROR ( XLAL_EFUNC );
          }

          XLALFree ( fnameFstatMap );
	  fclose (fpFstatMap);

        } /* if outputFstatMap */

      /* ----- if requested, output posterior pdfs on transient params {t0, tau} into a file */
      if ( uvar.outputPosteriors )
        {
          FILE *fpPosteriors;
          char *fnamePosteriors;
          UINT4 len = strlen ( uvar.outputPosteriors ) + 20;
          if ( (fnamePosteriors = XLALCalloc ( 1, len )) == NULL ) {
            XLALPrintError ("%s: failed to XLALCalloc ( 1, %d )\n", __func__, len );
            XLAL_ERROR ( XLAL_EFUNC );
          }
          sprintf ( fnamePosteriors, "%s_%04d_of_%04d.dat", uvar.outputPosteriors, i + 1, uvar.numDraws );

          if ( ( fpPosteriors = fopen ( fnamePosteriors, "wb" )) == NULL ) {
            XLALPrintError ("%s: failed to open posteriors-output file '%s' for writing.\n", __func__, fnamePosteriors );
            XLAL_ERROR ( XLAL_EFUNC );
          }
	  fprintf ( fpPosteriors, "%s", cfg.logString );	/* output header info */

          /* write them to file, using pdf-method */
	  if ( XLALOutputPDF1D_to_fp ( fpPosteriors, pdf_t0, "pdf_t0" ) != XLAL_SUCCESS ) {
            XLALPrintError ("%s: failed to output t0-posterior to file '%s'.\n", __func__, fnamePosteriors );
            XLAL_ERROR ( XLAL_EFUNC );
          }
	  if ( XLALOutputPDF1D_to_fp ( fpPosteriors, pdf_tau, "pdf_tau" ) != XLAL_SUCCESS ) {
            XLALPrintError ("%s: failed to output tau-posterior to file '%s'.\n", __func__, fnamePosteriors );
            XLAL_ERROR ( XLAL_EFUNC );
          }

          /* free mem, close file */
          XLALFree ( fnamePosteriors );
	  fclose (fpPosteriors);

        } /* if outputPosteriors */


      /* ----- if requested, output transient-cand statistics */
      if ( fpTransientStats && write_transientCandidate_to_fp ( fpTransientStats, &cand ) != XLAL_SUCCESS ) {
        XLALPrintError ( "%s: write_transientCandidate_to_fp() failed.\n", __func__ );
        XLAL_ERROR ( XLAL_EFUNC );
      }

      /* ----- free Memory */
      XLALDestroyTransientFstatMap ( cand.FstatMap );
      XLALDestroyMultiFstatAtomVector ( multiAtoms );
      XLALDestroyPDF1D ( pdf_t0 );
      XLALDestroyPDF1D ( pdf_tau );

    } /* for i < numDraws */

  /* ----- close files ----- */
  if ( fpTransientStats) fclose ( fpTransientStats );
  if ( fpInjParams ) fclose ( fpInjParams );

  /* ----- free memory ---------- */
  XLALDestroyMultiDetectorStateSeries ( cfg.multiDetStates );
  XLALDestroyMultiAMCoeffs ( multiAMBuffer.multiAM );
  XLALDestroyExpLUT();
  /* ----- free amplitude prior pdfs ----- */
  XLALDestroyPDF1D ( cfg.AmpPrior.pdf_h0Nat );
  XLALDestroyPDF1D ( cfg.AmpPrior.pdf_cosi );
  XLALDestroyPDF1D ( cfg.AmpPrior.pdf_psi );
  XLALDestroyPDF1D ( cfg.AmpPrior.pdf_phi0 );

  if ( cfg.logString ) XLALFree ( cfg.logString );
  gsl_rng_free ( cfg.rng );

  XLALDestroyUserVars();

  /* did we forget anything ? (doesn't cover gsl-memory!) */
  LALCheckMemoryLeaks();

  return 0;

} /* main() */
char* oph_gsl_ifft(UDF_INIT *initid, UDF_ARGS *args, char *result, unsigned long *length, char *is_null, char *error)
{
	if (*error)
	{
	        *length=0;
	        *is_null=0;
	        *error=1;
	        return NULL;
	}
	if (*is_null || !args->lengths[2])
	{
	        *length=0;
	        *is_null=1;
	        *error=0;
	        return NULL;
	}

    if (!initid->ptr) {

        initid->ptr=(char *)calloc(1,sizeof(oph_string));
        if(!initid->ptr){
            pmesg(1,  __FILE__, __LINE__, "Error allocating result\n");
            *length=0;
            *is_null=1;
            *error=1;
            return NULL;
        }

        oph_stringPtr output = (oph_stringPtr) initid->ptr;

        core_set_type(output,args->args[1],&(args->lengths[1]));
        if (output->type!=OPH_COMPLEX_DOUBLE) {
        	pmesg(1,  __FILE__, __LINE__, "Invalid type: oph_complex_double required\n");
        	*length=0;
        	*is_null=1;
        	*error=1;
        	return NULL;
        }

        core_set_type(output,args->args[0],&(args->lengths[0]));
        if (output->type!=OPH_COMPLEX_DOUBLE) {
        	pmesg(1,  __FILE__, __LINE__, "Invalid type: oph_complex_double or oph_double required\n");
        	*length=0;
        	*is_null=1;
        	*error=1;
        	return NULL;
        }

        output->length = (unsigned long *)calloc(1,sizeof(unsigned long));
        if (!output->length) {
            pmesg(1,  __FILE__, __LINE__, "Error allocating length\n");
            *length=0;
            *is_null=1;
            *error=1;
            return NULL;
        }

        *(output->length) = args->lengths[2];

        if(core_set_elemsize(output)){
            pmesg(1,  __FILE__, __LINE__, "Error on setting element size\n");
            *length=0;
            *is_null=0;
            *error=1;
            return NULL;
        }

        if(core_set_numelem(output)){
            pmesg(1,  __FILE__, __LINE__, "Error on counting result elements\n");
            *length=0;
            *is_null=0;
            *error=1;
            return NULL;
        }

        output->content = (char *)calloc(1,*(output->length));
        if(!output->content){
            pmesg(1,  __FILE__, __LINE__, "Error allocating result string\n");
            *length=0;
            *is_null=1;
            *error=1;
            return NULL;
        }

        initid->extension = calloc(1,sizeof(oph_gsl_fft_extraspace));
        if (!initid->extension) {
            pmesg(1,  __FILE__, __LINE__, "Error allocating extra space\n");
            *length=0;
            *is_null=1;
            *error=1;
            return NULL;
        }

        oph_gsl_fft_extraspace *extra = (oph_gsl_fft_extraspace *) initid->extension;

        extra->wt = gsl_fft_complex_wavetable_alloc(output->numelem);
        if (!extra->wt) {
            pmesg(1,  __FILE__, __LINE__, "Error allocating wavetable\n");
            *length=0;
            *is_null=1;
            *error=1;
            return NULL;
        }

        extra->ws = gsl_fft_complex_workspace_alloc(output->numelem);
        if (!extra->ws) {
            pmesg(1,  __FILE__, __LINE__, "Error allocating workspace\n");
            *length=0;
            *is_null=1;
            *error=1;
            return NULL;
        }

    }

    oph_stringPtr output = (oph_stringPtr) initid->ptr;
    oph_gsl_fft_extraspace *extra = (oph_gsl_fft_extraspace *) initid->extension;

    gsl_set_error_handler_off();

    memcpy(output->content,args->args[2],*(output->length));
    if (gsl_fft_complex_inverse((gsl_complex_packed_array) output->content,1,output->numelem,extra->wt,extra->ws)) {
        pmesg(1,  __FILE__, __LINE__, "Error computing ifft\n");
        *length=0;
        *is_null=1;
        *error=1;
        return NULL;
    }

    *length = *(output->length);
    *error=0;
    *is_null=0;

    return output->content;
}
Esempio n. 18
0
void initialise() { gsl_set_error_handler_off(); }
Esempio n. 19
0
/**
 * The settle function computes the steady state nearest the initial
 * conditions.
 */
void SteadyState::settle( bool forceSetup )
{
#ifdef USE_GSL
	gsl_set_error_handler_off();
	
	if ( !isInitialized_ ) {
		cout << "Error: SteadyState object has not been initialized. No calculations done\n";
		return;
	}
	if ( forceSetup || isSetup_ == 0 ) {
		setupSSmatrix();
	}

	// Setting up matrices and vectors for the calculation.
	unsigned int nConsv = numVarPools_ - rank_;
	double * T = (double *) calloc( nConsv, sizeof( double ) );

	unsigned int i, j;


	Id ksolve = Field< Id >::get( stoich_, "ksolve" );
	struct reac_info ri;
	ri.rank = rank_;
	ri.num_reacs = nReacs_;
	ri.num_mols = numVarPools_;
	ri.T = T;
	ri.Nr = Nr_;
	ri.gamma = gamma_;
	ri.stoich = stoich_;
	ri.nVec = 
			LookupField< unsigned int, vector< double > >::get(
			ksolve,"nVec", 0 );
	ri.convergenceCriterion = convergenceCriterion_;

	// Fill up boundary condition values
	if ( reassignTotal_ ) { // The user has defined new conservation values.
		for ( i = 0; i < nConsv; ++i )
			T[i] = total_[i];
		reassignTotal_ = 0;
	} else {
		for ( i = 0; i < nConsv; ++i )
			for ( j = 0; j < numVarPools_; ++j )
				T[i] += gsl_matrix_get( gamma_, i, j ) * ri.nVec[ j ];
		total_.assign( T, T + nConsv );
	}

	vector< double > repair( numVarPools_, 0.0 );
	for ( unsigned int j = 0; j < numVarPools_; ++j )
		repair[j] = ri.nVec[j];

	int status = iterate( gsl_multiroot_fsolver_hybrids, &ri, maxIter_ );
	if ( status ) // It failed. Fall back with the Newton method
		status = iterate( gsl_multiroot_fsolver_dnewton, &ri, maxIter_ );
	status_ = string( gsl_strerror( status ) );
	nIter_ = ri.nIter;
	if ( status == GSL_SUCCESS ) {
		solutionStatus_ = 0; // Good solution
		LookupField< unsigned int, vector< double > >::set(
			ksolve,"nVec", 0, ri.nVec );
		classifyState( T );
		/*
		 * Should happen in the ss_func.
		for ( i = 0; i < numVarPools_; ++i )
			s_->S()[i] = gsl_vector_get( op( solver->x ), i );
			*/
	} else {
		cout << "Warning: SteadyState iteration failed, status = " <<
			status_ << ", nIter = " << nIter_ << endl;
		// Repair the mess
		for ( unsigned int j = 0; j < numVarPools_; ++j )
			ri.nVec[j] = repair[j];
		solutionStatus_ = 1; // Steady state failed.
		LookupField< unsigned int, vector< double > >::set(
			ksolve,"nVec", 0, ri.nVec );
	}

	// Clean up.
	free( T );
#endif
}
Esempio n. 20
0
gsl_multimin_fminimizer * Fit::fitSimplex(gsl_multimin_function f, int &iterations, int &status)
{
	const gsl_multimin_fminimizer_type *T = gsl_multimin_fminimizer_nmsimplex2;

	//size of the simplex
	gsl_vector *ss;
	//initial vertex size vector
	ss = gsl_vector_alloc (f.n);
	//set all step sizes to 1 can be increased to converge faster
	gsl_vector_set_all (ss, 10.0);

	gsl_set_error_handler_off();

	gsl_multimin_fminimizer *s_min = gsl_multimin_fminimizer_alloc (T, f.n);
	status = gsl_multimin_fminimizer_set (s_min, &f, d_param_init, ss);

	double size;
	size_t iter = 0;
	bool inRange = true;
	for (int i=0; i<d_p; i++){
		double p = gsl_vector_get(d_param_init, i);
		d_results[i] = p;
		if (p < d_param_range_left[i] || p > d_param_range_right[i]){
			inRange = false;
			break;
		}
	}

	if (status) {
	    iterations = 0;
	    gsl_vector_free(ss);
	    return s_min;
	}

	do{
		iter++;
		status = gsl_multimin_fminimizer_iterate (s_min);

		if (status)
			break;

        for (int i=0; i<d_p; i++){
			double p = gsl_vector_get(s_min->x, i);
			if (p < d_param_range_left[i] || p > d_param_range_right[i]){
				inRange = false;
				break;
			}
		}
		if (!inRange)
			break;

		for (int i=0; i<d_p; i++)
			d_results[i] = gsl_vector_get(s_min->x, i);

		size = gsl_multimin_fminimizer_size (s_min);
		status = gsl_multimin_test_size (size, d_tolerance);
	}
	while (inRange && status == GSL_CONTINUE && (int)iter < d_max_iterations);

	iterations = iter;
	gsl_vector_free(ss);
	return s_min;
}
Esempio n. 21
0
/**
 * MAIN function
 * Generates samples of B-stat and F-stat according to their pdfs for given signal-params.
 */
int main(int argc,char *argv[])
{
  UserInput_t XLAL_INIT_DECL(uvar);
  ConfigVariables XLAL_INIT_DECL(cfg);

  vrbflg = 1;	/* verbose error-messages */

  /* turn off default GSL error handler */
  gsl_set_error_handler_off ();

  /* ----- register and read all user-variables ----- */
  if ( XLALInitUserVars( &uvar ) != XLAL_SUCCESS ) {
    LogPrintf ( LOG_CRITICAL, "%s: XLALInitUserVars() failed with errno=%d\n", __func__, xlalErrno );
    return 1;
  }

  /* do ALL cmdline and cfgfile handling */
  BOOLEAN should_exit = 0;
  if ( XLALUserVarReadAllInput ( &should_exit, argc, argv ) != XLAL_SUCCESS ) {
    LogPrintf ( LOG_CRITICAL, "%s: XLALUserVarReadAllInput() failed with errno=%d\n", __func__, xlalErrno );
    return 1;
  }
  if ( should_exit )
    return EXIT_FAILURE;

  if ( uvar.version ) {
    /* output verbose VCS version string if requested */
    CHAR *vcs;
    if ( (vcs = XLALGetVersionString (lalDebugLevel)) == NULL ) {
      LogPrintf ( LOG_CRITICAL, "%s:XLALGetVersionString(%d) failed with errno=%d.\n", __func__, lalDebugLevel, xlalErrno );
      return 1;
    }
    printf ( "%s\n", vcs );
    XLALFree ( vcs );
    return 0;
  }

  /* ---------- Initialize code-setup ---------- */
  if ( XLALInitCode( &cfg, &uvar ) != XLAL_SUCCESS ) {
    LogPrintf (LOG_CRITICAL, "%s: XLALInitCode() failed with error = %d\n", __func__, xlalErrno );
    XLAL_ERROR ( XLAL_EFUNC );
  }

  /* compare IFO name for line injection with IFO list, find the corresponding index, or throw an error if not found */
  UINT4 numDetectors = cfg.multiDetStates->length;
  INT4 lineX = -1;
  if ( uvar.lineIFO ) {
    for ( UINT4 X=0; X < numDetectors; X++ ) {
      if ( strcmp( uvar.lineIFO, uvar.IFOs->data[X] ) == 0 )
        lineX = X;
    }
    if ( lineX == -1 ) {
      XLALPrintError ("\nError in function %s, line %d : Could not match detector ID \"%s\" for line injection to any detector.\n\n", __func__, __LINE__, uvar.lineIFO);
      XLAL_ERROR ( XLAL_EFAILED );
    }
  }

  /* ----- prepare stats output ----- */
  FILE *fpStats = NULL;
  if ( uvar.outputStats )
    {
      if ( (fpStats = fopen (uvar.outputStats, "wb")) == NULL)
	{
	  LogPrintf (LOG_CRITICAL, "Error opening file '%s' for writing..\n\n", uvar.outputStats );
	  XLAL_ERROR ( XLAL_EIO );
	}
      fprintf (fpStats, "%s", cfg.logString );		/* write search log comment */
      if ( write_BSGL_candidate_to_fp ( fpStats, NULL, uvar.IFOs, NULL, uvar.computeBSGL ) != XLAL_SUCCESS ) { /* write header-line comment */
        XLAL_ERROR ( XLAL_EFUNC );
      }
    } /* if outputStats */

  /* ----- prepare injection params output ----- */
  FILE *fpInjParams = NULL;
  if ( uvar.outputInjParams )
    {
      if ( (fpInjParams = fopen (uvar.outputInjParams, "wb")) == NULL)
	{
	  LogPrintf (LOG_CRITICAL, "Error opening file '%s' for writing..\n\n", uvar.outputInjParams );
	  XLAL_ERROR ( XLAL_EIO );
	}
      fprintf (fpInjParams, "%s", cfg.logString );		/* write search log comment */
      if ( write_InjParams_to_fp ( fpInjParams, NULL, 0, uvar.outputMmunuX, numDetectors ) != XLAL_SUCCESS ) { /* write header-line comment */
        XLAL_ERROR ( XLAL_EFUNC );
      }
    } /* if outputInjParams */

  multiAMBuffer_t XLAL_INIT_DECL(multiAMBuffer);      /* prepare AM-buffer */

  /* ----- prepare BSGL computation */
  BSGLSetup *BSGLsetup = NULL;
  if ( uvar.computeBSGL )
    {
      BOOLEAN useLogCorrection = TRUE;
      REAL4 *oLGX_p = NULL;
      REAL4 oLGX[PULSAR_MAX_DETECTORS];
      if ( uvar.oLGX != NULL )
        {
          XLAL_CHECK ( uvar.oLGX->length == numDetectors, XLAL_EINVAL, "Invalid input: length(oLGX) = %d differs from number of detectors (%d)'\n", uvar.oLGX->length, numDetectors );
          XLAL_CHECK ( XLALParseLinePriors ( &oLGX[0], uvar.oLGX ) == XLAL_SUCCESS, XLAL_EFUNC );
          oLGX_p = &oLGX[0];
        }
      XLAL_CHECK ( ( BSGLsetup = XLALCreateBSGLSetup ( numDetectors, uvar.Fstar0, oLGX_p, useLogCorrection ) ) != NULL, XLAL_EFUNC );
    } // if computeBSGL

  /* ----- main MC loop over numDraws trials ---------- */
  INT4 i;
  for ( i=0; i < uvar.numDraws; i ++ )
    {
      InjParams_t XLAL_INIT_DECL(injParamsDrawn);

      /* ----- generate signal random draws from ranges and generate Fstat atoms */
      MultiFstatAtomVector *multiAtoms;

      multiAtoms = XLALSynthesizeTransientAtoms ( &injParamsDrawn, cfg.skypos, cfg.AmpPrior, cfg.transientInjectRange, cfg.multiDetStates, cfg.SignalOnly, &multiAMBuffer, cfg.rng, lineX, cfg.multiNoiseWeights );
      XLAL_CHECK ( multiAtoms != NULL, XLAL_EFUNC );

      /* ----- if requested, output signal injection parameters into file */
      if ( fpInjParams && (write_InjParams_to_fp ( fpInjParams, &injParamsDrawn, uvar.dataStartGPS, uvar.outputMmunuX, numDetectors ) != XLAL_SUCCESS ) ) {
        XLAL_ERROR ( XLAL_EFUNC );
      } /* if fpInjParams & failure*/

      /* initialise BSGLComponents structure and allocate memory */
      BSGLComponents XLAL_INIT_DECL(synthStats); /* struct containing multi-detector Fstat, single-detector Fstats, line-robust stat */
      synthStats.numDetectors = numDetectors;

      /* compute F- and BSGListics from atoms */
      UINT4 X;
      for ( X=0; X < numDetectors; X++ )    {
        synthStats.TwoFX[X] = XLALComputeFstatFromAtoms ( multiAtoms, X );
        if ( xlalErrno != 0 ) {
          XLALPrintError ("\nError in function %s, line %d : Failed call to XLALComputeFstatFromAtoms().\n\n", __func__, __LINE__);
          XLAL_ERROR ( XLAL_EFUNC );
        }
      }

      synthStats.TwoF = XLALComputeFstatFromAtoms ( multiAtoms, -1 );
      if ( xlalErrno != 0 ) {
        XLALPrintError ("\nError in function %s, line %d : Failed call to XLALComputeFstatFromAtoms().\n\n", __func__, __LINE__);
        XLAL_ERROR ( XLAL_EFUNC );
      }

      if ( uvar.computeBSGL ) {
        synthStats.log10BSGL = XLALComputeBSGL ( synthStats.TwoF, synthStats.TwoFX, BSGLsetup );
        XLAL_CHECK ( xlalErrno == 0, XLAL_EFUNC, "XLALComputeBSGL() failed with xlalErrno = %d\n", xlalErrno );
      }

      /* ----- if requested, output atoms-vector into file */
      if ( uvar.outputAtoms )
        {

          FILE *fpAtoms;
          char *fnameAtoms;
          UINT4 len = strlen ( uvar.outputAtoms ) + 20;
          if ( (fnameAtoms = XLALCalloc ( 1, len )) == NULL ) {
            XLALPrintError ("%s: failed to XLALCalloc ( 1, %d )\n", __func__, len );
            XLAL_ERROR ( XLAL_EFUNC );
          }
          sprintf ( fnameAtoms, "%s_%04d_of_%04d.dat", uvar.outputAtoms, i + 1, uvar.numDraws );

          if ( ( fpAtoms = fopen ( fnameAtoms, "wb" )) == NULL ) {
            XLALPrintError ("%s: failed to open atoms-output file '%s' for writing.\n", __func__, fnameAtoms );
            XLAL_ERROR ( XLAL_EFUNC );
          }
	  fprintf ( fpAtoms, "%s", cfg.logString );	/* output header info */

	  if ( write_MultiFstatAtoms_to_fp ( fpAtoms, multiAtoms ) != XLAL_SUCCESS ) {
            XLALPrintError ("%s: failed to write atoms to output file '%s'. xlalErrno = %d\n", __func__, fnameAtoms, xlalErrno );
            XLAL_ERROR ( XLAL_EFUNC );
          }

          XLALFree ( fnameAtoms );
	  fclose (fpAtoms);
        } /* if outputAtoms */


      /* ----- if requested, output transient-cand statistics */
      if ( fpStats && write_BSGL_candidate_to_fp ( fpStats, &synthStats, uvar.IFOs, &injParamsDrawn, uvar.computeBSGL ) != XLAL_SUCCESS ) {
        XLALPrintError ( "%s: write_transientCandidate_to_fp() failed.\n", __func__ );
        XLAL_ERROR ( XLAL_EFUNC );
      }

      /* ----- free Memory */
      XLALDestroyMultiFstatAtomVector ( multiAtoms );

    } /* for i < numDraws */

  /* ----- close files ----- */
  if ( fpStats ) fclose ( fpStats );
  if ( fpInjParams ) fclose ( fpInjParams );

  /* ----- free memory ---------- */
  XLALDestroyMultiDetectorStateSeries ( cfg.multiDetStates );
  XLALDestroyMultiNoiseWeights ( cfg.multiNoiseWeights );
  XLALDestroyExpLUT();
  XLALDestroyMultiAMCoeffs ( multiAMBuffer.multiAM );
  /* ----- free amplitude prior pdfs ----- */
  XLALDestroyPDF1D ( cfg.AmpPrior.pdf_h0Nat );
  XLALDestroyPDF1D ( cfg.AmpPrior.pdf_cosi );
  XLALDestroyPDF1D ( cfg.AmpPrior.pdf_psi );
  XLALDestroyPDF1D ( cfg.AmpPrior.pdf_phi0 );

  XLALFree ( BSGLsetup );
  BSGLsetup = NULL;

  if ( cfg.logString ) {
    XLALFree ( cfg.logString );
  }
  gsl_rng_free ( cfg.rng );

  XLALDestroyUserVars();

  /* did we forget anything ? (doesn't cover gsl-memory!) */
  LALCheckMemoryLeaks();

  return 0;

} /* main() */
Esempio n. 22
0
int PoissonGlm::betaEst( unsigned int id, unsigned int iter, double *tol, double th)
{
   gsl_set_error_handler_off();
   int status, isValid;
  // unsigned int j, ngoodobs;
   unsigned int i, step, step1; 
   double wij, zij, eij, mij, yij; //, bij;   
   double dev_old, dev_grad=1.0;
   gsl_vector_view Xwi;
   gsl_matrix *WX, *XwX;
   gsl_vector *z, *Xwz;
   gsl_vector *coef_old = gsl_vector_alloc(nParams);
   gsl_vector_view bj=gsl_matrix_column (Beta, id);

   // Main Loop of IRLS begins
   z = gsl_vector_alloc(nRows);
   WX = gsl_matrix_alloc(nRows, nParams); 
   XwX = gsl_matrix_alloc(nParams, nParams);
   Xwz = gsl_vector_alloc(nParams);
   step=0;
   *tol = 1.0;
   gsl_vector_memcpy (coef_old, &bj.vector);
   while ( step<iter ) {
       for (i=0; i<nRows; i++) { // (y-m)/g'
           yij = gsl_matrix_get(Yref, i, id);
           eij = gsl_matrix_get(Eta, i, id);
           mij = gsl_matrix_get(Mu, i, id);
        //   if (mij<mintol) mij=mintol;
        //   if (mij>maxtol) mij=maxtol;
           zij = eij + (yij-mij)*LinkDash(mij);
           if (Oref!=NULL) 
              zij = zij - gsl_matrix_get(Oref, i, id);
           // wt=sqrt(weifunc);
           wij = sqrt(weifunc(mij, th));
           // W^1/2*z[good]
           gsl_vector_set(z, i, wij*zij); 
           // W^1/2*X[good]
           Xwi = gsl_matrix_row (Xref, i);
           gsl_matrix_set_row (WX, i, &Xwi.vector);
           Xwi = gsl_matrix_row (WX, i);
           gsl_vector_scale(&Xwi.vector, wij); 
       }
       // in glm2, solve WXb=Wz, David suggested not good 
       // So back to solving X'WXb=X'Wz
       gsl_matrix_set_identity (XwX);
       gsl_blas_dsyrk (CblasLower,CblasTrans,1.0,WX,0.0,XwX); 
       status=gsl_linalg_cholesky_decomp(XwX);
       if (status==GSL_EDOM) {
          if (mmRef->warning==TRUE) {
             printf("Warning: singular matrix in betaEst: ");
             gsl_matrix_set_identity (XwX); 
             gsl_blas_dsyrk (CblasLower,CblasTrans,1.0,Xref,0.0,XwX);
          //  displaymatrix(Xref, "Xref");
	  // displaymatrix(XwX, "XX^T");
          //   printf("calc(XX')=%.8f\n", calcDet(XwX)); 
             status=gsl_linalg_cholesky_decomp(XwX);
             if (status==GSL_EDOM)  
                printf("X^TX is singular - check case resampling or input design matrix!\n");
             else {
                for (i=0; i<nRows; i++) {
                   mij = gsl_matrix_get(Mu, i, id);
                   wij = sqrt(weifunc(mij, th));
                   if (wij<mintol) printf("weight[%d, %d]=%.4f is too close to zero\n", i, id, wij);
                }
             } 
             printf("An eps*I is added to the singular matrix.\n");
          }
          gsl_matrix_set_identity (XwX);
          gsl_blas_dsyrk (CblasLower,CblasTrans,1.0,WX,mintol,XwX); 
          gsl_linalg_cholesky_decomp(XwX);
       }
       gsl_blas_dgemv(CblasTrans,1.0,WX,z,0.0,Xwz);
       gsl_linalg_cholesky_solve (XwX, Xwz, &bj.vector);

   // Debug for nan
/*   if (gsl_vector_get(&bj.vector, 1)!=gsl_vector_get(&bj.vector, 1)) {
       displayvector(&bj.vector, "bj");
       displayvector(z, "z");
       gsl_vector_view mj=gsl_matrix_column(Mu, id);
       displayvector(&mj.vector, "mj");
       printf("weight\n");
       for (i=0; i<nRows; i++){
           printf("%.4f ", sqrt(weifunc(mij, th)));
       }
       printf("\n");
       displaymatrix(XwX, "XwX");
       exit(-1);
   }   
*/
       // Given bj, update eta, mu
       dev_old = dev[id];
       isValid=predict(bj, id, th);
       dev_grad=(dev[id]-dev_old)/(ABS(dev[id])+0.1);
       *(tol)=ABS(dev_grad);  

       step1 = 0;
       // If divergent or increasing deviance, half step
       // (step>1) -> (step>0) gives weired results for NBin fit       
       // below works for boundary values, esp BIN fit but not NBin fit
       while ((dev_grad>eps)&(step>1)){
            gsl_vector_add (&bj.vector, coef_old);
            gsl_vector_scale (&bj.vector, 0.5);
       //     dev_old=dev[id];
            isValid=predict(bj, id, th);
            dev_grad=(dev[id]-dev_old)/(ABS(dev[id])+0.1); 
            *tol=ABS(dev_grad);
            if (*tol<eps) break;
            step1++;
            if (step1>10) {
            //   printf("\t Half step stopped at iter %d: gradient=%.8f\n", step1, dev_grad);
               break;
            }
       }
       if (isValid==TRUE) gsl_vector_memcpy (coef_old, &bj.vector);
      
       step++;
       if (*tol<eps) break;
   } 

   gsl_vector_free(z);
   gsl_matrix_free(WX); 
   gsl_matrix_free(XwX); 
   gsl_vector_free(Xwz); 
   gsl_vector_free(coef_old); 

   return step;
}
Esempio n. 23
0
int main( int argc, char **argv )
{
    // We use a GSL special function to compute binomial cdfs.  
    // Turn off the GSL error handler so we can trap those errors ourself.
    gsl_set_error_handler_off();

    // Set defaults program input values
    hotspot::numSD = hotspot::HotspotDefaults::MINSD;  // minimum sd and intensity for detection
    hotspot::lowInt = hotspot::HotspotDefaults::LOW_INTERVAL_WIDTH;   // range and interval for scanning
    hotspot::highInt = hotspot::HotspotDefaults::HIGH_INTEVAL_WIDTH;
    hotspot::incInt = hotspot::HotspotDefaults::INTERVAL_INCREMENT;
	hotspot::fuzzySeed = hotspot::HotspotDefaults::FUZZY_SEED;
    hotspot::totaltagcount = 0;
    hotspot::densityWin = hotspot::HotspotDefaults::DENSITY_WIN;

	// Fetch input data
	hotspot::GetArgs( argc, argv);
	hotspot::InputDataReader inputDataReader( hotspot::libpath );
	hotspot::totaltagcount = inputDataReader.numLines( );
	std::cout << "TotalTagCount: " << hotspot::totaltagcount << std::endl;
	hotspot::MappableCountsDataReader mappableCountsDataReader( hotspot::densitypath );
	if( hotspot::useDefaultBackgroundTags )
	{
		hotspot::backgroundTotalTagCount = hotspot::totaltagcount;
	}
    if( hotspot::useFuzzyThreshold )
    {
    	std::srand( hotspot::fuzzySeed );
    }

	bool headerPrinted = false;
	std::vector< int > inputData;
	std::vector< int > mappableCounts;

	// Main processing loop: each pass considers each chromosome in the input data set
	while( inputDataReader.readNextChrom( inputData ) > 0 )
    {
		std::cerr << "Processing chrom: " << inputDataReader.currentChromName( ) << std::endl;

		// get counts of 'background' mappable K-mers on each 50kb interval on that chromosome
    	int numRead = mappableCountsDataReader.readChrom(inputDataReader.currentChromName( ), mappableCounts );
    	if( numRead < 0 )
    	{
    		std::cerr << "Error reading background file. Aborting" << std::endl;
			exit( EXIT_FAILURE );
    	}

    	// Compute the hot spots and filter them
   		std::cerr << "Compute Hot Spots " << std::endl;
       	std::map< int, Hotspot* > hotspots;
  		hotspot::ComputeHotSpots( inputData, hotspot::lowInt, hotspot::highInt, hotspot::incInt, hotspots );
   		std::cerr << "Filter Hot Spots " << std::endl;
       	std::map< int, Hotspot* > filteredHotspots;
   		hotspot::FilterHotspots( hotspots, filteredHotspots );

   		// Calculate cluster size, and other hotspot statistics
   		if( hotspot::useGenomeDensWin)
   		{
   			// These vars are updated (side-effect) of the ClusterSize routine
   			hotspot::numGenomeDens = 0; hotspot::numLocalDens = 0;
   			hotspot::genomeDensZ = 0.0; hotspot::localDensZ = 0.0;
   		}
   		std::cerr << "Cluster Size" << std::endl;
   		hotspot::ClusterSize( inputData, hotspot::densityWin, filteredHotspots, mappableCounts );

   		if( hotspot::useGenomeDensWin )
   		{
   			std::cerr << hotspot::numGenomeDens
						<< " clusters scored using genome-wide density, avg. z = "
						<< hotspot::genomeDensZ / hotspot::numGenomeDens
						<< "; " << hotspot::numLocalDens
						<< " scored using local density, avg. z = "
						<< hotspot::localDensZ / hotspot::numLocalDens
						<< std::endl;
   		}

   		// Summarize the results of this chromosome. Reset temp data structures
   		std::map< int, Hotspot* >::iterator iter;
   		for( iter = hotspots.begin( ); iter != hotspots.end( ); ++iter )
   		{
   			delete iter->second;
   		}
   		if(! headerPrinted )
   		{
   			Hotspot::printHeader( hotspot::fpout );
   			headerPrinted = true;
   		}
   		for( iter = filteredHotspots.begin(); iter != filteredHotspots.end(); ++iter )
   		{
   			//TODO remove costly char lookup to one-time lookup outside loop
   			iter->second->printOut( inputDataReader.currentChromName().c_str( ), hotspot::fpout );
   			delete iter->second;
   		}

   		std::cerr << "Chrom summary: " << filteredHotspots.size( ) << std::endl;
   		std::fflush( hotspot::fpout );
   		mappableCounts.clear( );
   		inputData.clear( );

    }  // end loop over all chromosomes

	// Release open resources
    if( hotspot::fpout )
    {
    	std::fclose( hotspot::fpout );
	}

    std::exit( EXIT_SUCCESS );
}
Esempio n. 24
0
File: error.c Progetto: Fudge/rb-gsl
static VALUE rb_gsl_set_error_handler_off(VALUE module)
{
  gsl_set_error_handler_off();
  return Qtrue;
}
Esempio n. 25
0
int handle_second_lvl(int argc,char **argv,struct first_lvl_cmd *fl, struct second_lvl_cmd *sl)
{
	int status = 0;
	// check for help
	if(ask_help || (argc == 0 && sl->nargs != 0))
	{
		if(sl->help != NULL)
			print_help(sl->help);
		else
			print_first_lvl_help(fl);
		return 0;
	}
	// check number of arguments
	if(argc != sl->nargs)
	{
		info("Expected %u arguments, found %u\n",sl->nargs,argc);
		error("Wrong number of arguments\n");
		return 1;
	}
	// open input
	if(fl->flags & NEED_INPUT)
	{
		normal("Configuring input\n");
		if(infname)
		{
			info("Using %s as input file\n",infname);
			infile = fopen(infname,"r");
			if(!infile)
			{
				warning("failed to open file %s for graph input, using stdin instead\n",infname);
				infile = stdin;
				infname = NULL;
			}
		}
		else
			infile = stdin;

		status = ggen_read_graph(&g,infile);
		if(infname)
			fclose(infile);
		if(status)
		{
			error("Failed to read graph\n");
			goto free_ing;
		}
		normal("Input configured and graph read\n");
	}
	// load rng
	if(fl->flags & NEED_RNG)
	{
		normal("Configuring random number generator\n");
		// turn off automatic abort on gsl error
		gsl_set_error_handler_off();
		status = ggen_rng_init(&rng);
		if(status)
		{
			error("Failed to initialize RNG\n");
			goto free_ing;
		}
		if(rngfname)
		{
			info("Using %s as RNG state file\n",rngfname);
			status = ggen_rng_load(&rng,rngfname);
			if(status == 1)
				warning("RNG State file not found, will continue anyway\n");
			else if(status != 0)
			{
				error("Reading RNG State from file failed.\n");
				goto free_rng;
			}
		}
		normal("RNG configured\n");
	}
	// set name
	if((fl->flags & NEED_NAME) && name == NULL)
	{
		name = "newproperty";
		info("Property name needed, using %s as default\n",name);
	}
	// set type
	if((fl->flags & NEED_TYPE) && ptype == -1)
	{
		ptype = VERTEX_PROPERTY;
		info("Property type needed, using VERTEX as default\n");
	}

	// output is a bit different from input:
	// a command can have its output redirected even
	// if it does not generate a graph
	// need_output tells us if a resulting graph needs
	// to be wrote, not if the output can be redirected
	normal("Configuring output\n");
	if(outfname)
	{
		info("Opening %s for writing\n",outfname);
		outfile = fopen(outfname,"w");
		if(!outfile)
		{
			warning("Failed to open file %s for output, using stdout instead\n",outfname);
			outfile = stdout;
			outfname = NULL;
		}
	}
	else
		outfile = stdout;
	normal("Ouput configured\n");

	// launch cmd
	status = sl->fn(argc,argv);
	if(status)
	{
		error("Command Failed\n");
		goto err;
	}

	if(fl->flags & NEED_OUTPUT)
	{
		normal("Printing graph\n");
		if(fl->flags & IS_GRAPH_P)
			status = ggen_write_graph(g_p,outfile);
		else
			status = ggen_write_graph(&g,outfile);

		if(status)
		{
			error("Writing graph failed\n");
			goto free_outg;
		}
		else
			normal("Graph printed\n");
	}
	if((fl->flags & NEED_RNG) && rngfname)
	{
		normal("Saving RNG state\n");
		status = ggen_rng_save(&rng,rngfname);
		if(status)
		{
			error("RNG saving failed\n");
		}
		else
			normal("RNG Saved\n");
	}
free_outg:
	if(outfname)
		fclose(outfile);

	if(fl->flags & IS_GRAPH_P)
	{
		igraph_destroy(g_p);
		free(g_p);
	}
err:
free_rng:
	if(fl->flags & NEED_RNG)
		gsl_rng_free(rng);
free_ing:
	if(fl->flags & NEED_INPUT)
		igraph_destroy(&g);
	return status;
}
Esempio n. 26
0
// Wald Test used in both summary and anova (polymophism)
int GlmTest::GeeWald(glm *Alt, gsl_matrix *LL, gsl_vector *teststat)
{
    gsl_set_error_handler_off();

    unsigned int i, j, l;
    double alpha, result, sum=0;
    unsigned int nP = Alt->nParams;
    unsigned int nDF = LL->size1;
    unsigned int nVars=tm->nVars, nRows=tm->nRows;
    int status;

    gsl_vector *LBeta = gsl_vector_alloc(nVars*nDF);
    gsl_vector_set_zero(LBeta);
    gsl_matrix *w1jX1=gsl_matrix_alloc(nRows, nP);
    gsl_matrix *XwX=gsl_matrix_alloc(nP, nP);
    gsl_matrix *Rl2 = gsl_matrix_alloc(nDF, nP);
    gsl_matrix *IinvN = gsl_matrix_alloc(nDF, nDF);
    gsl_matrix *IinvRl = gsl_matrix_alloc(nVars*nDF, nVars*nDF);
    gsl_vector *tmp = gsl_vector_alloc(nVars*nDF);
    gsl_vector_view tmp2, wj, LBj, bj; //, dj; 
    gsl_matrix_view Rl;

    gsl_matrix_set_zero(IinvRl);
    GrpMat *Z = (GrpMat*)malloc(nVars*sizeof(GrpMat));
    for (j=0; j<nVars; j++){
       Z[j].matrix = gsl_matrix_alloc(nP, nRows);
       // w1jX1 = W^1/2 * X
       wj=gsl_matrix_column(Alt->wHalf, j);
       for (i=0; i<nP; i++)
           gsl_matrix_set_col (w1jX1, i, &wj.vector);
       gsl_matrix_mul_elements (w1jX1, Alt->Xref);

       // LBeta = L*Beta       
       LBj=gsl_vector_subvector(LBeta, j*nDF, nDF);
       bj=gsl_matrix_column(Alt->Beta, j);
       gsl_blas_dgemv(CblasNoTrans,1,LL,&bj.vector,0,&LBj.vector);

       // Z = (X^T W X)^-1 * X^T W^1/2. 
       gsl_matrix_set_identity(XwX);
       gsl_blas_dsyrk (CblasLower,CblasTrans,1.0,w1jX1,0.0,XwX);
       status=gsl_linalg_cholesky_decomp (XwX);
       if (status==GSL_EDOM) {
          if (tm->warning==TRUE) 
             printf("Warning:singular matrix in wald test. An eps*I is added to the singular matrix.\n");
          gsl_matrix_set_identity(XwX);
          gsl_blas_dsyrk(CblasLower,CblasTrans,1.0,w1jX1,eps,XwX);
          gsl_linalg_cholesky_decomp(XwX);
       }
       gsl_linalg_cholesky_invert(XwX);
       gsl_blas_dgemm(CblasNoTrans,CblasTrans,1.0,XwX,w1jX1,0.0, Z[j].matrix);

       gsl_matrix_memcpy(Rl2, LL);
       gsl_blas_dtrmm (CblasRight,CblasLower,CblasNoTrans,CblasNonUnit,1.0,XwX,Rl2); // L*(X'WX)^-1
       gsl_blas_dgemm (CblasNoTrans, CblasTrans, 1.0, Rl2, LL, 0.0, IinvN); // L*(X^T*W*X)^-1*L^T 

       if ( (tm->punit!=NONE) || (tm->corr==IDENTITY) ) {
          status=gsl_linalg_cholesky_decomp (IinvN);
          if (status==GSL_EDOM) {
             if (tm->warning==TRUE) 
             printf("Warning:singular IinvN in wald test.\n");
          }
          tmp2=gsl_vector_subvector(tmp, 0, nDF);
          gsl_linalg_cholesky_solve (IinvN, &LBj.vector, &tmp2.vector);
          gsl_blas_ddot (&LBj.vector, &tmp2.vector, &result);
          gsl_vector_set(teststat, j+1, sqrt(result));
          sum = sum + result;
       }

       if (tm->corr!=IDENTITY) {
          // IinvRl=L*vSandRl*L^T 
          for (l=0; l<=j; l++) {
              Rl=gsl_matrix_submatrix(IinvRl,j*nDF,l*nDF,nDF,nDF);
              alpha = gsl_matrix_get(Rlambda, j, l);
              // borrow XwX space to store vSandRl
              gsl_blas_dgemm(CblasNoTrans,CblasTrans,alpha,Z[j].matrix,Z[l].matrix, 0.0, XwX); 
              // Rl2 = L*vSandRl*L^T
              gsl_blas_dgemm(CblasNoTrans,CblasNoTrans,1.0,LL,XwX,0.0,Rl2);
              gsl_blas_dgemm(CblasNoTrans,CblasTrans,1.0,Rl2,LL,0.0,&Rl.matrix);
          } // end l
       }  // end if (tm->corr) 

    } // end for j=1:nVars       

    if ( tm->corr==IDENTITY ) 
        gsl_vector_set(teststat, 0, sqrt(sum));
    else {
        status=gsl_linalg_cholesky_decomp (IinvRl);
        if (status==GSL_EDOM) {
           if (tm->warning==TRUE) 
           printf("Warning:singular matrix in multivariate wald test.\n");
        }
        gsl_linalg_cholesky_solve (IinvRl, LBeta, tmp);
        gsl_blas_ddot (LBeta, tmp, &result);
        gsl_vector_set(teststat, 0, sqrt(result));
    }

    // free memory
    for (j=0; j<nVars; j++) 
        gsl_matrix_free(Z[j].matrix);
    free(Z);
    gsl_vector_free(LBeta);
    gsl_matrix_free(w1jX1);
    gsl_matrix_free(XwX);
    gsl_matrix_free(Rl2);
    gsl_matrix_free(IinvN);
    gsl_matrix_free(IinvRl);
    gsl_vector_free(tmp);

    return SUCCESS;
}
Esempio n. 27
0
int PoissonGlm::EstIRLS(gsl_matrix *Y, gsl_matrix *X, gsl_matrix *O, gsl_matrix *B, double *a)
{
    initialGlm(Y, X, O, B);

    gsl_set_error_handler_off();
    gsl_rng *rnd=gsl_rng_alloc(gsl_rng_mt19937);
    unsigned int i, j;   
    int status;
    double yij, mij, vij, wij, tol, hii, uij, wei;
    gsl_vector_view Xwi, Xi, vj, hj, dj;

    gsl_matrix *WX = gsl_matrix_alloc(nRows, nParams);   
    gsl_matrix *TMP = gsl_matrix_alloc(nRows, nParams);   
    gsl_matrix *XwX = gsl_matrix_alloc(nParams, nParams);   

    for (j=0; j<nVars; j++) {
       if ( a!=NULL ) theta[j]=a[j]; 
       // estimate mu and beta   
       iterconv[j] = betaEst(j, maxiter, &tol, theta[j]); 
       if ((mmRef->warning==TRUE)&(iterconv[j]==maxiter)) 
           printf("Warning: EstIRLS reached max iterations, may not converge in the %d-th variable (dev=%.4f, err=%.4f)!\n", j, dev[j], tol);
       gsl_matrix_memcpy (WX, X);
       for (i=0; i<nRows; i++) {
            mij = gsl_matrix_get(Mu, i, j);
            // get variance
            vij = varfunc( mij, theta[j] );
            gsl_matrix_set(Var, i, j, vij); 
            // get weight
            wij = sqrt(weifunc(mij, theta[j]));  
            gsl_matrix_set(wHalf, i, j, wij);             
            // get (Pearson) residuals
            yij = gsl_matrix_get(Y, i, j);
            gsl_matrix_set(Res, i, j, (yij-mij)/sqrt(vij));        
            // get PIT residuals for discrete data
            wei = gsl_rng_uniform_pos (rnd); // wei ~ U(0, 1)
            uij = wei*cdf(yij, mij, theta[j]);
            if (yij>0) uij=uij+(1-wei)*cdf((yij-1),mij,theta[j]);
            gsl_matrix_set(PitRes, i, j, uij);
            // get elementry log-likelihood    
            ll[j] = ll[j] + llfunc( yij, mij, theta[j]);
            // W^1/2 X
            Xwi = gsl_matrix_row (WX, i);
            gsl_vector_scale(&Xwi.vector, wij);            
       }      
       aic[j]=-ll[j]+2*(nParams);

       // X^T * W * X
       gsl_matrix_set_identity(XwX);
       gsl_blas_dsyrk (CblasLower, CblasTrans, 1.0, WX, 0.0, XwX);
       status=gsl_linalg_cholesky_decomp (XwX);
       if (status==GSL_EDOM) {
          if (mmRef->warning==TRUE)
             printf("Warning: singular matrix in calculating pit-residuals. An eps*I is added to the singular matrix.\n");
          gsl_matrix_set_identity(XwX);
          gsl_blas_dsyrk (CblasLower, CblasTrans, 1.0, WX, mintol, XwX);
          gsl_linalg_cholesky_decomp (XwX);
       }
       gsl_linalg_cholesky_invert (XwX);

       // Calc varBeta
       dj = gsl_matrix_diagonal (XwX);
       vj = gsl_matrix_column (varBeta, j);       
       gsl_vector_memcpy (&vj.vector, &dj.vector);

       // hii is diagonal element of H=X*(X'WX)^-1*X'*W
       hj = gsl_matrix_column (sqrt1_Hii, j);
       gsl_blas_dsymm(CblasRight,CblasLower,1.0,XwX,Xref,0.0,TMP); // X*(X'WX)^-1
       for (i=0; i<nRows; i++) {
           Xwi=gsl_matrix_row(TMP, i);
           Xi=gsl_matrix_row(Xref, i);
           wij=gsl_matrix_get(wHalf, i, j);
           gsl_blas_ddot(&Xwi.vector, &Xi.vector, &hii);
           gsl_vector_set(&hj.vector, i, MAX(mintol, sqrt(MAX(0, 1-wij*wij*hii))));
       } 
   } 
   // standardize perason residuals by rp/sqrt(1-hii) 
//   gsl_matrix_div_elements (Res, sqrt1_Hii);
//   subtractMean(Res);  // have mean subtracted

   gsl_matrix_free(XwX);
   gsl_matrix_free(WX);
   gsl_matrix_free(TMP);
   gsl_rng_free(rnd);

   return SUCCESS;    
}
double QFFitFunctionFCSDistributionDIntGaussian::evaluate(double t, const double* data) const {
    const int nonfl_comp=data[FCSDLG_n_nonfluorescent];
    const double N=data[FCSDLG_n_particle];
    const double nf_tau1=data[FCSDLG_nonfl_tau1]/1.0e6;
    const double nf_theta1=data[FCSDLG_nonfl_theta1];
    const double nf_tau2=data[FCSDLG_nonfl_tau2]/1.0e6;
    const double nf_theta2=data[FCSDLG_nonfl_theta2];
    const double D1=data[FCSDLG_diff_coeff1];
    const double D1_sigma=data[FCSDLG_diff_coeff_sigma];
    const double D_min=data[FCSDLG_D_range_min];
    const double D_max=data[FCSDLG_D_range_max];
    const double wxy=data[FCSDLG_focus_width]/1e3;


    const double background=data[FCSDiff_background];
    const double cr=data[FCSDLG_count_rate];
    double backfactor=qfSqr(cr-background)/qfSqr(cr);
    if (fabs(cr)<1e-15) backfactor=1;

    double gamma=data[FCSDLG_focus_struct_fac];
    if (gamma==0) gamma=1;
    const double gamma2=sqr(gamma);

    const double offset=data[FCSDLG_offset];


    if (N>0) {
        register double diff=0.0;
        double diff1=0.0;
        double diff2=0.0;
        double error=0;

        QFFitFunctionFCSDistributionDIntGaussian_intparam p;
        p.gamma=gamma;
        p.DC=D1;
        p.DSigma=D1_sigma;
        p.wxy=wxy;
        p.tau=t;

        gsl_function F;
        F.function = &QFFitFunctionFCSDistributionDIntGaussian_f;
        F.params = &p;

        gsl_function FD;
        FD.function = &QFFitFunctionFCSDistributionDIntGaussian_fd;
        FD.params = &p;

        gsl_error_handler_t * old_h=gsl_set_error_handler_off();


        gsl_integration_qags(&F, D_min, D1, 0, 1e-7, wN, w, &diff1, &error);
        gsl_integration_qags(&F, D1, D_max, 0, 1e-7, wN, w, &diff2, &error);
        diff=diff1+diff2;

        gsl_integration_qags(&FD, D_min, D1, 0, 1e-7, wN, w, &diff1, &error);
        gsl_integration_qags(&FD, D1, D_max, 0, 1e-7, wN, w, &diff2, &error);
        diff=diff/(diff1+diff2);


        gsl_set_error_handler(old_h);

        double pre=1.0;
        if (nonfl_comp==1) {
            pre=(1.0-nf_theta1+nf_theta1*exp(-t/nf_tau1))/(1.0-nf_theta1);
        } else if (nonfl_comp==2) {
            pre=(1.0-nf_theta1+nf_theta1*exp(-t/nf_tau1)-nf_theta2+nf_theta2*exp(-t/nf_tau2))/(1.0-nf_theta1-nf_theta2);
        }
        return offset+pre/N*diff*backfactor;
    } else {
        const double Dtau=qfSqr(wxy)/4.0/t;
        return -1.0*exp(-0.5*qfSqr((Dtau-D1)/D1_sigma))/N*backfactor;
    }
}
Esempio n. 29
0
int NBinGlm::nbinfit(gsl_matrix *Y, gsl_matrix *X, gsl_matrix *O, gsl_matrix *B)
{   
    gsl_set_error_handler_off();

    initialGlm(Y, X, O, B);

    gsl_rng *rnd=gsl_rng_alloc(gsl_rng_mt19937);
    unsigned int i, j; //, isConv;
    double yij, mij, vij, hii, uij, wij, wei;
    double th, tol, dev_th_b_old;
    int status;
 //   gsl_vector_view b0j, m0j, e0j, v0j;
    gsl_matrix *WX = gsl_matrix_alloc(nRows, nParams);   
    gsl_matrix *TMP = gsl_matrix_alloc(nRows, nParams);   
    gsl_matrix *XwX = gsl_matrix_alloc(nParams, nParams);   
    gsl_vector_view Xwi, Xi, vj, dj, hj;

    for (j=0; j<nVars; j++) {  
        betaEst(j, maxiter, &tol, maxtol); //poisson
        // Get initial theta estimates
        iterconv[j]=0.0;  
        if (mmRef->estiMethod==CHI2) {
           th = getDisper(j, 1.0); 
           while ( iterconv[j]<maxiter ) {
//printf("th=%.2f, iterconv[%d]=%d\n", th, j, iterconv[j]);
               iterconv[j]++;
               dev_th_b_old = dev[j];
               betaEst(j, 1.0, &tol, th);  // 1-step beta
               th = getDisper(j, th)/th; 
               tol = ABS((dev[j]-dev_th_b_old)/(ABS(dev[j])+0.1));
               if (tol<eps) break;
         }  }
        else if (mmRef->estiMethod==NEWTON) {
            th = thetaML(0.0, j, maxiter);
            while ( iterconv[j]<maxiter ) {
               iterconv[j]++;
               dev_th_b_old = dev[j];
               th = thetaML(th, j, maxiter2);
               betaEst(j, maxiter2, &tol, th);  
               tol=ABS((dev[j]-dev_th_b_old)/(ABS(dev[j])+0.1));
               if (tol<eps) break;
        }  } 
       else {
           th = getfAfAdash(0.0, j, maxiter);
/*           lm=0;
           for (i=0; i<nRows; i++) {
               yij = gsl_matrix_get(Y, i, j);
               mij = gsl_matrix_get(Mu, i, j);
               lm = lm + llfunc( yij, mij, th);
           } */
           while ( iterconv[j]<maxiter ) {
               iterconv[j]++;
               dev_th_b_old = dev[j];
               betaEst(j, maxiter2, &tol, th);  
               th = getfAfAdash(th, j, 1.0);
               tol=ABS((dev[j]-dev_th_b_old)/(ABS(dev[j])+0.1));
               if (tol<eps) break;
           }
       }       
       if ((iterconv[j]==maxiter)&(mmRef->warning==TRUE)) 
           printf("Warning: reached maximum itrations - negative binomial may NOT converge in the %d-th variable (dev=%.4f, err=%.4f, theta=%.4f)!\n", j, dev[j], tol, th);

       // other properties based on mu and phi
       theta[j] = th;
       gsl_matrix_memcpy(WX, Xref);  
       ll[j]=0;
       for (i=0; i<nRows; i++) {
           yij = gsl_matrix_get(Y, i, j);
           mij = gsl_matrix_get(Mu, i, j);
           vij = varfunc( mij, th);
           gsl_matrix_set(Var, i, j, vij); 
           wij = sqrt(weifunc(mij, th));
           gsl_matrix_set(wHalf, i, j, wij); 
           gsl_matrix_set(Res, i, j, (yij-mij)/sqrt(vij));        
           ll[j] = ll[j] + llfunc( yij, mij, th);
           // get PIT residuals for discrete data
           wei = gsl_rng_uniform_pos (rnd); // wei ~ U(0, 1)
           uij=wei*cdf(yij, mij, th);
           if (yij>0) uij=uij+(1-wei)*cdf((yij-1),mij,th);
           gsl_matrix_set(PitRes, i, j, uij);
           // W^1/2 X
           Xwi = gsl_matrix_row (WX, i);
           gsl_vector_scale(&Xwi.vector, wij);
       }
       aic[j]=-ll[j]+2*(nParams+1);

       // X^T * W * X
       gsl_matrix_set_identity (XwX);
       gsl_blas_dsyrk (CblasLower, CblasTrans, 1.0, WX, 0.0, XwX);
       status=gsl_linalg_cholesky_decomp (XwX);
       if (status==GSL_EDOM) {
          if (mmRef->warning==TRUE)
             printf("Warning: singular matrix in calculating pit-residuals. An eps*I is added to the singular matrix.\n");
          gsl_matrix_set_identity (XwX);
          gsl_blas_dsyrk (CblasLower, CblasTrans, 1.0, WX, mintol, XwX);
          gsl_linalg_cholesky_decomp (XwX);
       }
       gsl_linalg_cholesky_invert (XwX); // (X'WX)^-1

       // Calc varBeta
       vj = gsl_matrix_column (varBeta, j);
       dj = gsl_matrix_diagonal (XwX);
       gsl_vector_memcpy (&vj.vector, &dj.vector);

       // hii is diagonal element of H=X*(X'WX)^-1*X'*W
       hj = gsl_matrix_column (sqrt1_Hii, j);
       gsl_blas_dsymm(CblasRight,CblasLower,1.0,XwX,Xref,0.0,TMP); // X*(X'WX)^-1
       for (i=0; i<nRows; i++) {
           Xwi=gsl_matrix_row(TMP, i);
           Xi=gsl_matrix_row(Xref, i);
           wij=gsl_matrix_get(wHalf, i, j);
           gsl_blas_ddot(&Xwi.vector, &Xi.vector, &hii);
           gsl_vector_set(&hj.vector, i, MAX(mintol, sqrt(MAX(0, 1-wij*wij*hii))));
//printf("hii=%.4f, wij=%.4f, sqrt(1-wij*wij*hii)=%.4f\n", hii, wij, sqrt(1-wij*wij*hii));
       }
   } // end nVar for j loop
//   gsl_matrix_div_elements (Res, sqrt1_Hii);
//   subtractMean(Res);

   gsl_matrix_free(XwX);
   gsl_matrix_free(WX);
   gsl_matrix_free(TMP);
   gsl_rng_free(rnd);

   return SUCCESS;    
}
Esempio n. 30
0
int GlmTest::GeeScore(gsl_matrix *X1, glm *PtrNull, gsl_vector *teststat)
{
    gsl_set_error_handler_off();

    double result, alpha, sum=0;
    unsigned int i, j, l, nP = X1->size2;
    unsigned int nVars=tm->nVars, nRows=tm->nRows;
    int status;

    gsl_vector *U = gsl_vector_alloc(nVars*nP);
    gsl_matrix *kRlNull = gsl_matrix_alloc(nVars*nP, nVars*nP);
    gsl_matrix_set_zero (kRlNull);
    gsl_matrix *XwX = gsl_matrix_alloc(nP, nP);
    gsl_vector *tmp=gsl_vector_alloc(nVars*nP);
    gsl_vector_view wj, uj, rj, tmp2; //, dj;
    gsl_matrix_view Rl;

    GrpMat *Z = (GrpMat*)malloc(nVars*sizeof(GrpMat));
    for (j=0; j<nVars; j++) {
        Z[j].matrix = gsl_matrix_alloc(nRows, nP);
        // get W^1/2 * X
        wj = gsl_matrix_column (PtrNull->wHalf, j);
        for (i=0; i<nP; i++)
            gsl_matrix_set_col (Z[j].matrix, i, &wj.vector);
        gsl_matrix_mul_elements (Z[j].matrix, X1);

        uj=gsl_vector_subvector(U, j*nP, nP);
        rj=gsl_matrix_column(PtrNull->Res, j);
        gsl_blas_dgemv(CblasTrans, 1, Z[j].matrix, &rj.vector, 0, &uj.vector);

        if ( (tm->punit!=NONE) || (tm->corr==IDENTITY) ) {
           gsl_matrix_set_identity(XwX);
           gsl_blas_dsyrk(CblasLower, CblasTrans, 1, Z[j].matrix, 0, XwX);
           status=gsl_linalg_cholesky_decomp(XwX); 
           if (status==GSL_EDOM) {
              if (tm->warning==TRUE)
                  printf("Warning: singular matrix in score test. An eps*I is added to the singular matrix.\n");
              gsl_matrix_set_identity(XwX);
              gsl_blas_dsyrk(CblasLower,CblasTrans,1,Z[j].matrix,eps,XwX);
              gsl_linalg_cholesky_decomp(XwX); 
           }
           tmp2=gsl_vector_subvector(tmp, 0, nP);
           gsl_linalg_cholesky_solve(XwX, &uj.vector, &tmp2.vector);
           gsl_blas_ddot(&uj.vector, &tmp2.vector, &result);
           gsl_vector_set(teststat, j+1, result);
           sum = sum+result;           
        }

        if ( tm->corr!=IDENTITY) {
            for (l=0; l<=j; l++) { // lower half
                alpha = gsl_matrix_get(Rlambda, j, l);
                Rl=gsl_matrix_submatrix(kRlNull,j*nP,l*nP,nP,nP);
                gsl_blas_dgemm(CblasTrans, CblasNoTrans, alpha, Z[j].matrix, Z[l].matrix, 0, &Rl.matrix);
            }
        }
    } // end for j=1:nVars

    // multivariate test stat   
    if ( tm->corr==IDENTITY ) gsl_vector_set(teststat, 0, sum);
    else {    
        status=gsl_linalg_cholesky_decomp (kRlNull);
        if (status==GSL_EDOM) {
           if (tm->warning==TRUE) 
              printf("Warning:singular kRlNull in multivariate score test.\n");
        }
        gsl_linalg_cholesky_solve (kRlNull, U, tmp);
        gsl_blas_ddot (U, tmp, &result);
        gsl_vector_set(teststat, 0, result);
    }

   // clear memory
    gsl_vector_free(U);
    gsl_vector_free(tmp);
    gsl_matrix_free(XwX);
    gsl_matrix_free(kRlNull);
    for (j=0; j<nVars; j++) gsl_matrix_free(Z[j].matrix);
    free(Z);

    return SUCCESS;

}