Skip to main content

replacement - Looking for an elegant way to solve a (system of) ODEs/functional equations with undetermined coefficients


I want to solve an ODE using undetermined coefficients/guess-and-verify and am looking for an elegant way to use this technique. I am running into a few ugly warts. Here is a basic implementation for a simple example:


ode = r v[z] == Exp[z] + g v'[z] + s^2/2 v''[z]
guess = {v[z_] -> a Exp[z] + b Exp[c z]} (* for some a,b,c*)

(* Inelegance 1: how can I substitute the guess into the ode directly?
For example, ode //. guess doesn't work *)
guessderivs =
Union[guess, {v'[z_] -> (D[v[z] /. guess, z]), v''[z_] -> (D[v[z] /. guess, z, z])}]

(* ugly, but complete now. Substitute*)

odesub = ode //. guessderivs // FullSimplify
(* => e^z (1 + a (g - r)) + b e^(c z) (c g - r) == 0 *)

(*Inelegance #2: This is an easy example, but is there a standard way to
get equations to solve for all z? SolveAlways[odesub,z] didn't work *)

(* Doing it manually works, of course*)
a$sub = First@Solve[(2 + a (2 g - 2 r + s^2)) == 0, a]

c$sub = Solve[(2 c g - 2 r + c^2 s^2) == 0,c]

(* The last constant, b, would come from an initial value. mine is v'[0]==0 for example *)

To summarize where this is ugly:




  1. How to make a guess substitution of a functional form, and have the derivatives work (i.e. v'[z] //. {v[z_]-> a Exp[b z]} but actually substitute the derivatives) I recognize the problem here that FullForm[v'[z]] == Derivative[1][v][z] so the rule doesn't match, but is there a nice way to replace these generally?





  2. How to get the system of equations (in general) with undetermined coefficients? I thought that SolveAlways was supposed to do this?




EDIT: It looks like the cleanest method is from @RiemannZeta which is to give a list of linearly independent basis vectors (anonymous as described by @belisarius), substitute, and find the coefficients.


For this setup, let me give the following goal for some generic UndeterminedCoefficientsSystem function:


ode = {r v[z] == Exp[z] + g v'[z] + s^2/2 v''[z]};
ic = {v'[0] == 0};
equations = Union[ode, ic]; (* In reality, I will be trying a system of equations *)
v$basis = {Exp[#]&, Exp[d #]&, # &}; (* with an addition to test, which should be 0 here *)
coefficientsystem = UndeterminedCoefficientSystem[{{v, v$basis}}, equations};


(* Assume that this function generates a list of coefficients of the form C[1][1], C[1][2],... for the entire basis then it substitutes into the set of equations *)
coefficientsystem == {C[1][1] == -1 - g C[1][1] + r C[1][1] - 1/2 s^2 C[1][1],
C[1][2] == -d g C[1][2] + r C[1][2] - 1/2 d^2 s^2 C[1][2],
C[1][3] == r C[1][3],
C[1][1] + d C[1][2] + C[1][3] == 0
} (* The last equation comes from the v'[0]==0 *)

So basically, the function does the following:




  1. For arguments, takes a list of function name with a list of basis as anonymous functions. Here it is only 1, but I need to use this to solve a more complicated system of ODEs. Index the functions by j.

  2. Take each function with index j and basis of length i of anonymous functions. Generate a list of coefficients for C[i][j] of these.

  3. For each function and basis, create a guess anonymous function as the linear combination of these, with the C[i][j] coefficients. Create a substitution rule given the function name to the linear combination of basis.

  4. For each given equation, substitute in the concatenated list of guesses (for each j)

  5. For each basis, for each equation, find the coefficient with @RiemannZeta technique and append the whole list (if there are different basis for the different functions, it is reasonable to just look for the coefficients of the union of all anoymous basis)

  6. Return the whole list of equations.


Does that make sense as a generic function? It should work for any sort of functional equations, and not just ODEs.


(I am getting stuck very early here. For example, we need to have anonymous guesses (to ensure that we can both take derivatives and evaluate at initial values such as v'[0] == 0) but how do I take two anonymous functions and concatenate a linear combination to form a new one?)



Answer




To see the steps you can just ask Wolfram|Alpha :)


WolframAlpha["r v[z] == Exp[z] + g v'[z] + s^2/2 v''[z]"]

But if you're wanting to do it yourself, here's what I recommend.




  1. I'd do the following:


    guess = a Exp[z] + b Exp[c z];
    odesub = ode /. {v[z] -> guess, Derivative[n_][v][z] :> D[guess, {z,n}]} // FullSimplify


    (* b E^(c z) (2 c g - 2 r + c^2 s^2) + E^z (2 + a (2 g - 2 r + s^2)) == 0 *)


  2. For this step, I think you want to equate coefficients of your linearly independent basis functions to zero.


    coeffs = Coefficient[Subtract @@ odesub, {Exp[z], Exp[c z]}]
    (* {2 + 2 a g - 2 a r + a s^2, 2 b c g - 2 b r + b c^2 s^2} *)

    Solve[Thread[coeffs == 0], {a, c}]
    (* {{a -> -2/(2 g - 2 r + s^2), c -> (-g - Sqrt[g^2 + 2 r s^2])/s^2},
    {a -> -2/(2 g - 2 r + s^2), c -> (-g + Sqrt[g^2 + 2 r s^2])/s^2}} *)



Comments

Popular posts from this blog

plotting - Filling between two spheres in SphericalPlot3D

Manipulate[ SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, Mesh -> None, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], {n, 0, 1}] I cant' seem to be able to make a filling between two spheres. I've already tried the obvious Filling -> {1 -> {2}} but Mathematica doesn't seem to like that option. Is there any easy way around this or ... Answer There is no built-in filling in SphericalPlot3D . One option is to use ParametricPlot3D to draw the surfaces between the two shells: Manipulate[ Show[SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], ParametricPlot3D[{ r {Sin[t] Cos[1.5 Pi], Sin[t] Sin[1.5 Pi], Cos[t]}, r {Sin[t] Cos[0 Pi], Sin[t] Sin[0 Pi], Cos[t]}}, {r, 1, 2 - n}, {t, 0, Pi}, PlotStyle -> Yellow, Mesh -> {2, 15}]], {n, 0, 1}]

plotting - Plot 4D data with color as 4th dimension

I have a list of 4D data (x position, y position, amplitude, wavelength). I want to plot x, y, and amplitude on a 3D plot and have the color of the points correspond to the wavelength. I have seen many examples using functions to define color but my wavelength cannot be expressed by an analytic function. Is there a simple way to do this? Answer Here a another possible way to visualize 4D data: data = Flatten[Table[{x, y, x^2 + y^2, Sin[x - y]}, {x, -Pi, Pi,Pi/10}, {y,-Pi,Pi, Pi/10}], 1]; You can use the function Point along with VertexColors . Now the points are places using the first three elements and the color is determined by the fourth. In this case I used Hue, but you can use whatever you prefer. Graphics3D[ Point[data[[All, 1 ;; 3]], VertexColors -> Hue /@ data[[All, 4]]], Axes -> True, BoxRatios -> {1, 1, 1/GoldenRatio}]

plotting - Adding a thick curve to a regionplot

Suppose we have the following simple RegionPlot: f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}] Now I'm trying to change the curve defined by $y=g[x]$ into a thick black curve, while leaving all other boundaries in the plot unchanged. I've tried adding the region $y=g[x]$ and playing with the plotstyle, which didn't work, and I've tried BoundaryStyle, which changed all the boundaries in the plot. Now I'm kinda out of ideas... Any help would be appreciated! Answer With f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 You can use Epilog to add the thick line: RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}, PlotPoints -> 50, Epilog -> (Plot[g[x], {x, 0, 2}, PlotStyle -> {Black, Thick}][[1]]), PlotStyle -> {Directive[Yellow, Opacity[0.4]], Directive[Pink, Opacity[0.4]],