I am solving a set of differential equations, where the coefficient is determined by the solution itself. Here is a minimal example:
s = NDSolve[{M'[r] == a r^2, M[0] == 0}, M, r];
Plot[Evaluate[M[r] /. s], {r, 0, 1}]
where a is determined by requiring M[r=1]=1. Once the correct a is found, I then solve the equations normally and plot M[r]. In fortran I could iterate over a until such a requirement is met. I would like to know how to do this with Mathematica, or better still, do this more elegantly (not iterating, since it is time consuming in Mathematica).
Or if you find the above example too silly, here is the original problem:
s = NDSolve[{M'[r] == r^2 Exp[lnp[r]], lnp'[r] == - M[r]/r^2, M[0.01] == 0, lnp[0.01] == a}, {M, lnp}, {r, 0.01, 1}]
Plot[Evaluate[M[r] /. s], {r, 0.01, 1}]
where a is determined by requiring M[1]=1.
Thanks!
There is probably a neater way of doing this.
DSolve[D[M[r], r] == a r^2, M[r], r]
{{M[r] -> (a r^3)/3 + C[1]}} . . . (eqn. 1)
From eqn. 1, when r = 0, M[0] == C[1], therefore
M[r] == (a r^3)/3 + M[0]
Given M[0] = 0
M[r] == (a r^3)/3
Also given M[1] = 1, a == 3, therefore
M[r_] := r^3
Plot[M[r], {r, 0, 10}]
Related
I am trying to model the spread of disease using the differential equations given on this site http://www.maa.org/press/periodicals/loci/joma/the-sir-model-for-spread-of-disease-the-differential-equation-model with Wolfram Mathematica.
I entered:
NDSolve[{i'[t]== 1/2s[t]i[t]-1/3i[t], s[t]==-1/2s[t]i[t],r[t]==1/3i[t], r[0] ==0, s[0]==1, i[0]==1.27*10^-6,s'[0]==0} i, {t, 0, 100}]
and received the error
NDSolve called with 2 arguments; 3 or more arguments are expected.
I also tried
NDSolve[{i'[t]== 1/2s[t]i[t]-1/3i[t], s[t]==-1/2s[t]i[t],r[t]==1/3i[t], r[0] ==0, s[0]==1, i[0]==1.27*10^-6,s'[0]==0} i, {t, 0, 100}]
and got the same error
I am a newcomer to both differential equations and Mathematica, so I'd be grateful if someone can help.
As Bill told these was no coma. Second argument of NDSolve is set of function. You can type it without arguments or with arguments. Your code should look like this:
sol = NDSolve[
{i'[t] == 1/2 s[t] i[t] - 1/3 i[t],
s[t] == -1/2 s[t] i[t], r[t] == 1/3 i[t],
r[0] == 0,
s[0] == 1,
i[0] == 1.27*10^-6,
s'[0] == 0}, {i[t], s[t], r[t]}, {t, 0, 10}]
It generates error connected with numerical problems:
NDSolve::ivres: NDSolve has computed initial values that give a zero residual for the differential-algebraic system, but some components are different from those specified. If you need them to be satisfied, giving initial conditions for all dependent variables and their derivatives is recommended. >>
But you can print your results:
Plot[{Evaluate[i[t] /. sol], Evaluate[s[t] /. sol],
Evaluate[r[t] /. sol]}, {t, 0, 10}]
I try to solve a differential equation (using DSolve) of the form:
Sys = {(Re[a T'[x] + b T[x]] == 0), T[1] == 3};
Sol = DSolve[Sys, T[x], x];
Plot[T[x]/.Sol, {x, 0, 1}
Where 'a' and 'b' are complex coefficients (non dependent of x).
I know this can't be the right syntax but I don't seem to find the right one anywhere. I can, of course, do the following:
Sys = {(a T'[x] + b T[x]] == 0), T[1] == 3};
Sol = DSolve[Sys, T[x], x];
Plot[Re[T[x]]/.Sol, {x, 0, 1}]
But this doesn't necessarily give me the same solution. How do I force Mathematica to take only the real part and solve the differential equation?
Thanks.
I don't use Mathematica in general and I need it to compare with an other program. I want to solve a system of three differential and non linear equations. For this I use Dsolve. Everything goes wrong when I put the nonlinear term (exponential).
Here is my code:
equa = {x'[t] == z[t] - Exp[y[t]],
y'[t] == z[t] - y[t],
z'[t] == x[t] + y[t] - z[t],
x[0] == 0,
y[0] == 0,
z[0] == 0};
slt = DSolve[equa, {x, y, z}, t]
Plot[{x[t] /. slt}, {t, 0, 10}]
And the errors are like this :
DSolve::dsvar: 0.1 cannot be used as a variable.
ReplaceAll::reps:{Dsolve[<<1>>]} is neither a list of replacement rules nor a valid dispatch table, and so cannot be used for replacing
Does someone know why the exponential term makes troubles ?
Thanks
You may try
s = NDSolve[equa, {x, y, z}, {t, 0, 10}];
Plot[Evaluate[({x[t], y[t], z[t]} /. s)], {t, 0, 1}]
I am wondering if anyone can help me to plot the Cantor dust on the plane in Mathematica. This is linked to the Cantor set.
Thanks a lot.
EDIT
I actually wanted to have something like this:
Here's a naive and probably not very optimized way of reproducing the graphics for the ternary Cantor set construction:
cantorRule = Line[{{a_, n_}, {b_, n_}}] :>
With[{d = b - a, np = n - .1},
{Line[{{a, np}, {a + d/3, np}}], Line[{{b - d/3, np}, {b, np}}]}]
Graphics[{CapForm["Butt"], Thickness[.05],
Flatten#NestList[#/.cantorRule&, Line[{{0., 0}, {1., 0}}], 6]}]
To make Cantor dust using the same replacement rules, we take the result at a particular level, e.g. 4:
dust4=Flatten#Nest[#/.cantorRule&,Line[{{0.,0},{1.,0}}],4]/.Line[{{a_,_},{b_,_}}]:>{a,b}
and take tuples of it
dust4 = Transpose /# Tuples[dust4, 2];
Then we just plot the rectangles
Graphics[Rectangle ### dust4]
Edit: Cantor dust + squares
Changed specs -> New, but similar, solution (still not optimized).
Set n to be a positive integer and choice any subset of 1,...,n then
n = 3; choice = {1, 3};
CanDChoice = c:CanD[__]/;Length[c]===n :> CanD[c[[choice]]];
splitRange = {a_, b_} :> With[{d = (b - a + 0.)/n},
CanD##NestList[# + d &, {a, a + d}, n - 1]];
cantLevToRect[lev_]:=Rectangle###(Transpose/#Tuples[{lev}/.CanD->Sequence,2])
dust = NestList[# /. CanDChoice /. splitRange &, {0, 1}, 4] // Rest;
Graphics[{FaceForm[LightGray], EdgeForm[Black],
Table[cantLevToRect[lev], {lev, Most#dust}],
FaceForm[Black], cantLevToRect[Last#dust /. CanDChoice]}]
Here's the graphics for
n = 7; choice = {1, 2, 4, 6, 7};
dust = NestList[# /. CanDChoice /. splitRange &, {0, 1}, 2] // Rest;
and everything else the same:
Once can use the following approach. Define cantor function:
cantorF[r:(0|1)] = r;
cantorF[r_Rational /; 0 < r < 1] :=
Module[{digs, scale}, {digs, scale} = RealDigits[r, 3];
If[! FreeQ[digs, 1],
digs = Append[TakeWhile[Most[digs]~Join~Last[digs], # != 1 &], 1];];
FromDigits[{digs, scale}, 2]]
Then form the dust by computing differences of F[n/3^k]-F[(n+1/2)/3^k]:
With[{k = 4},
Outer[Times, #, #] &[
Table[(cantorF[(n + 1/2)/3^k] - cantorF[(n)/3^k]), {n, 0,
3^k - 1}]]] // ArrayPlot
I like recursive functions, so
cantor[size_, n_][pt_] :=
With[{s = size/3, ct = cantor[size/3, n - 1]},
{ct[pt], ct[pt + {2 s, 0}], ct[pt + {0, 2 s}], ct[pt + {2 s, 2 s}]}
]
cantor[size_, 0][pt_] := Rectangle[pt, pt + {size, size}]
drawCantor[n_] := Graphics[cantor[1, n][{0, 0}]]
drawCantor[5]
Explanation: size is the edge length of the square the set fits into. pt is the {x,y} coordinates of it lower left corner.
I am finally working on my n-point Pade code, again, and I am running across an error that was not occurring previously. The heart of the matter revolves around this code:
zi = {0.1, 0.2, 0.3}
ai = {0.904837, 1.05171, -0.499584}
Quiet[ RecurrenceTable[ {A[0] == 0, A[1] == ai[[1]],
A[n+1]==A[n] + (z - zi[[n]]) ai[[n+1]] A[n-1]},
A, {n, Length#ai -1 } ],
{Part::pspec}]
(The use of Quiet is necessary as Part complains about zi[[n]] and ai[[n+1]] when n is purely symbolic.) The code itself is part of a function that I want a symbolic result from, hence z is a Symbol. But, when I run the above code I get the error:
RecurrenceTable::nlnum1:
The function value {0.904837,0.904837+0. z} is not a list of numbers with
dimensions {2} when the arguments are {0,0.,0.904837}.
Note the term {0.904837,0.904837+0. z} where 0. z is not reduced to zero. What do I need to do to force it to evaluate to zero, as it seems to be the source of the problem? Are there alternatives?
Additionally, as a general complaint about the help system for the Wolfram Research personnel who haunt stackoverflow: in v.7 RecurrenceTable::nlnum1 is not searchable! Nor, does the >> link at the end of the error take you to the error definition, but takes you to the definition of RecurrenceTable, instead, where the common errors are not cross-referenced.
Edit: After reviewing my code, the solution I came up with was to evaluate the RecurrenceTable completely symbolically, including the initial conditions. The working code is as follows:
Clear[NPointPade, NPointPadeFcn]
NPointPade[pts : {{_, _} ..}] := NPointPade ## Transpose[pts]
NPointPade[zi_List, fi_List] /; Length[zi] == Length[fi] :=
Module[{ap, fcn, rec},
ap = {fi[[1]]};
fcn = Module[{gp = #, zp, res},
zp = zi[[-Length#gp ;;]];
res = (gp[[1]] - #)/((#2 - zp[[1]]) #) &[Rest#gp, Rest#zp];
AppendTo[ap, res[[1]]];
res
] &;
NestWhile[fcn, fi, (Length[#] > 1 &)];
(*
The recurrence relation is used twice, with different initial conditions, so
pre-evaluate it to pass along to NPointPadeFcn
*)
rec[aif_, zif_, a_, b_][z_] :=
Evaluate[RecurrenceTable[
{A[n + 1] == A[n] + (z - zif[n])*aif[n + 1]*A[n - 1],
A[0] == a, A[1] == b},
A, {n, {Length#ap - 1}}][[1]]];
NPointPadeFcn[{zi, ap, rec }]
]
NPointPadeFcn[{zi_List, ai_List, rec_}][z_] /; Length[zi] == Length[ai] :=
Module[{aif, zif},
zif[n_Integer] /; 1 <= n <= Length[zi] := zi[[n]];
aif[n_Integer] /; 1 <= n <= Length[zi] := ai[[n]];
rec[aif, zif, 0, ai[[1]]][z]/rec[aif, zif, 1, 1][z]
]
Format[NPointPadeFcn[x_List]] := NPointPadeFcn[Shallow[x, 1]];
Like the built-in interpolation functions, NPointPade does some pre-processing, and returns a function that can be evaluated, NPointPadeFcn. The pre-processing done by NPointPade generates the list of ais from the zis and the function values at those points, in addition to pre-evaluating the recurrence relations. When NPointPadeFcn is supplied with a z value, it evaluates two linear recurrence relations by supplying it with the appropriate values.
Edit: for the curious, here's NPointPade in operation
In the first plot, it is difficult to tell the difference between the two functions, but the second plot shows the absolute (blue) and relative (red) errors. As written, it takes a very long time to create a Pade for 20 points, so I need to work on speeding it up. But, for now, it works.
You can hide part extraction behind a function:
In[122]:= zi = {0.1, 0.2, 0.3};
ai = {0.904837, 1.05171, -0.499584};
In[124]:= zif[n_Integer] /; 1 <= n <= Length[zi] := zi[[n]]
aif[n_Integer] /; 1 <= n <= Length[ai] := ai[[n]]
In[127]:= RecurrenceTable[{A[0] == 0, A[1] == aif[1],
A[n + 1] ==
A[n] + (z - zif[n]) aif[n + 1] A[n - 1]}, A, {n, (Length#ai) - 1}]
Out[127]= {0.904837, 0.904837,
0.904837 - 0.271451 aif[4] + 0.904837 z aif[4]}
EDIT
Here is the work-around for the problem:
In[4]:= zi = {0.1, 0.2, 0.3};
ai = {0.904837, 1.05171, -0.499584};
In[6]:= zif[n_Integer] /; 1 <= n <= Length[zi] := zi[[n]]
aif[n_Integer] /; 1 <= n <= Length[ai] := ai[[n]]
In[8]:= Block[{aif, zif},
RecurrenceTable[{A[0] == 0, A[1] == aif[1],
A[n + 1] == A[n] + (z - zif[n]) aif[n + 1] A[n - 1]},
A, {n, 0, (Length#ai) - 1}]]
Out[8]= {0, 0.904837, 0.904837}
Block serves to temporarily remove definitions of aif and zif while RecurrenceTable is executed. Then, when Block exits, the values are restored, and the output of RecurrenceTable evaluates.
It seems to me that Sasha's approach can be mimicked by just Blocking Part.
zi = {0.1, 0.2, 0.3};
ai = {0.904837, 1.05171, -0.499584};
Block[{Part},
RecurrenceTable[{A[0] == 0, A[1] == ai[[1]],
A[n + 1] == A[n] + (z - zi[[n]]) ai[[n + 1]] A[n - 1]},
A, {n, Length#ai - 1}]
]
{0, 0.904837, 0.904837}
Addressing Sasha's criticism, here are two other ways one might approach this:
With[{Part = $z},
RecurrenceTable[{A[0] == 0, A[1] == ai[[1]],
A[n + 1] == A[n] + (z - zi[[n]]) ai[[n + 1]] A[n - 1]},
A, {n, Length#ai - 1}]
] /. $z -> Part
-
With[{Part = Hold[Part]},
RecurrenceTable[{A[0] == 0, A[1] == ai[[1]],
A[n + 1] == A[n] + (z - zi[[n]]) ai[[n + 1]] A[n - 1]},
A, {n, Length#ai - 1}]
] // ReleaseHold