Plotting the RealExponent of difference of two solutions of a equation with respect to delay

Question

I have obtained the following equations from Wolfram documentation.

sol = 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 = 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}]];
ListPlot[Table[{t, RealExponent[(x[t] /. sol) - (x[t] /. solrk)]}, {t, 17, 5000, 17}]]

The same equation has been solved twice using two different methods and RealExponent[d] has been plotted with respect to time. Here d is the difference between x[t] computed by the different methods.

My question is How to plot RealExponent[d] with respect to τ, where τ can be varied from 14 to 40.

Answer 1

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.