How to specify initial conditions at parts of domain in Mathematica? - wolfram-mathematica

I try to compare solution of my Finite Volume Method to solution of Mathematica for simple Heat Equation U_t = U_xx. For this I have to specify initial and boundary condition for NDSolve function in Mathematica. I would like to have on boundaries U = 90. As initial condition I would like to have 100 in all square domain except boundaries. How can I do this? Obviously my code doesn't work.
FUNC = NDSolve[{D[T[x, y, t], t] == (D[T[x, y, t], x, x] + D[T[x, y, t], y, y]),
T[x, y, 0] == 100, T[0, y, t] == 90, T[9, y, t] == 90,
T[x, 0, t] == 90, T[x, 9, t] == 90},
T, {x, 0, 9}, {y, 0, 9}, {t, 0, 6}];
It try to set initial condition at all domain equals to 100.

Actually, with a small modification your code does work.
FUNC = T /.
NDSolve[{
D[T[x, y, t], t] == (D[T[x, y, t], x, x] + D[T[x, y, t], y, y]),
T[x, y, 0] == 100, T[0, y, t] == 90, T[9, y, t] == 90,
T[x, 0, t] == 90, T[x, 9, t] == 90},
T, {x, 0, 9}, {y, 0, 9}, {t, 0, 10}][[1]]
Modifications are the T/. (ReplaceAll) part in front and the [[1]] (Part) at the end; you may want to look these op in the documentation. Thery are necessary to massage the output into the correct shape .
You get an error message about inconsistency of boundary and initial conditions (which is correct). The result is nevertheless usable.
Alternatively, you can change the initial condition so as to read
FUNC = T /.
NDSolve[{
D[T[x, y, t], t] == (D[T[x, y, t], x, x] + D[T[x, y, t], y, y]),
T[x, y, 0] == If[x == 0 || x == 9 || y == 0 || y == 9, 90, 100],
T[0, y, t] == 90, T[9, y, t] == 90, T[x, 0, t] == 90,
T[x, 9, t] == 90}, T, {x, 0, 9}, {y, 0, 9}, {t, 0, 10}][[1]]
You can now do lots of things with this function like e.g. a Manipulate:
Manipulate[ContourPlot[FUNC[x, y, t], {x, 0, 9}, {y, 0, 9}], {t, 0, 10}]
or an animated GIF:
anim = Table[DensityPlot[FUNC[x, y, t], {x, 0, 9}, {y, 0, 9},
ColorFunctionScaling -> False, PlotPoints -> 50,
ColorFunction -> (Hue[Rescale[#, {50, 100}], 1, 1] &)],
{t, 0, 10, .2}];
Export[ToFileName[$UserDocumentsDirectory, "anim.gif"], anim, "GIF"]

Related

Mathematica: How to evaluate this function?

I need to evaluate a function in 2D but it has three unknowns, the two arguments (x, y) and alpha. I need to evaluate x and y between {0,100}, while alpha between {0,1}.
The function is: f(x, y) = x ^ (a) * y ^ (1-a)
Thank you!
Not sure what "evaluate a function in 2D" means. Some options
f[x_, y_, a_] := x^a y^(1 - a)
Generate plots for different values of a
Table[Plot3D[f[x, y, a], {x, 0, 100}, {y, 0, 100},
PlotLabel -> "a = " <> ToString#a], {a, 0, 1, .1}] //
Partition[#, UpTo[4]] & //
Grid
Generate contours
ContourPlot3D[f[x, y, a], {x, 0, 100}, {y, 0, 100}, {a, 0, 1}, Contours -> 5]

Unable to find a solution for 2d nonlinear heat equation in mathematica

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'm trying to solve a very simple heat conduction differential equation with NDSolve in Mathematica, but the solution I get is quite strange…

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…

Find zeros for solutions to differential equations in Mathematica

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}

Mathematica 2D Heat Equation Animation

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 :)

Resources