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;
}
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);
}
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;
}
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);
}
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;
}