A one-step of a Runge-Kutta method

Manipulate[
Quiet[
x0=0; 
poligonal[x0,f,y0,scheme,h];
escy1=Max[ y1,y0]; escy0=Min[ y1,y0];
If[escy0<0,escy0=1.25*escy0, escy0=0.75*escy0];
If[escy1<0,escy1=0.5*escy1, escy1=1.25*escy1];
Show[If[el,Graphics[{RGBColor[ 1,0.3, 0.05],Dashed,Thick,elocal}],Graphics[]],
flecha0,
Graphics[linea],
Graphics[textual],ListPlot[Puntos,PlotStyle->Directive[PointSize[Large],Blue]], 
Plot[Evaluate[y[t]/.teosol[x0,f,y0,t]],{t,x0,h} ,PlotStyle->{Thickness[0.005],RGBColor[ 0,0, 0]},AxesOrigin->{0,0}],Axes->True,PlotRange->All,AspectRatio->2/3,
ImageSize->{640,440}, PlotLabel->tit,ImagePadding->{{20,20},{20,20}} ]],
(* --- *)
{{f,f1,"y'="},{f1->"-y + cos(x)",f2->"x^2+y^2",f3->"x + 1",f4->"cos(x) y",f5->"(y^2)(1 - x)",f6->"-5 y-2 x + 1",f7->"y (1 - y/10)"},ControlType->PopupMenu,ControlPlacement->Left},
(*  ---  *)
{{y0,1/4,"(Subscript[y, 0])"},-1/2,3/2,1/4,Appearance->"Labeled",Exclusions->0,ControlPlacement->Left,ImageSize->Tiny},
{{h,0.4,"h"},0.05,1.5,0.05,Appearance->"Labeled",Exclusions->0,ControlPlacement->Left,ImageSize->Tiny},
{{scheme,"RK3","scheme"},{"RK1","RK21","RK22","RK3","RK4"},ControlType->PopupMenu,ControlPlacement->Left,ImageSize->Small},
Delimiter,
{{el,False,"local error"},{True,False},ControlPlacement->Left},
{{Puntos,1},ControlType->None},
{{textual,1},ControlType->None},
{{teo,1},ControlType->None},
Delimiter,ControlPlacement->Left,
AutorunSequencing->{1,4},
TrackedSymbols:>{f,y0,h,scheme,tit,y1,el},
Initialization:>(
(* Differential Equations *)
f1[x_,y_]:=-y+Cos[x];
f2[x_,y_]:=x^2+y^2;
f3[x_,y_]:= x+1;
f4[x_,y_]:= Cos[x] y;
f5[x_,y_]:= y^2(1-x);
f6[x_,y_]:= -5 y-2 x+1;
f7[x_,y_]:=   y(1-y/10);
(* Exact solution *)
teosol[x0_,f_,y0_,t_]:=NDSolve[{y'[t]==f[t,y[t]],y[x0]==y0},y,{t,0,h}];
(* Numerical construction of the Runge-Kutta method  *)
poligonal[x0_,f_,y0_,scheme_,h_]:=Module[{nn1,i,t,pp,aux,Y,G,A,b,c,s,des},
(* Choice of the Runge-Kutta scheme *)
Which[
scheme=="RK1",s=1;c={0}; b={1}; A={{0}};tit="y1=y0+h g1";,
scheme=="RK21",s=2;c={0,1}; b={1/2,1/2}; A={{0,0},{1,0}};tit="y1=y0+h/2(g1+g2)";,
scheme=="RK22",s=2;c={0,1/2}; b={0,1}; A={{0,0},{1/2,0}};tit="y1=y0+h g2";,
scheme=="RK3",s=3;c={0,1/2,1}; b={1/6,4/6,1/6}; A={{0,0,0},{1/2,0,0},{-1,2,0}};tit="y1=y0+h/6(g1+4g2+g3)";,
scheme=="RK4",s=4;c={0,1/2,1/2,1}; b={1/6,2/6,2/6,1/6}; A={{0,0,0,0},{1/2,0,0,0},{0,1/2,0,0},{0,0,1,0}};tit="y1=y0+h/6 (g1+2g2+2g3+g4)";
]; 
(* Compute the stages *)
Y=Table[0,{i,1,s}]; G=Y;
For[i=1,i≤s,i++,
Y[[i]]=y0+h*Sum[ A[[i,j]]*G[[j]],{j,1,i-1}];
G[[i]]=f[x0+c[[i]]*h,Y[[i]]];
];
y1=y0+h*Sum[b[[i]]*G[[i]],{i,1,s}];
Puntos=Table[{x0+c[[i]]*h, Y[[i]]},{i,1,s}];

flecha0=Table[0,{i,1,s}];
des=h/8;
For[i=1,i≤s,i++,flecha0[[i]]= Graphics[{Hue[(i-1)/3],Arrow[{{x0+c[[i]]*h,Y[[i]]},{x0+c[[i]]*h+des, Y[[i]]+des*G[[i]]}}]}];
];
argumento= Table[{x0,y0},{i,1,s+1}];
For[i=1,i≤s,i++,
argumento[[i+1]]={x0+h*Sum[b[[j]],{j,1,i}],y0+h*Sum[b[[j]]*G[[j]],{j,1,i}]};
];
linea=Table[{Thickness[0.005],Hue[(i1-1)/3],Line[{argumento[[i1]],argumento[[i1+1]]} ]},{i1,1,s}];
 (* Print text in each arrow *)
textual=Table[0,{i,1,s+2}];
For[i=1,i≤s,i++,
textual[[i]]=Text[Style[Row[{"g",i}],Bold,Medium],{x0+c[[i]]*h+des/2,Y[[i]]+ des/2}]
];
textual[[s+1]]=Text[Style["y0",Bold,Blue,Medium],{x0-des/2,y0},Background->LightBlue];
textual[[s+2]]=Text[Style["y1",Bold,Blue,Medium],{x0+h,y1+des/4}];
elocal=Line[{{x0+h,y1},Flatten[Evaluate[{t,y[t]}/.teosol[x0,f,y0,t]]/.t->x0+h]}];
];)
]

CAPTION

This Demonstration shows the process of geometric construction of a one step of the numerical integration carried out by a Runge–Kutta method. For several initial value problems and Runge-Kutta methods (explicit Euler, Runge, classic, ...), you can select the initial value, the step-size, the initial value (Subscript[y, 0]). You can also plot the local  error at the end of the step-size.

THIS NOTEBOOK IS THE SOURCE CODE FROM

Contributed by: Luis Rández

"A one-step of a Runge-Kutta method"
 http://demonstrations.wolfram.com/AOneStepOfARungeKuttaMethod/
 Wolfram Demonstrations Project
 Published:

A full-function Wolfram Mathematica system is required to edit this notebook.
GET WOLFRAM MATHEMATICA »

© Wolfram Demonstrations Project & Contributors   |   Terms of Use   |   Make a new version of this Demonstration »