/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
char ros_PrepareMatrix (
/* Inout argument: (step size is decreased when LU fails) */
double* H,
/* Input arguments: */
int Direction, double gam, double Jac0[],
/* Output arguments: */
double Ghimj[], int Pivot[] )
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Prepares the LHS matrix for stage calculations
1. Construct Ghimj = 1/(H*ham) - Jac0
"(Gamma H) Inverse Minus Jacobian"
2. Repeat LU decomposition of Ghimj until successful.
-half the step size if LU decomposition fails and retry
-exit after 5 consecutive fails
Return value: Singular (true=1=failed_LU or false=0=successful_LU)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
{
/*~~~> Local variables */
int i, ising, Nconsecutive;
double ghinv;
Nconsecutive = 0;
while (1) { /* while Singular */
/*~~~> Construct Ghimj = 1/(H*ham) - Jac0 */
WCOPY(920,Jac0,1,Ghimj,1);
WSCAL(920,(-ONE),Ghimj,1);
ghinv = ONE/(Direction*(*H)*gam);
for (i=0; i<74; i++) {
Ghimj[LU_DIAG[i]] = Ghimj[LU_DIAG[i]]+ghinv;
} /* for i */
/*~~~> Compute LU decomposition */
DecompTemplate( Ghimj, Pivot, &ising );
if (ising == 0) {
/*~~~> if successful done */
return 0; /* Singular = false */
} else { /* ising .ne. 0 */
/*~~~> if unsuccessful half the step size; if 5 consecutive fails return */
Nsng++;
Nconsecutive++;
printf("\nWarning: LU Decomposition returned ising = %d\n",ising);
if (Nconsecutive <= 5) { /* Less than 5 consecutive failed LUs */
*H = (*H)*HALF;
} else { /* More than 5 consecutive failed LUs */
return 1; /* Singular = true */
} /* end if Nconsecutive */
} /* end if ising */
} /* while Singular */
} /* ros_PrepareMatrix */
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
void ros_FunTimeDerivative (
/*~~~> Input arguments: */
KPP_REAL T, KPP_REAL Roundoff,
KPP_REAL Y[], KPP_REAL Fcn0[],
void (*ode_Fun)(KPP_REAL, KPP_REAL [], KPP_REAL []),
/*~~~> Output arguments: */
KPP_REAL dFdT[] )
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The time partial derivative of the function by finite differences
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
{
/*~~~> Local variables */
KPP_REAL Delta;
Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T));
(*ode_Fun)(T+Delta,Y,dFdT);
WAXPY(KPP_NVAR,(-ONE),Fcn0,1,dFdT,1);
WSCAL(KPP_NVAR,(ONE/Delta),dFdT,1);
} /* ros_FunTimeDerivative */
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
void ros_FunTimeDerivative (
/*~~~> Input arguments: */
double T, double Roundoff,
double Y[], double Fcn0[],
void (*ode_Fun)(double, double [], double []),
/*~~~> Output arguments: */
double dFdT[] )
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The time partial derivative of the function by finite differences
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
{
/*~~~> Local variables */
double Delta;
Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T));
(*ode_Fun)(T+Delta,Y,dFdT);
WAXPY(74,(-ONE),Fcn0,1,dFdT,1);
WSCAL(74,(ONE/Delta),dFdT,1);
} /* ros_FunTimeDerivative */
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
int RosenbrockIntegrator(
/*~~~> Input: the initial condition at Tstart; Output: the solution at T */
KPP_REAL Y[],
/*~~~> Input: integration interval */
KPP_REAL Tstart, KPP_REAL Tend ,
/*~~~> Input: tolerances */
KPP_REAL AbsTol[], KPP_REAL RelTol[],
/*~~~> Input: ode function and its Jacobian */
void (*ode_Fun)(KPP_REAL, KPP_REAL [], KPP_REAL []),
void (*ode_Jac)(KPP_REAL, KPP_REAL [], KPP_REAL []) ,
/*~~~> Input: The Rosenbrock method parameters */
int ros_S,
KPP_REAL ros_M[], KPP_REAL ros_E[],
KPP_REAL ros_A[], KPP_REAL ros_C[],
KPP_REAL ros_Alpha[],KPP_REAL ros_Gamma[],
KPP_REAL ros_ELO, char ros_NewF[],
/*~~~> Input: integration parameters */
char Autonomous, char VectorTol,
int Max_no_steps,
KPP_REAL Roundoff, KPP_REAL Hmin, KPP_REAL Hmax, KPP_REAL Hstart,
KPP_REAL FacMin, KPP_REAL FacMax, KPP_REAL FacRej, KPP_REAL FacSafe,
/*~~~> Output: time at which the solution is returned (T=Tend if success)
and last accepted step */
KPP_REAL *Texit, KPP_REAL *Hexit )
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Template for the implementation of a generic Rosenbrock method
defined by ros_S (no of stages) and coefficients ros_{A,C,M,E,Alpha,Gamma}
returned value: IERR, indicator of success (if positive)
or failure (if negative)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
{
KPP_REAL Ynew[KPP_NVAR], Fcn0[KPP_NVAR], Fcn[KPP_NVAR],
dFdT[KPP_NVAR],
Jac0[KPP_LU_NONZERO], Ghimj[KPP_LU_NONZERO];
KPP_REAL K[KPP_NVAR*ros_S];
KPP_REAL H, T, Hnew, HC, HG, Fac, Tau;
KPP_REAL Err, Yerr[KPP_NVAR];
int Pivot[KPP_NVAR], Direction, ioffset, j, istage;
char RejectLastH, RejectMoreH;
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
/*~~~> INITIAL PREPARATIONS */
T = Tstart;
*Hexit = 0.0;
H = MIN(Hstart,Hmax);
if (ABS(H) <= 10.0*Roundoff)
H = DeltaMin;
if (Tend >= Tstart) {
Direction = +1;
} else {
Direction = -1;
} /* end if */
RejectLastH=0; RejectMoreH=0;
/*~~~> Time loop begins below */
while ( ( (Direction > 0) && ((T-Tend)+Roundoff <= ZERO) )
|| ( (Direction < 0) && ((Tend-T)+Roundoff <= ZERO) ) ) {
if ( Nstp > Max_no_steps ) { /* Too many steps */
*Texit = T;
return ros_ErrorMsg(-6,T,H);
}
if ( ((T+0.1*H) == T) || (H <= Roundoff) ) { /* Step size too small */
*Texit = T;
return ros_ErrorMsg(-7,T,H);
}
/*~~~> Limit H if necessary to avoid going beyond Tend */
*Hexit = H;
H = MIN(H,ABS(Tend-T));
/*~~~> Compute the function at current time */
(*ode_Fun)(T,Y,Fcn0);
/*~~~> Compute the function derivative with respect to T */
if (!Autonomous)
ros_FunTimeDerivative ( T, Roundoff, Y, Fcn0, ode_Fun, dFdT );
/*~~~> Compute the Jacobian at current time */
(*ode_Jac)(T,Y,Jac0);
/*~~~> Repeat step calculation until current step accepted */
while (1) { /* WHILE STEP NOT ACCEPTED */
if( ros_PrepareMatrix( &H, Direction, ros_Gamma[0],
Jac0, Ghimj, Pivot) ) { /* More than 5 consecutive failed decompositions */
*Texit = T;
return ros_ErrorMsg(-8,T,H);
}
/*~~~> Compute the stages */
for (istage = 1; istage <= ros_S; istage++) {
/* Current istage offset. Current istage vector is K[ioffset:ioffset+KPP_NVAR-1] */
ioffset = KPP_NVAR*(istage-1);
/* For the 1st istage the function has been computed previously */
if ( istage == 1 )
WCOPY(KPP_NVAR,Fcn0,1,Fcn,1);
else { /* istage>1 and a new function evaluation is needed at current istage */
if ( ros_NewF[istage-1] ) {
WCOPY(KPP_NVAR,Y,1,Ynew,1);
for (j = 1; j <= istage-1; j++)
WAXPY(KPP_NVAR,ros_A[(istage-1)*(istage-2)/2+j-1],
&K[KPP_NVAR*(j-1)],1,Ynew,1);
Tau = T + ros_Alpha[istage-1]*Direction*H;
(*ode_Fun)(Tau,Ynew,Fcn);
} /*end if ros_NewF(istage)*/
} /* end if istage */
WCOPY(KPP_NVAR,Fcn,1,&K[ioffset],1);
for (j = 1; j <= istage-1; j++) {
HC = ros_C[(istage-1)*(istage-2)/2+j-1]/(Direction*H);
WAXPY(KPP_NVAR,HC,&K[KPP_NVAR*(j-1)],1,&K[ioffset],1);
} /* for j */
if ((!Autonomous) && (ros_Gamma[istage-1])) {
HG = Direction*H*ros_Gamma[istage-1];
WAXPY(KPP_NVAR,HG,dFdT,1,&K[ioffset],1);
} /* end if !Autonomous */
SolveTemplate(Ghimj, Pivot, &K[ioffset]);
} /* for istage */
/*~~~> Compute the new solution */
WCOPY(KPP_NVAR,Y,1,Ynew,1);
for (j=1; j<=ros_S; j++)
WAXPY(KPP_NVAR,ros_M[j-1],&K[KPP_NVAR*(j-1)],1,Ynew,1);
/*~~~> Compute the error estimation */
WSCAL(KPP_NVAR,ZERO,Yerr,1);
for (j=1; j<=ros_S; j++)
WAXPY(KPP_NVAR,ros_E[j-1],&K[KPP_NVAR*(j-1)],1,Yerr,1);
Err = ros_ErrorNorm ( Y, Ynew, Yerr, AbsTol, RelTol, VectorTol );
/*~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax */
Fac = MIN(FacMax,MAX(FacMin,FacSafe/pow(Err,ONE/ros_ELO)));
Hnew = H*Fac;
/*~~~> Check the error magnitude and adjust step size */
Nstp++;
if ( (Err <= ONE) || (H <= Hmin) ) { /*~~~> Accept step */
Nacc++;
WCOPY(KPP_NVAR,Ynew,1,Y,1);
T += Direction*H;
Hnew = MAX(Hmin,MIN(Hnew,Hmax));
/* No step size increase after a rejected step */
if (RejectLastH)
Hnew = MIN(Hnew,H);
RejectLastH = 0; RejectMoreH = 0;
H = Hnew;
break; /* EXIT THE LOOP: WHILE STEP NOT ACCEPTED */
} else { /*~~~> Reject step */
if (Nacc >= 1)
Nrej++;
if (RejectMoreH)
Hnew=H*FacRej;
RejectMoreH = RejectLastH; RejectLastH = 1;
H = Hnew;
} /* end if Err <= 1 */
} /* while LOOP: WHILE STEP NOT ACCEPTED */
} /* while: time loop */
/*~~~> The integration was successful */
*Texit = T;
return 1;
} /* RosenbrockIntegrator */
