Skip to main content
added 99 characters in body
Source Link
Michael E2
  • 244.7k
  • 18
  • 350
  • 774

This is basically what I think you're looking for. The RealExponent of the difference is stored in red as a list of triples {τ, t, d}.

Clear[x, t, τ, sol, solrk]

sol[τ_] := Block[{t, x},  (* so  Table[]  doesn't overwrite  t  *)
   sol[τ] =               (* remember the solution so that it won't be recomputed *)
    First[NDSolve[{x'[t] == (1/4) x[t - τ]/(1 + x[t - τ]^10) - x[t]/10, 
       x[t /; t <= 0] == 1/2}, x, {t, 0, 5000}, 
      MaxSteps -> ∞]]
   ];

solrk[τ_] := Block[{t, x},
   solrk[τ] = 
    First[NDSolve[{x'[t] == (1/4) x[t - τ]/(1 + x[t - τ]^10) - x[t]/10, 
       x[t /; t <= 0] == 1/2}, x, {t, 0, 5000}, 
      MaxSteps -> ∞, 
      Method -> {"ExplicitRungeKutta", "DifferenceOrder" -> 3}]]
   ];

red = Table[{τ, t, RealExponent[(x[t] /. sol[τ]) - (x[t] /. solrk[τ])]},
   {τ, 14, 40, 4}, {t, 17, 5000, 17}];

ListPointPlot3D[red, Filling -> Bottom]

Mathematica graphics The right plot is with a Δτ in Table[] of 2.

This is basically what I think you're looking for. The RealExponent of the difference is stored in red as a list of triples {τ, t, d}.

Clear[x, t, τ, sol, solrk]

sol[τ_] := Block[{t, x},  (* so  Table[]  doesn't overwrite  t  *)
   sol[τ] =               (* remember the solution so that it won't be recomputed *)
    First[NDSolve[{x'[t] == (1/4) x[t - τ]/(1 + x[t - τ]^10) - x[t]/10, 
       x[t /; t <= 0] == 1/2}, x, {t, 0, 5000}, 
      MaxSteps -> ∞]]
   ];

solrk[τ_] := Block[{t, x},
   solrk[τ] = 
    First[NDSolve[{x'[t] == (1/4) x[t - τ]/(1 + x[t - τ]^10) - x[t]/10, 
       x[t /; t <= 0] == 1/2}, x, {t, 0, 5000}, 
      MaxSteps -> ∞, 
      Method -> {"ExplicitRungeKutta", "DifferenceOrder" -> 3}]]
   ];

red = Table[{τ, t, RealExponent[(x[t] /. sol[τ]) - (x[t] /. solrk[τ])]},
   {τ, 14, 40, 4}, {t, 17, 5000, 17}];

ListPointPlot3D[red, Filling -> Bottom]

Mathematica graphics

This is basically what I think you're looking for. The RealExponent of the difference is stored in red as a list of triples {τ, t, d}.

Clear[x, t, τ, sol, solrk]

sol[τ_] := Block[{t, x},  (* so  Table[]  doesn't overwrite  t  *)
   sol[τ] =               (* remember the solution so that it won't be recomputed *)
    First[NDSolve[{x'[t] == (1/4) x[t - τ]/(1 + x[t - τ]^10) - x[t]/10, 
       x[t /; t <= 0] == 1/2}, x, {t, 0, 5000}, 
      MaxSteps -> ∞]]
   ];

solrk[τ_] := Block[{t, x},
   solrk[τ] = 
    First[NDSolve[{x'[t] == (1/4) x[t - τ]/(1 + x[t - τ]^10) - x[t]/10, 
       x[t /; t <= 0] == 1/2}, x, {t, 0, 5000}, 
      MaxSteps -> ∞, Method -> {"ExplicitRungeKutta", "DifferenceOrder" -> 3}]]
   ];

red = Table[{τ, t, RealExponent[(x[t] /. sol[τ]) - (x[t] /. solrk[τ])]},
   {τ, 14, 40, 4}, {t, 17, 5000, 17}];

ListPointPlot3D[red, Filling -> Bottom]

The right plot is with a Δτ in Table[] of 2.

Source Link
Michael E2
  • 244.7k
  • 18
  • 350
  • 774

This is basically what I think you're looking for. The RealExponent of the difference is stored in red as a list of triples {τ, t, d}.

Clear[x, t, τ, sol, solrk]

sol[τ_] := Block[{t, x},  (* so  Table[]  doesn't overwrite  t  *)
   sol[τ] =               (* remember the solution so that it won't be recomputed *)
    First[NDSolve[{x'[t] == (1/4) x[t - τ]/(1 + x[t - τ]^10) - x[t]/10, 
       x[t /; t <= 0] == 1/2}, x, {t, 0, 5000}, 
      MaxSteps -> ∞]]
   ];

solrk[τ_] := Block[{t, x},
   solrk[τ] = 
    First[NDSolve[{x'[t] == (1/4) x[t - τ]/(1 + x[t - τ]^10) - x[t]/10, 
       x[t /; t <= 0] == 1/2}, x, {t, 0, 5000}, 
      MaxSteps -> ∞, 
      Method -> {"ExplicitRungeKutta", "DifferenceOrder" -> 3}]]
   ];

red = Table[{τ, t, RealExponent[(x[t] /. sol[τ]) - (x[t] /. solrk[τ])]},
   {τ, 14, 40, 4}, {t, 17, 5000, 17}];

ListPointPlot3D[red, Filling -> Bottom]

Mathematica graphics