Still new to Mathematica syntax. When I do:
DSolve[{
D[u[x, t], {x, 2}] == (1/(v*v))*D[u[x, t], {t, 2}],
u[0, t] == 0,
u[l, 0] == 0
}, u, {x, t}]
it just returns what I entered
DSolve[{(u^(2,0))[x,t]==(u^(0,2))[x,t]/v^2,u[0,t]==0,u[l,0]==0},u,{x,t}]
However, when I remove the boundary conditions, I get
{{u->Function[{x,t},C[1][t-(Sqrt[v^2] x)/v^2]+C[2][t+(Sqrt[v^2] x)/v^2]]}}
with C[1] and C[2] representing the functions for the boundary conditions.
Anyone know why this is happening?
2 things:
Don't you need more boundary and initial conditions than just 2? You have second order derivatives on left and right side, each requires 2 conditions. Hence total is 4. see http://mathworld.wolfram.com/WaveEquation1-Dimensional.html
I do not think DSolve or NDSolve can solve initial and boundary value problems? I seem to have read this somewhere sometime ago. No time to check now.
I think that Mathematica doesn't know how to deal with these boundary conditions for 2nd order PDEs. How would you want the answer returned? As a general Fourier series?
This is mentioned in the Mathematica Cookbook (and probably other places)...
Breaking down the problem for Mathematica (with the dimensional factor v->1), you find
In[1]:= genSoln = DSolve[D[u[x, t], {x, 2}] == D[u[x, t], {t, 2}], u, {x, t}] // First
Out[1]= {u -> Function[{x, t}, C[1][t - x] + C[2][t + x]]}
In[2]:= Solve[u[0, t] == 0 /. genSoln]
Out[2]= {{C[1][t] -> -C[2][t]}}
In[3]:= u[l, 0] == 0 /. genSoln /. C[1][x_] :> -C[2][x] // Simplify
Out[3]= C[2][-l] == C[2][l]
that the solution is written as f(t-x)-f(t+x) where f is periodic over [-l,l]...
You can't do any more with out making assumptions about the smoothness of the solution.
You can check that the standard Fourier series approach would work, e.g.
In[4]:= f[x_, t_] := Sin[n Pi (t + x)/l] - Sin[n Pi (t - x)/l]
In[5]:= And[D[u[x, t], {x, 2}] == D[u[x, t], {t, 2}],
u[0, t] == 0, u[l, 0] == 0] /. u -> f // Reduce[#, n] & // Simplify
Out[5]= C[1] \[Element] Integers && (n == 2 C[1] || n == 1 + 2 C[1])
Related
I am trying to visualize the result of numerical integration in Wolfram Mathematica using DensityPlot. But dark artifacts appear inside the circle on the graph, this is incorrect. How to fix this?
f[u_, v_]:=(1/1.2)*(1/(3.14159*0.02^2)*E^(-((x-u)^2+(y-v)^2)/0.02^2)+0.2/(3.14159*2^2)*E^(-((x-u)^2+(y-v)^2)/2^2));
i[x_, y_]:=NIntegrate[f[u, v],{u, v} \[Element] Disk[{0,0},2.5], AccuracyGoal -> 30];
DensityPlot[i[x, y], {x, -3, 3}, {y, -3, 3},ColorFunction->"SunsetColors",PlotPoints -> 20, PlotLegends -> Automatic]
Link to the image: https://postimg.cc/47MJTYj7
Well, that is not an artifact, or is it. First I'd like to point out that f is a function of u, v, x and y. So the way it is programmed is not very clean. Now to the main problem. There are two Gaussian peaks. One is very broad, the other very sharp. In many cases the numerical integral just does not get points near the sharp peak, therefore not detecting it. As the rest is smooth and easy, no subset is generated and the integral is just missing this contribution. Luckily, there is an option specifically for this. MinRecursion: NIntegrate may miss sharp peaks of integrands:.... So this works
g[x_, y_, s_] := Exp[ -( x^2 + y^2 ) / s^2] / (s^2 Pi)
f[x_, y_, u_, v_] := g[ x - u, y - v, 0.02 ] / 1.2 + 0.2 g[ x - u, y - v, 2 ]
i[x_, y_] := NIntegrate[ f[x, y, u, v], {u, v} \[Element] Disk[{0, 0}, 2.5], MinRecursion -> 5]
nn = 30;
t = Table[i[x, y], {x, -3, 3, 6/nn}, {y, -3, 3, 6/nn}];
ListDensityPlot[t, ColorFunction -> "SunsetColors", PlotLegends -> Automatic]
Takes quite some time, though. Probably, it would be better to split this up in two integrals and invest some thought on the integration boundaries.
I am trying to solve this system of eqs
dw(v,t)/dt =2g(v,t) w(t,v)
g(t,v)= Pi/2 (v^2)d g0(v,t)/dt
d go(v,t)/dt + d/dv[dw/dt *1/v^3)]=0
initial conditions
f0= (a/(Pi)^0.5)*e^[v^2/ve^2] + (b/(Pi)^0.5)*e^[(v - u)^2/ve^2]
a^2 + b^2 = 1
f0=go(v,0)
w(v,0)=0
This is my code
Here I am initializing some variables and defining f0 that is g(v,t=0).
a = 0.5;
b = (3^0.5)/2;
ve = 1;
u = 1;
f0[v_] = (a/(Pi)^0.5)Exp[v^2/ve^2] + (b/(Pi)^0.5)Exp[(v - u)^2/ve^2];
u1 = Log[((1 - a^2)/a^2)^0.5]/(2*u) + u/2;
u2 = 3u/2 - Log[((1 - a^2)/a^2)^0.5]/(2u);
f0[u1]
f0[u2]
Here I am using a system of 3 eqs for 3 functions and equating g(v,0)=f0
sol = NDSolve[{
D[go[v, t], t] + D[D[w[v, t], t], v]/(v^3) + (-3v^(-4))D[w[v, t], t] == 0,
g[v, t] == Pi/2 (v^2) D[go[v, t], v],
go[v, 0] == f0[v],
D[w[v, t], t] == 2g[v, t]w[v, t],
w[v, 0] == 0},
{go[v, t], W[v, t]},
{v, u1, u2},
{t, 0, 10000000000}]
And it is returning errors like
The PDE is convection dominated and the result may not be stable.
Adding artificial diffusion may help
"No DirichletCondition or Robin-type NeumannValue was specified for
{g}; the result may not be unique"
The PDE is convection dominated and the result may not be stable.
Adding artificial diffusion may help.
I am using Sage to (within a script) solve a simple equation in two variables:
sage: x, y = var("x y")
sage: p = x*y + x/y + 1/x
sage: diff(p, x)
y + 1/y - 1/x^2
sage: diff(p, y)
x - x/y^2
sage: solve([diff(p,x)==0, diff(p,y)==0], [x,y])
[[x == 0, y == 0], [x == -1/2*sqrt(2), y == 1],
[x == 1/2*sqrt(2), y == 1], [x == -1/2*I*sqrt(2), y == -1],
[x == 1/2*I*sqrt(2), y == -1]]
For some reason, Sage returns a solution that isn't a solution at all, here [x == 0, y == 0] can easily be seen NOT to be an answer of [y + 1/y - 1/x^2 == 0, x - x/y^2 == 0].
Is this a bug? a known bug? or am I doing something wrong?
UPDATE: rephrased the title, and I am wondering, worst case, how can I substitute the solutions back in the system to manually check if the equations are verified?
PS: I would post this on AskSage, but it is currently down.
Well, looks like Maxima's solve function is returning the spurious solution [x = 0, y = 0]. I see that Maxima's to_poly_solve is better behaved here.
p : x*y + x/y + 1/x;
load (to_poly_solve);
[dpx, dpy] : [diff (p, x), diff (p, y)];
to_poly_solve ([dpx, dpy], [x, y]);
=> %union([x = -1/sqrt(2),y = 1],[x = 1/sqrt(2),y = 1],
[x = -%i/sqrt(2),y = -1],[x = %i/sqrt(2),y = -1])
for xy in args (%) do print (subst (xy, [dpx, dpy]));
=>
[0,0]
[0,0]
[0,0]
[0,0]
I don't know how to call to_poly_solve from Sage, although I'm pretty sure it's possible.
Hope this helps. Good luck & have fun.
I am working on a solution to solve a Partial Differential Equation, Fick's Second Law of Diffusion to be exact.
I was able to produce a 3D Plot using the NDSolve and Plot3D functions.
Code used:
NDSolve[{D[c[t, h], t] == 1*D[c[t, h], h, h],
c[0, h] == Erfc[h/(2*81.2)],
c[t, 0] == 1,
c[t, 4000] == 3.08*^-18}, c, {t, 0, 900}, {h, 0, 274}]
Instead of a graphical representation, I would like to find numerical points of the graph at t = 900.
I would like to know how to put in t = 900 into NDSolve (or other functions) so as to generate detailed numerical points of the solution.
Try saving the solution in a variable first:
e = NDSolve[{D[c[t, h], t] == 1*D[c[t, h], h, h], c[0, h] == Erfc[h/(2*81.2)], c[t, 0] == 1, c[t, 4000] == 3.08*^-18}, c, {t, 0, 900}, {h, 0, 274}]
Then we can Evaluate this expression for our desired variables:
Evaluate[c[900, 10] /. e]
(*{0.914014}*)
Or to make it more versatile, we can use Manipulate:
Manipulate[Evaluate[c[t, h] /. e], {t, 0, 900}, {h, 0, 274}]
Update:
Considering the information I received from the comments below; we can define a function like q[t,h] which will give us the solution as a function:
q[t_, h_] := Evaluate[c[t, h] /. e]
q[900, 10]
(*{0.914014}*)
To address the question we start with the following toy model problem being here just a case study:
Given two circles on a plane (its centers (c1 and c2) and radii (r1 and r2)) as well as a positive number r3, find all circles with radii = r3 (i.e all points c3 being centers of circles with radii = r3) tangent (externally and internally) to given two circles.
In general, depending on Circle[c1,r1], Circle[c2,r2] and r3 there are 0,1,2,...8 possible solutions. A typical case with 8 solutions :
I slightly modified a neat Mathematica implementation by Jaime Rangel-Mondragon on Wolfram Demonstration Project, but its core is similar:
Manipulate[{c1, a, c2, b} = pts;
{r1, r2} = Map[Norm, {a - c1, b - c2}];
w = Table[
Solve[{radius[{x, y} - c1]^2 == (r + k r1)^2,
radius[{x, y} - c2]^2 == (r + l r2)^2}
] // Quiet,
{k, -1, 1, 2}, {l, -1, 1, 2}
];
w = Select[
Cases[Flatten[{{x, y}, r} /. w, 2],
{{_Real, _Real}, _Real}
],
Last[#] > 0 &
];
Graphics[
{{Opacity[0.35], EdgeForm[Thin], Gray,
Disk[c1, r1], Disk[c2, r2]},
{EdgeForm[Thick], Darker[Blue,.5],
Circle[First[#], Last[#]]& /# w}
},
PlotRange -> 8, ImageSize -> {915, 915}
],
"None" -> {{pts, {{-3, 0}, {1, 0}, {3, 0}, {7, 0}}},
{-8, -8}, {8, 8}, Locator},
{{r, 0.3, "r3"}, 0, 8},
TrackedSymbols -> True,
Initialization :> (radius[z_] := Sqrt[z.z])
]
We can easily conclude that in a generic case we have an even number of solutions 0,2,4,6,8 while cases with an odd number of solutions 1,3,5,7 are exceptional - they are of zero measure in terms of control ranges. Thus changing in Manipulate c1, r1, c2, r2, r3 one can observe that it is much more difficult to track cases with an odd number of circles.
One could modify on a basic level the above approach : solving purely symbolically equations for c3 as well as redesignig Manipulate structure with an emphasis on changing number of solutions. If I'm not wrong Solve can work only numerically with Locator in Manipulate, however here Locator seems to be crucial for simplicity of controlling c1, r1, c2, r2 as well as for the whole implementation.
Let's state the questions, :
1. How can we force Manipulate to track seamlessly cases with an odd number of solutions (circles) ?
2. Is there any way to make Solve to find exact solutions of the underlying equations?
( I find the answer by Daniel Lichtblau to be the best approach to the question 2, but it seems in this instance there is still an essential need for sketching of a general technique of emphasizing measure zero sets of solutions while working with Manipulate )
These considerations are of less importance while dealing with exact solutions
For example Solve[x^2 - 3 == 0, x] yields {{x -> -Sqrt[3]}, {x -> Sqrt[3]}}
while in case from the above of slightly more difficult equations extracted from Manipulate setting the following arguments :
c1 = {-Sqrt[3], 0}; a = {1, 0}; c2 = {6 - Sqrt[3], 0}; b = {7, 0};
{r1, r2} = Map[ Norm, {a - c1, b - c2 }];
r = 2.0 - Sqrt[3];
to :
w = Table[Solve[{radius[{x, y} - {x1, y1}]^2 == (r + k r1)^2,
radius[{x, y} - {x2, y2}]^2 == (r + l r2)^2}],
{k, -1, 1, 2}, {l, -1, 1, 2}];
w = Select[ Cases[ Flatten[ {{x, y}, r} /. w, 2], {{_Real, _Real}, _Real}],
Last[#] > 0 &]
we get two solutions :
{{{1.26795, -3.38871*10^-8}, 0.267949}, {{1.26795, 3.38871*10^-8}, 0.267949}}
similarly under the same arguments and equations, putting :
r = 2 - Sqrt[3];
we get no solutions : {}
but in fact there is exactly one solution which we would like to emphasize:
{ {3 - Sqrt[3], 0 }, 2 - Sqrt[3] }
In fact, passing to Graphics such a small difference between two different solutions and the uniqe one is indistinguishable, however working with Manipulate we cannot track carefully with a desired accuracy merging of two circles and usually the last observed configuration when lowering r3 before vanishing all solutions (reminding so-called structural instability) looks like this :
Manipulate is rather a powerful tool, not only a toy, and its mastering could be very useful. The considered issues when appearing in a serious research are frequently critical, for example: in studying solutions of nonlinear differential equations, occurence of singularities in its solutions, qualitative behavior of dynamical systems, bifurcations, phenomena in Catastrophe theory and so on.
As this is a measure zero set, tools that require some granularity will generally have trouble with the concept. Perhaps better is to look for the singularity locus explicitly, where solutions have multiplicity or in other ways depart from the nearby solution behavior(s). It will be a part of the discriminant variety. In particular, you can grab the relevant part by setting your defining polynomials to zero and simultaneously making the Jacobian determinant zero.
Here is your example. I will eventually (wlog) put one center at the origin and the other at (1,0).
centers = Array[c, {2, 2}];
radii = Array[r, 3];
circ[cen_, rad_, x_, y_] := ({x, y} - cen).({x, y} - cen) - rad^2
I'll use your 'k' for both polynomials. Your formulation has pairs (k,l) where each is +-1. We can just use k, arrange by squaring to get a polynomial in k^2, and replace that with 1.
polys =
Table[Expand[
circ[centers[[j]], radii[[3]] + k*radii[[j]], x, y]], {j, 2}]
Out[18]= {x^2 + y^2 - 2 x c[1, 1] + c[1, 1]^2 - 2 y c[1, 2] +
c[1, 2]^2 - k^2 r[1]^2 - 2 k r[1] r[3] - r[3]^2,
x^2 + y^2 - 2 x c[2, 1] + c[2, 1]^2 - 2 y c[2, 2] + c[2, 2]^2 -
k^2 r[2]^2 - 2 k r[2] r[3] - r[3]^2}
We'll remove the part that is linear in k, square the rest, square that removed part, and equate the two. We also then replace k with unity.
p2 = polys - k*Coefficient[polys, k];
polys2 = Expand[p2^2 - (k*Coefficient[polys, k])^2] /. k -> 1;
We now get the determinant of the Jacobian and add that to the brew.
discrim = Det[D[polys2, #] & /# {x, y}];
allrelations = Join[polys2, {discrim}];
Now set the centers as noted earlier (could have done this from the beginning, one would suppose).
ar2 =
allrelations /. {c[1, 1] -> 0, c[1, 2] -> 0, c[2, 1] -> 0,
c[2, 2] -> 0}
Out[38]= {x^4 + 2 x^2 y^2 + y^4 - 2 x^2 r[1]^2 - 2 y^2 r[1]^2 +
r[1]^4 - 2 x^2 r[3]^2 - 2 y^2 r[3]^2 - 2 r[1]^2 r[3]^2 + r[3]^4,
x^4 + 2 x^2 y^2 + y^4 - 2 x^2 r[2]^2 - 2 y^2 r[2]^2 + r[2]^4 -
2 x^2 r[3]^2 - 2 y^2 r[3]^2 - 2 r[2]^2 r[3]^2 + r[3]^4, 0}
We now eliminate x and y to get the locus in r[1],r[2],r[3] parameter space that determines where we'll have multiplicity in our solutions.
gb = GroebnerBasis[ar2, radii, {x, y},
MonomialOrder -> EliminationOrder]
{r[1]^6 - 3 r[1]^4 r[2]^2 + 3 r[1]^2 r[2]^4 - r[2]^6 -
8 r[1]^4 r[3]^2 + 8 r[2]^4 r[3]^2 + 16 r[1]^2 r[3]^4 -
16 r[2]^2 r[3]^4}
If I did this all correctly, then we now have the polynomial defining the locus in parameter space where solution sets can get silly. Off this set they should never have multiplicity, and real counts should always be even. The intersection of this set with real space will be a 2d surface in the 3d space of the radii parameters. It will separate regions that have 0, 2, 4, 6, or 8 real solutions from one another.
Last, I'll point out that in this example the variety in question reduces nicely into a product of planes. I guess from a geometric view this is not too surprising.
Factor[gb[[1]]]
Out[43]= (r[1] - r[2]) (r[1] + r[2]) (r[1] - r[2] - 2 r[3]) (r[1] +
r[2] - 2 r[3]) (r[1] - r[2] + 2 r[3]) (r[1] + r[2] + 2 r[3])