Skip to main content

differential equations - Numerical solution of IVP for linear ODE with variable coefficient runs wild soon


Cross posted in scicomp.SE.


A friend of mine showed me this initial value problem (IVP) for a linear ordinary differential equation (ODE) with variable coefficient:



$$y''(x)=\left(x^2-1\right) y(x)$$$$y(0)=1$$$$y'(0)=0$$


Seems to be a simple one, right? Actually it can be solved analytically by DSolve:


asol = DSolve[{y''[x] == (x^2 - 1) y[x], y[0] == 1, y'[0] == 0}, y[x], x]


{{y[x] -> E^(-(x^2/2))}}

But its numerical solution given by NDSolve runs wild very fast:


l = 10;
nsol = NDSolve[{y''[x] == (x^2 - 1) y[x], y[0] == 1, y'[0] == 0},

y, {x, 0, l}]; // AbsoluteTiming
Manipulate[Plot[y[x] /. nsol // Evaluate, {x, 0, l2},
PlotRange -> {{0, 7}, {-10, 1}}], {l2, 1/10, 7}]


{0.015600, Null}

enter image description here


How to resolve the problem?


Well, actually I found two solution for this problem but one is time-consuming and the other is limited so I'm not quite satisfied.



Solution 1


A higher WorkingPrecision will help:


l = 10;
nsol = NDSolve[{y''[x] == (x^2 - 1) y[x], y[0] == 1, y'[0] == 0},
y, {x, 0, l}, WorkingPrecision -> 50]; // AbsoluteTiming
Plot[y[x] /. nsol, {x, 0, l}, PlotRange -> All]


{2.857000, Null}


enter image description here


Nonetheless, this solution is slow, and will need a higher WorkingPrecision and be even slower when l gets larger.


Solution 2


Noticing the analytic solution involves a Exp, given the experience that Exp often causes trouble in numerical calculation, the transformation $y(x)=e^{z(x)}$ is used:


l = 50;
rule = y -> (Exp[z@#] &);

(* z[0] == 0 is manually substituted because it seems that
NDSolveValue has some difficulty in understanding y[0] == 1 /. rule *)
nsol = NDSolveValue[{y''[x] == (x^2 - 1) y[x], z[0] == 0, y'[0] == 0} /. rule,

z, {x, 0, l}]; // AbsoluteTiming
Plot[Exp@nsol[x], {x, 0, l}, PlotRange -> All]


 {0.013000, Null}

enter image description here


However, as mentioned above, this solution is limited, I wouldn't have thought it out if I was unaware of the analytic solution, and I really doubt if this method can be extended: I guess there's a sort of problem behind this specific example, once it's solved, more complicated problem might be solved too, for example this and this.


I'd appreciate if anyone can give an in-depth explanation for the problem or find a better solution.



Answer




I think this shows what the problem is. The ODE is inherently numerically unstable as any deviation from the exact solution goes to ±∞.


asol = DSolve[{y''[x] == (x^2 - 1) y[x], y[0] == 1, y'[0] == p}, y[x], x];
Manipulate[
Plot[y[x] /. asol /. {{p -> 0}, {p -> 10^(-error)}, {p -> -10^(-error)}} // Evaluate,
{x, 0, 7}, PlotRange -> 2],
{error, 1, 10, Appearance -> "Labeled"}]

Mathematica graphics




Update - Possible workaround



Aside from increasing the working precision and increasing the "DifferenceOrder", one can try the approach I took toward the Airy equation in my answer to how to solve ODE with boundary at infinity, which is similar both in form and in having a single solution (for a given initial value for y[0]) that does not diverge to infinity. For that approach, we have to set up the problem as a boundary-value problem on $[0, \infty)$ instead of an initial-value problem. One can see from the equation that $y = 0$ is a solution, and that for some $x > 1$, if $y$, $y'$ are both positive or both negative, the solution diverges. Thus if a solution crosses the $x$-axis, it will diverge. And if $y$ is positive (negative) and reaches a local minimum (maximum resp.), then $y$ will diverge. Further $y$ cannot approach a finite nonzero value because $|y''|$ will be bounded away from $0$. One might surmise that there is a solution that starts at $y = 1$ and approaches $y = 0$. (It's harder to know that this will have the initial condition $y' = 0$, but I suppose one could check that afterwards. If it doesn't satisfy it, then I suppose the IVP actually has a diverging solution and the straightforward NDSolve solution should be used.)


First we transform the differential equation with the substitutions $x = \tan t$ and $u(t) = y(\tan t)$ to transform $[0,\infty)$ to $[0,\pi/2]$. (You might want to evaluate the NestList separately if you cannot see what it does.)


eqn = (-(x[t]^2 - 1) y[x[t]]
+ D[D[y[x[t]], t]/D[x[t], t], t]/D[x[t], t]) x'[t]^3 == 0 /.
x -> Tan;
bvp = {eqn, u[0] == 1, u[Pi/2] == 0} /.
Solve[NestList[D[#, t] &, u[t] == y[Tan[t]], 2],
{y''[Tan[t]], y'[Tan[t]], y[Tan[t]]}];

femsol = y -> (u[ArcTan[#]] &) /.

First@NDSolve[bvp, u, {t, 0, Pi/2},
Method -> {"FiniteElement", "MeshOptions" -> {"MaxCellMeasure" -> 0.01}}]

Plot[y[x] /. femsol // Evaluate, {x, 0, 7}]

Mathematica graphics


Comparison with the exact solution:


Plot[Exp[-x^2/2] - (y[x] /. femsol) // Evaluate, {x, 0, 7}, PlotRange -> All]

Mathematica graphics



Comments

Popular posts from this blog

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...

plotting - How to draw lines between specified dots on ListPlot?

I would like to create a plot where I have unconnected dots and some connected. So far, I have figured out how to draw the dots. My code is the following: ListPlot[{{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4,13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full] I have thought using ListLinePlot command, but I don't know how to specify to the command to draw only selected lines between the dots. Do have any suggestions/hints on how to do that? Thank you. Answer One possibility would be to use Epilog with Line : ListPlot[ {{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4, 13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full, Epilog -> { Line[ ...