Exemple #1
0
void timestep(double ****f, double ****df, double ***nut, double t, double ****fout,
              double dttry, double *dtdid, double *dtnext)
{
   double dt, err, errs;

   dt=dttry;
   for (;;)
   {
      err = rkck(f, df, nut, t, dt, fout);
      if (VarStep==0 || count%VarStep!=0) {
            *dtdid = dt;
            *dtnext = dt;
            return;
            }

      MPI_Allreduce(&err, &errs, 1, MPI_DOUBLE , MPI_MAX, MPI_COMM_WORLD);
      err=errs;

      err *=ErrScale;
      if (err<=1.0)
         break;
      dt = max(Safety * dt * pow(err, Pshrink), dt*(double)0.1);
      if (t+dt == t)
	    {
	     dump(f,nut,t,count);
             nrerror("Stepsize underflow in rk\n",t,count);
            }
   }
   *dtdid = dt;
   if (err>ErrCon)
      *dtnext = Safety * dt * pow(err, Pgrow);
   else
      *dtnext = dt * (double)5.0;
}
Exemple #2
0
void rkqs(float y[], float dydx[], int n, float *x, float htry, float eps,
	float yscal[], float *hdid, float *hnext,
	void (*derivs)(float, float [], float []))
{
	void rkck(float y[], float dydx[], int n, float x, float h,
		float yout[], float yerr[], void (*derivs)(float, float [], float []));
	int i;
	float errmax,h,htemp,xnew,*yerr,*ytemp;

	yerr=vector(1,n);
	ytemp=vector(1,n);
	h=htry;
	for (;;) {
		rkck(y,dydx,n,*x,h,ytemp,yerr,derivs);
		errmax=0.0;
		for (i=1;i<=n;i++) errmax=FMAX(errmax,fabs(yerr[i]/yscal[i]));
		errmax /= eps;
		if (errmax <= 1.0) break;
		htemp=SAFETY*h*pow(float(errmax),float(PSHRNK));
		h=(h >= 0.0 ? FMAX(htemp,0.1*h) : FMIN(htemp,0.1*h));
		xnew=(*x)+h;
		if (xnew == *x) nrerror("stepsize underflow in rkqs");
	}
	if (errmax > ERRCON) *hnext=SAFETY*h*pow(float(errmax),float(PGROW));
	else *hnext=5.0*h;
	*x += (*hdid=h);
	for (i=1;i<=n;i++) y[i]=ytemp[i];
	free_vector(ytemp,1,n);
	free_vector(yerr,1,n);
}
Exemple #3
0
void timestep(double ****f, double ****df, double t, double ****fout,
              double dttry, double *dtdid, double *dtnext)
{
   double dt, err = 0;

   dt=dttry;
   for (;;)
   {
      err = rkck(f, df, t, dt, fout);
      err *=ErrScale;
      if (err<=1.0)
         break;
      dt = max(Safety * dt * pow(err, Pshrink), dt*(double)0.1);
      if (t+dt == t) 
	    {
	     dump(n1,n2,n3,Re,f,nut,t_cur,count);
             nrerror("Stepsize underflow in rk\n\a",t);
            }
   }
   *dtdid = dt;
   if (err>ErrCon)
      *dtnext = Safety * dt * pow(err, Pgrow);
   else
      *dtnext = dt * (double)5.0;
}
Exemple #4
0
void rkqs(float y[], float dydx[], int n, float *x, float htry, float eps,
	float yscal[], float *hdid, float *hnext,
	void (*derivs)(float, float [], float []))
{
	void rkck(float y[], float dydx[], int n, float x, float h,
		float yout[], float yerr[], void (*derivs)(float, float [], float []));
	int i;
	float errmax,h,xnew,*yerr,*ytemp;

	yerr=vector(1,n);
	ytemp=vector(1,n);
	h=htry;
	for (;;) {
		rkck(y,dydx,n,*x,h,ytemp,yerr,derivs);
		errmax=0.0;
		for (i=1;i<=n;i++) errmax=FMAX(errmax,fabs(yerr[i]/yscal[i]));
		errmax /= eps;
		if (errmax > 1.0) {
			h=SAFETY*h*pow(errmax,PSHRNK);
			if (h < 0.1*h) h *= 0.1;
			xnew=(*x)+h;
			if (xnew == *x) nrerror("stepsize underflow in rkqs");
			continue;
		} else {
			if (errmax > ERRCON) *hnext=SAFETY*h*pow(errmax,PGROW);
			else *hnext=5.0*h;
			*x += (*hdid=h);
			for (i=1;i<=n;i++) y[i]=ytemp[i];
			break;
		}
	}
	free_vector(ytemp,1,n);
	free_vector(yerr,1,n);
}
Exemple #5
0
void rkqs(double *y, double *dydx, int n, double *x, 
	      double htry, double eps, double *yscal, 
	      double *hdid, double *hnext, double sigma2, double den1,   
	      void (*derivs)(double, double *, double *, double, double))   
{   
    int i;   
    double errmax,h,htemp,xnew;   
    double *yerr=ALLOC(n,double);   
    double *ytemp=ALLOC(n,double);   
    
    h=htry;   
    for (;;) {
	rkck(y,dydx,n,*x,h,ytemp,yerr,sigma2,den1,derivs);   
        errmax=0.0;   
        for (i=0;i<n;i++) errmax=MAX(errmax,fabs(yerr[i]/yscal[i]));   
        errmax /= eps;   
        if (errmax <= 1.0) break;   
        htemp=SAFETY*h*pow(errmax,PSHRNK);   
        h=(h >= 0.0 ? MAX(htemp,0.1*h) : MIN(htemp,0.1*h));   
        xnew=(*x)+h;   
    }   
    if (errmax > ERRCON) *hnext=SAFETY*h*pow(errmax,PGROW);   
    else *hnext=5.0*h;   
    *x += (*hdid=h);   
    for (i=0;i<n;i++) y[i]=ytemp[i]; 
    free(ytemp); free(yerr);
}   
void RungeKuttaSolver::rkqs(double y[], double dydx[], int n, double *x, double htry, double eps, double yscal[], double *hdid, double *hnext, RungeKuttaEquation *Equations[])
{
	int i;
	double errmax,h,xnew,*yerr,*ytemp;

	yerr=new_vector(1,n);
	ytemp=new_vector(1,n);
	h=htry;
	for (;;)
	{
		rkck(y,dydx,n,*x,h,ytemp,yerr,Equations);
		errmax=0.0;
		for (i=1;i<=n;i++) 
			errmax=FMAX(errmax,fabs(yerr[i]/yscal[i]));
		errmax /= eps;
		if (errmax > 1.0)
		{
			h=SAFETY*h*pow(errmax,PSHRNK);
			if (h < 0.1*h)
				h *= 0.1;

			xnew=(*x)+h;
			if (xnew == *x)	
				nrerror("stepsize underflow in rkqs");
			continue;
		}
		else
		{
			if (errmax > ERRCON) 
				*hnext=SAFETY*h*pow(errmax,PGROW);
			else 
				*hnext=5.0*h;
			*x += (*hdid=h);
			for (i=1;i<=n;i++) 
				y[i]=ytemp[i];
			break;
		}
	}
	delete_vector(ytemp,1,n);
	delete_vector(yerr,1,n);
}
bool rkqs(double y[], double dydx[], int n, double *x, double htry, double eps,
	double yscal[], double *hdid, double *hnext,
	void (*derivs)(double , double [], double [], int, long, double), long node)
{

	void rkck(double y[], double dydx[], int n, double x, double h,
		double yout[], double yerr[], void (*derivs)(double , double [], double [], int, long, double), long node);
	int i;
	double errmax,h,htemp,xnew,*yerr,*ytemp;
 bool success = false;
 double *epsi;

 // y[]    - c(step)
 // dydx[] - dcdt(step)
 // yscal  - scaling of errors

	yerr=dvector(1,n);
	ytemp=dvector(1,n);
	h=htry; //set stepsize to initial trial value
	epsi=dvector(1,n);

 for (i=1;i<=n;i++) 
   epsi[i]=eps;
 //epsi[2]= eps*1000;
 //epsi[20]= eps*1000;
 //epsi[21]= eps*1000;
	
 for (;;) {
	  rkck(y,dydx,n,*x,h,ytemp,yerr,derivs, node); // take a step --> update yerr, ytemp
	  //evaluate accuracy
   errmax=0.0;

   //for (i=1;i<=n;i++) 
     //yscal[i]=fabs(y[i])+fabs(dydx[i]*h)+TINY; // for Runge Kutta, this is done in driver routine odeint
     //yscal[i]= eps + eps*DMAX(fabs(y[i]),fabs(ytemp[i]));  
     //yscal[i]= 0 + eps*fabs(y[i]);  
   for (i=1;i<=n;i++) 
     //if(i==2 || i==20 || i==21 ) 
     //  errmax=DMAX(errmax,errmax/10); // find max rel. error |d0/d1|
     //  errmax=DMAX(errmax, fabs(yerr[i]/yscal[i])); // find max rel. error |d0/d1|
       errmax=DMAX(errmax, fabs(yerr[i]/yscal[i])/(epsi[i])); // find max rel. error |d0/d1|
       //errmax += pow(yerr[i]/yscal[i],2);
       //errmax = DMAX(errmax, pow(yerr[i]/yscal[i],2));
   //errmax /= eps;              // SCALE relative to required tolerance
   //errmax = sqrt(errmax/n);
   //errmax = sqrt(errmax);

   if(DEBUGRK>0){
  
   rkqs_yerr << "node" << node <<" " << *x << " " << h << " ";
   for (i=1;i<=25;i++) rkqs_yerr << " " << fabs(yerr[ idcs[i] ]) ;
   rkqs_yerr << "\n";

   rkqs_ytemp << "node" << node <<" " << *x << " " << h << " ";
   for (i=1;i<=25;i++) rkqs_ytemp << " " << ytemp[ idcs[i] ] ;
   rkqs_ytemp << "\n";
   
   rkqs_errmax << "node" << node <<" " << *x << " " << h << " ";
   for (i=1;i<=25;i++) {
       rkqs_errmax << " " << fabs((yerr[ idcs[i] ] / yscal[ idcs[i] ]))/epsi[i];
   }
   rkqs_errmax << " " << errmax; 
   rkqs_errmax << "\n";  
  }

   if (errmax <= 1.0) break;   // success, break and compute next step size

   // failed, truncation error too large
   htemp=SAFETY*h*pow(errmax,PSHRNK);                 // reduce step size
   h=(h >= 0.0 ?  (htemp,0.1*h) : DMIN(htemp,0.1*h)); // no more than factor of 1/10
	  xnew=(*x)+h;
    if (xnew == *x){ 
      std::cout << "step size underflow in rkqs" << "\n";
      //nrerror("stepsize underflow in rkqs");
   	  free_dvector(ytemp,1,n);
      free_dvector(yerr,1,n);
      success = false;
      return success;
   }
 }

  if(DEBUGRK>0){
   rkqs_yerr << "\n";
   rkqs_ytemp << "\n";
   rkqs_errmax << "\n";  
  }

 if (errmax > ERRCON) *hnext=SAFETY*h*pow(errmax,PGROW);
	else *hnext=5.0*h;

//if(*hnext > 3500) *hnext=3500;

	*x += (*hdid=h);
	for (i=1;i<=n;i++) y[i]=ytemp[i];  // update y[i] concentration vector
	free_dvector(ytemp,1,n);
	free_dvector(yerr,1,n);
	free_dvector(epsi,1,n);
 success = true;
 return success;

}