This is a very simple one-dimensional solid-phase heat conduction differential equation, here is my code:
a = NDSolve[{D[721.7013888888889` 0.009129691127380562` tes[t, x],
t] == 2.04988920646734`*^-6 D[tes[t, x], x, x],
tes[t, 0] == 298 + 200 t, tes[t, 0.01] == 298,
tes[0, x] == 298}, {tes[t, x]}, {t, 0, 0.005}, {x, 0, 0.01}]
Plot3D[tes[t, x] /. a, {t, 0, 0.005}, {x, 0, 0.01}, PlotRange -> All]
(Plot[(tes[t, x] /. a) /. t -> 0.0005, {x, 0, 0.01},
PlotRange -> All])
After you run it, you will see: the temperature (in the equation it's named as tes) is lower than 298! It's ridiculous, it's against the second law of thermodynamics…how does this error come out? How can I correct it?
I'll deal only with the numerical aspects of this. First, scale time and space so that your equation becomes $\partial_t f=\partial_{x,x}f$ in the dimensionless units. then, for instance,
a = NDSolve[{D[ tes[t, x], t] == D[tes[t, x], x, x],
tes[t, 0] \[Equal] 1,
tes[t, 1] \[Equal] 1,
tes[0, x] \[Equal] Cos[2 \[Pi]*x/2]^2},
tes[t, x],
{t, 0, 1},
{x, 0, 1}
]
Plot3D[tes[t, x] /. a, {t, 0, .2}, {x, 0, 1}, PlotRange -> All,
AxesLabel \[Rule] {"t", "x"}]
so heat just diffuses inwards (note I changed the boundary and initial conditions).
This problem has been solved here,
I should admit that I haven't catch the nature yet at the time I posted this question…
Related
Please help me to find a solution in a Wolfram Mathematica program.
I have several times checked the accuracy of the entered data. They are true. The solution must exist. But a Wolfram provides either the empty graph (for any point in time), or an error "NDSolve::eerr". Here is my code:
solution =
NDSolve[{D[fun[t, x, y], t] ==
Exp[-t]*Cos[Pi*y] + D[fun[t, x, y], {x, 2}] +
D[fun[t, x, y], {y, 2}], fun[t, 0, y] == 0, fun[t, 1, y] == 0,
fun[0, x, y] == 0, (D[fun[t, x, y], y] /. y -> 0) ==
0, (D[fun[t, x, y], y] /. y -> 1) == 0},
fun[t, x, y], {t, 0, 5}, {x, 0, 1}, {y, 0, 1}]
Plot3D[Evaluate[First[fun[5, x, y] /. solution]], {x, 0, 1}, {y, 0,
1}, PlotRange -> All, Mesh -> None, PlotPoints -> 40]
And here is the error code
NDSolve::eerr: Warning: scaled local spatial error estimate of
140.65851971330582at t = 5. in the direction of independent variable x is much greater than the prescribed error tolerance. Grid
spacing with 15 points may be too large to achieve the desired
accuracy or precision. A singularity may have formed or a smaller grid
spacing can be specified using the MaxStepSize or MinPoints method
options.
Please advise what can be done in such a situation. Many thanks in advance!
I ran into this problem when I try to solve a partial differential equation. Here is my code:
dd = NDSolve[{D[tes[t, x], t] ==D[tes[t, x], x, x] + Exp[-1/(tes[t, x])],
tes[t, 0] == 1, tes[t, -1] == 1, tes[0, x] == 1}, {tes[t, x]}, {t, 0, 5}, {x, -1, 0}]
f[t_, x_] = tes[t, x] /. dd
kkk = FunctionInterpolation[Integrate[Exp[-1.1/( Evaluate[f[t, x]])], {x, -1, 0}], {t, 0, 0.05}]
kkg[t_] = Integrate[Exp[-1.1/( Evaluate[f[t, x]])], {x, -1, 0}]
Plot[Evaluate[kkk[t]] - Evaluate[kkg[t]], {t, 0, 0.05}]
N[kkg[0.01] - kkk[0.01], 1]
It's strange that the deviation showed in the graph reaches up to more than 5*10^-7 around t=0.01, while it's only -3.88578*10^-16 when calculated by N[kkg[0.01] - kkk[0.01], 1], I wonder how this error comes out.
By the way, I feel it strange that the output of N[kkg[0.01] - kkk[0.01], 1] has so many decimal places, I've set the precision as 1, right?
Using Mathematica 7 the plot I get does not show a peak at 0.01:
Plot[kkk[t] - kkg[t], {t, 0, 0.05}, GridLines -> Automatic]
There is a peak at about 0.00754:
kkk[0.00754] - kkg[0.00754] // N
{6.50604*10^-7}
Regarding N, it does not change the precision of machine precision numbers as it does for exact or arbitrary precision ones:
N[{1.23456789, Pi, 1.23456789`50}, 2]
Precision /# %
{1.23457, 3.1, 1.2}
{MachinePrecision, 2., 2.}
Look at SetPrecision if you want to force (fake) a precision, and NumberForm if you want to print a number in a specific format.
Given the following code:
s := NDSolve[{x''[t] == -x[t], x[0] == 1, x'[0] == 1}, x, {t, 0, 5 }]
Plot[Evaluate[{x[t]} /. s], {t, 0, 3}]
This plots the solution to the differential equation. How would I numerically solve for a zero of x[t] where t ranges between 0 and 3?
The original question was answered by #rcollyer. I am answering the question you posted in your first comment to rcollyer's answer:
But what if instead our s is "s := NDSolve[{x'[t]^2 == -x[t]^3 - x[t] + 1, x[0] == 0.5}, x, {t, 0, 5}]" Then the FindRoot function just gives back an error while the plot shows that there is a zero around 0.6 or so.
So:
s = NDSolve[{x'[t]^2 == -x[t]^3 - x[t] + 1, x[0] == 0.5},
x, {t, 0, 1}, Method -> "StiffnessSwitching"];
Plot[Evaluate[{x[t]} /. s], {t, 0, 1}]
FindRoot[x[t] /. s[[1]], {t, 0, 1}]
{t -> 0.60527}
Edit
Answering rcollyer's comment, the "second line" comes from the squared derivative, as in:
s = NDSolve[{x'[t]^2 == Sin[t], x[0] == 0.5}, x[t], {t, 0, Pi}];
Plot[Evaluate[{x[t]} /. s], {t, 0, Pi}]
Coming from:
DSolve[{x'[t]^2 == Sin[t]}, x[t], t]
(*
{{x[t] -> C[1] - 2 EllipticE[1/2 (Pi/2 - t), 2]},
{x[t] -> C[1] + 2 EllipticE[1/2 (Pi/2 - t), 2]}}
*)
FindRoot works
In[1]:= FindRoot[x[t] /. s, {t, 0, 3}]
Out[1]:= {t -> 2.35619}
I'm working on mapping a temperature gradient in two dimensions and having a lot of trouble. My current approach is to define an Interpolating Function and then try to graph it a lot of times, then animate that table of graphs. Here's what I have so far:
RT = 388.726919
R = 1
FUNC == NDSolve[{D[T[x, y, t], t] ==
RT*(D[T[x, y, t], x, x] + D[T[x, y, t], y, y]),
T[x, y, 0] == 0,
T[0, y, t] == R*t,
T[9, y, t] == R*t,
T[x, 0, t] == R*t,
T[x, 9, t] == R*t},
T, {x, 0, 9}, {y, 0, 9}, {t, 0, 6}]
So the first two variables just control the rate of change. The equation I'm solving is the basic 2D heat equation, where dT/dt=a(d^2T/dx^2+d^2T/dy^2). The initial conditions set everything to 0, then define the edges as the source of the heat change. Right now it sweeps over a 9x9 block from t=0 to t=6.
The second part attempts to animate the function working.
ListAnimate[
Table[
DensityPlot[T[x, y, t] /. FUNC, {x, 0, 9}, {y, 0, 9}, Mesh -> 9]
, {t, 0, 6}]
]
Unfortunately, this doesn't work, and I'm going crazy trying to figure out why. I first thought it had something to do with the Interpolating Function but now I'm not so confident that the animating code works either. Anyone have any ideas?
Just a quick check:
RT = 1
R = 1
FUNC = NDSolve[{D[T[x, y, t], t] ==
RT*(D[T[x, y, t], x, x] + D[T[x, y, t], y, y]), T[x, y, 0] == 0,
T[0, y, t] == R*t,
T[9, y, t] == R*t,
T[x, 0, t] == R*t,
T[x, 9, t] == R*t}, T,
{x, 0, 9}, {y, 0, 9}, {t, 0, 6}];
a = Table[
Plot3D[T[x, y, t] /. FUNC, {x, 0, 9}, {y, 0, 9}, Mesh -> 15,
PlotRange -> {{0, 9}, {0, 9}, {-1, 10}},
ColorFunction -> Function[{x, y, z}, Hue[.3 (1 - z)]]], {t, 0, 6}]
Export["c:\anim.gif", a]
PS: A lot of mistakes are avoided by using a lowercase letter as the first char for your symbols...
I'm with Mark -- there is nothing wrong with your program. The problem is that nothing interesting happens to your function after t=0: Try having a look at
ListAnimate[
Table[Plot3D[T[x, y, t] /. FUNC, {x, 0, 9}, {y, 0, 9}, Mesh -> 9], {t, 0, 6}]]
As you can see, all that happens is a scaling, so that when DensityPlot rescales each frame independently, they end up looking identical :)
i'd like to have something like this
w[w1_] :=
NDSolve[{y''[x] + y[x] == 2, y[0] == w1, y'[0] == 0}, y, {x, 0, 30}]
this seems like it works better but i think i'm missing smtn
w := NDSolve[{y''[x] + y[x] == 2, y[0] == w1, y'[0] == 0},
y, {x, 0, 30}]
w2 = Table[y[x] /. w, {w1, 0.0, 1.0, 0.5}]
because when i try to make a table, it doesn't work:
Table[Evaluate[y[x] /. w2], {x, 10, 30, 10}]
i get an error:
ReplaceAll::reps: {<<1>>[x]} is neither a list of replacement rules nor a valid dispatch table, and so cannot be used for replacing. >>
ps: is there a better place to ask questions like that? mathematica doesn't have supported forums and only has mathGroup e-mail list. it would be nice if stackoverflow would have more specific mathematica tags like simplify, ndsolve, plot manipulation
There are a lot of ways to do that. One is:
w[w1_] := NDSolve[{y''[x] + y[x] == 2,
y'[0] == 0}, y[0] == w1,
y[x], {x, 0, 30}];
Table[Table[{w1,x,y[x] /. w[w1]}, {w1, 0., 1.0, 0.5}]/. x -> u, {u, 10, 30, 10}]
Output:
{{{0., 10, {3.67814}}, {0.5, 10, {3.25861}}, {1.,10, {2.83907}}},
{{0., 20, {1.18384}}, {0.5, 20, {1.38788}}, {1.,20, {1.59192}}},
{{0., 30, {1.6915}}, {0.5, 30, {1.76862}}, {1.,30, {1.84575}}}}
I see you already chose an answer, but I want to toss this solution for families of linear equations up. Specifically, this is to model a slight variation on Lotka-Volterra.
(*Put everything in a module to scope x and y correctly.*)
Module[{x, y},
(*Build a function to wrap NDSolve, and pass it
the initial conditions and range.*)
soln[iCond_, tRange_, scenario_] :=
NDSolve[{
x'[t] == -scenario[[1]] x[t] + scenario[[2]] x[t]*y[t],
y'[t] == (scenario[[3]] - scenario[[4]]*y[t]) -
scenario[[5]] x[t]*y[t],
x[0] == iCond[[1]],
y[0] == iCond[[2]]
},
{x[t], y[t]},
{t, tRange[[1]], tRange[[2]]}
];
(*Build a plot generator*)
GeneratePlot[{iCond_, tRange_, scen_,
window_}] :=
(*Find a way to catch errors and perturb iCond*)
ParametricPlot[
Evaluate[{x[t], y[t]} /. soln[iCond, tRange, scen]],
{t, tRange[[1]], tRange[[2]]},
PlotRange -> window,
PlotStyle -> Thin, LabelStyle -> Medium
];
(*Call the plot generator with different starting conditions*)
graph[scenario_, tRange_, window_, points_] :=
{plots = {};
istep = (window[[1, 2]] - window[[1, 1]])/(points[[1]]+1);
jstep = (window[[2, 2]] - window[[2, 1]])/(points[[2]]+1);
Do[Do[
AppendTo[plots, {{i, j}, tRange, scenario, window}]
, {j, window[[2, 1]] + jstep, window[[2, 2]] - jstep, jstep}
], {i, window[[1, 1]] + istep, window[[1, 2]] - istep, istep}];
Map[GeneratePlot, plots]
}
]
]
We can then use Animate (or table, but animate is awesome)
tRange = {0, 4};
window = {{0, 8}, {0, 6}};
points = {5, 5}
Animate[Show[graph[{3, 1, 8, 2, 0.5},
{0, t}, window, points]], {t, 0.01, 5},
AnimationRunning -> False]