fun[y1_, y2_, ti_, w_] :=
Module[{y1i = y1, y2i = y2, tj = ti, wi = w}, a = 0.5; b = 0.8;
c = 1.5;
t1 = tj; t2 = tj + wi;
Ans = Y /.
First#NDSolve[{Y'[t] = a*Y[t] + b*X[t], X'[t] = c*Y[t] + a*X[t],
Y[t1] = y1i, X[t1] = y2i}, {Y, X}, {t, t1, t2} ];
Data = Table[{t, Ans[t]}, {t, t1, t2, 10^-6}];
Export["Data.xls", Data, "XLS"]
ya = Ans["ValuesOnGrid"]
Return[Last[ya]];];
fun[1, 0, 0, 1]`
I have been trying to solve similar coupled differential equations in Mathematica. So far I have been able to do this outside the a defined function and was able to use the data for analysis purposes. But for using inside loops, I need to solve coupled differential equations numerically inside functions.
Related
Firstly, this problem is much easier to understand visually, I would post images but I'm new on here. I'm solving two coupled differential equations (for temperature and density) using NDSolve. The temperature equation has a heating function added to it in the form of a Gaussian and I want to thin the Gaussian (lower the variance) until it's nearly a delta function, but as I lower the variance to a certain point NDSolve starts ignoring the heating function, presumably something to do with the step size being too large? Here's the code I'm using:
Start with some jargon:
a = 1.99*10^-9;
b = 0.24*10^-3;
d = 1.21*10^-3;
T0 = 1*10^6;
n0 = 0.9*10^9;
ti = -400;
tf = 500;
kB = 1.38*10^-16;
and define the heating function "Qgt" as a Gaussian (with standard deviation "sig" and amplitude "Ag" plus some background "Qb":
Qb = 0.33*10^-3;
sig = 3;
var = sig^2;
Ag = 16.5;
Qg = Ag*Exp[-(t - 10)^2/(2*var)];
Qgt = Qg + Qb;
Then run the solver:
sss = NDSolve[{T'[t] == -(n[t]^-1) T[t]^(7/2) (a) -
n[t] T[t]^(-1/2) (b) + Qgt/(3*kB*n[t]),
n'[t] == T[t]^(5/2) (a) - (n[t]^2) (T[t]^(-3/2)) (d), T[ti] == T0,
n[ti] == n0}, {T, n}, {t, ti, tf}];
and finally plot T[t]:
TP = Plot[T[t] /. sss, {t, ti, 400}, PlotRange -> All]
If you run all this you get a working plot where T[t] remains constant initially then the heating spike greatly increases the temperature and the system cools back to constant. BUT when I reduce "sig" to 2, the entire heating function gets ignored and the temperature never spikes up! Please run this quickly to see my problem, I don't understand what's happening and ultimately I want "sig" to be as low as 1 or 0.5. Thank you!
Increasing the working precision on the solver seems to do the trick.
a = 1.99*10^-9;
b = 0.24*10^-3;
d = 1.21*10^-3;
T0 = 1*10^6;
n0 = 0.9*10^9;
ti = -400;
tf = 500;
kB = 1.38*10^-16;
Qb = 0.33*10^-3;
sig = 0.5;
var = sig^2;
Ag = 16.5;
Qg = Ag*Exp[-(t - 10)^2/(2*var)];
Qgt = Qg + Qb;
sss = Quiet#
NDSolve[{T'[t] == -(n[t]^-1) T[t]^(7/2) (a) - n[t] T[t]^(-1/2) (b) + Qgt/(3*kB*n[t]),
n'[t] == T[t]^(5/2) (a) - (n[t]^2) (T[t]^(-3/2)) (d), T[ti] == T0,
n[ti] == n0}, {T, n}, {t, ti, tf}, WorkingPrecision -> 24];
Plot[T[t] /. sss, {t, ti, 400}, PlotRange -> All]
I am working on finding the initial points of convergence using newton's iteration method in mathematica. newton function works now I would like to show which initial points from a grid produce Newton iterations that converge to -1, same for points that converge to (1 + (3)^1/2)/2i, given that:
f(x) = x^3+1
newton[x0_] := (
x = x0;
a1 = {};
b1 = {};
c1 = {};
counter = 0;
error = Abs[f[x]];
While[counter < 20 && error > 0.0001,
If[f'[x] != 0, x = x - N[f[x]/f'[x]]];
counter = counter + 1;
error = Abs[f[x]]];
x)
I created a grid to show which initial points of a+bi converge to the roots.
grid = Table[a + b I, {a, -2, 2, 0.01}, {b, -2, 2, 0.01}];
Then I created a fractal, but whenever I plot it gives me a blank graph on the axis.
There's got to be a way for me to be able to identify the converge points from the grid but so far I have not been successful. I tried using the Which[] method but when comparing the value its returns false.
Any help will appreciate it
Your code is not optimal, to put it mildly, but to give you a head start, why don't you start with something like this:
f[x_] := x^3 + 1;
newton[x0_] := (x = x0;
a1 = {};
b1 = {};
c1 = {};
counter = 0;
error = Abs[f[x]];
While[counter < 20 && error > 0.0001,
If[f'[x] != 0, x = x - N[f[x]/f'[x]]];
counter = counter + 1;
error = Abs[f[x]]];
{x, counter})
Table[Re#newton[a + b I], {a, -2, 2, 0.01}, {b, -2, 2, 0.01}] // Image
I already have implemented Euler method in Mathematica.
Now I want to convert this method to Heun method (improved Euler).
I have this Euler implementation:
a = 2;(*my a parameter*)
b = .01; (*my b parameter*)
x = 0; (*starting x value*)
p = 1; (*starting p value*)
t = 1; (*step size t*)
f[p_] := a p - b p^2; (*my function*)
f[0] = 1;
eulertable = {}; (*build table (x,p).n steps in loop*)
For[n = 1,
n <= 21, n++,
AppendTo[eulertable, {x, p}];
p = p + t f[p];
x = x + t;]
Now I want to implement this with the Heun method. I already have this implementation of the Heun method.
heun[f_, {x_, x0_, xn_}, {y_, y0_}, steps_] :=
Block[{ xold = x0, yold = y0, sollist = {{x0, y0}}, x, y, h },
h = N[(xn - x0) / steps];
Do[ xnew = xold + h;
k1 = h * (f /. {x -> xold, y -> yold});
k2 = h * (f /. {x -> xold + h, y -> yold + k1});
ynew = yold + .5 * (k1 + k2);
sollist = Append[sollist, {xnew, ynew}];
xold = xnew;
yold = ynew,
{steps}
];
Return[sollist]
]
But I need to convert this method to have the input like it is in my Euler method. So I have to convert the Heun method that I have the parameter a, b, x, t, p, f[].
As I am new with Mathematica I am having problems to convert the method.
Why do you put f[0]=1?
Replace
p = p + t f[p];
x = x + t;
with
p1 = p + t f[p];
p2 = p + t f[p1];
p = (p1+p2)/2;
x = x + t;
Your step size is rather large for the values of your parameters.
I am trying to solve an D-equation and do not know y[0], but I know y[x1]=y1.
I want to solve the DSolve only in the relevant xrange x=[x1, infinitny].
How could it work?
Attached the example that does not work
dsolv2 = DSolve[{y'[x] == c*0.5*t12[x, l2]^2 - alpha*y[x], y[twhenrcomesin] == zwhenrcomesin, x >= twhenrcomesin}, y[x], x]
dsolv2 = Flatten[dsolv2]
zsecondphase[x_] = y[x] /. dsolv2[[1]]
I am aware that DSolve does not allow the inequality condition but I put it in to explain you what I am looking for (t12[x,l2] will give me a value only depending on x since l2 is known).
EDIT
t12[j24_, lambda242_] := (cinv1 - cinv2)/(cop2 - cop1 + (h2*lambda242)*E^(p*j24));
cinv1 = 30; cinv2 = 4; cinv3 = 3; h2 = 1.4; h3 = 1.2; alpha = 0.04; z = 50; p = 0.06; cop1 = 0; cop2 = 1; cop3 = 1.3; teta2 = 0.19; teta3 =0.1; co2 = -0.6; z0 = 10;l2 = 0.1;
Your equation is first order and linear, so you can get a very general solution :
generic = DSolve[{y'[x] == f[x] - alpha*y[x], y[x0] == y0}, y[x], x]
Then you can substitute your specific term :
c = 1;
x0 = 1;
y0 = 1;
solution[x_] = generic[[1, 1, 2]] /. {f[x_] -> c*0.5*t12[x, l2]^2}
Plot[solution[x], {x, x0, 100}]
What is wrong with this example?
t12[x_] := Exp[-x .01] Sin[x];
dsolv2 = Chop#DSolve[{y'[x] == c*0.5*t12[x]^2 - alpha*y[x], y[1] == 1}, y[x], x];
Plot[y[x] /. dsolv2[[1]] /. {alpha -> 1, c -> 1}, {x, 1, 100}, PlotRange -> Full]
Edit
Regarding your commentary:
Try using a piecewise function to restrict the domain:
t12[x_] := Piecewise[{{ Exp[-x .01] Sin[x], x >= 1}, {Indeterminate, True}}] ;
dsolv2 = Chop#DSolve[{y'[x] == c*0.5*t12[x]^2 - alpha*y[x], y[1] == 1}, y[x], x];
Plot[y[x] /. dsolv2[[1]] /. {alpha -> 1, c -> 1}, {x, 1, 100}, PlotRange -> Full]
When I was trying to find the maximum value of f using NMaximize, mathematica gave me a error saying
NMaximize::cvdiv: Failed to converge to a solution. The function may be unbounded.
However, if I scale f with a large number, say, 10^5, 10^10, even 10^100, NMaximize works well.
In the two images below, the blue one is f, and the red one is f/10^10.
Here come my questions:
Is scaling a general optimization trick?
Any other robust, general workarounds for the optimizations such
needle-shape functions?
Because the scaling barely changed the shape of the needle-shape of
f, as shown in the two images, how can scaling work here?
thanks :)
Update1: with f included
Clear["Global`*"]
d = 1/100;
mu0 = 4 Pi 10^-7;
kN = 97/100;
r = 0.0005;
Rr = 0.02;
eta = 1.3;
e = 3*10^8;
s0 = 3/100;
smax = 1/100; ks = smax/s0;
fre = 1; tend = 1; T = 1;
s = s0*ks*Sin[2*Pi*fre*t];
u = D[s, t];
umax = N#First[Maximize[u, t]];
(*i=1;xh=0.1;xRp=4.5`;xLc=8.071428571428573`;
i=1;xh=0.1;xRp=4.5;xLc=8.714285714285715;*)
i = 1; xh = 0.1; xRp = 5.5; xLc = 3.571428571428571`;
(*i=1;xh=0.1`;xRp=5.`;xLc=6.785714285714287`;*)
h = xh/100; Rp = xRp/100; Lc = xLc/100;
Afai = Pi ((Rp + h + d)^2 - (Rp + h)^2);
(*Pi (Rp-Hc)^2== Afai*)
Hc = Rp - Sqrt[Afai/Pi];
(*2Pi(Rp+h/2) L/2==Afai*)
L = (2 Afai)/(\[Pi] (h + 2 Rp));
B = (n mu0 i)/(2 h);
(*tx = -3632B+2065934/10 B^2-1784442/10 B^3+50233/10 B^4+230234/10 \
B^5;*)
tx = 54830.3266978739 (1 - E^(-3.14250266080741 B^2.03187556833859));
n = Floor[(kN Lc Hc)/(Pi r^2)] ;
A = Pi*(Rp^2 - Rr^2);
b = 2*Pi*(Rp + h/2);
(* -------------------------------------------------------- *)
Dp0 = 2*tx/h*L;
Q0 = 0;
Q1 = ((1 - 3 (L tx)/(Dp h) + 4 (L^3 tx^3)/(Dp^3 h^3)) Dp h^3)/(
12 eta L) b;
Q = Piecewise[{{Q1, Dp > Dp0}, {Q0, True}}];
Dp = Abs[dp[t]];
ode = u A - A/e ((s0^2 - s^2)/(2 s0 )) dp'[t] == Q*Sign[dp[t]];
sol = First[
NDSolve[{ode, dp[0] == 0}, dp, {t, 0, tend} ,
MaxSteps -> 10^4(*Infinity*), MaxStepFraction -> 1/30]];
Plot[dp''[t] A /. sol, {t, T/4, 3 T/4}, AspectRatio -> 1,
PlotRange -> All]
Plot[dp''[t] A /10^10 /. sol, {t, T/4, 3 T/4}, AspectRatio -> 1,
PlotRange -> All, PlotStyle -> Red]
f = dp''[t] A /. sol;
NMaximize[{f, T/4 <= t <= 3 T/4}, t]
NMaximize[{f/10^5, T/4 <= t <= 3 T/4}, t]
NMaximize[{f/10^5, T/4 <= t <= 3 T/4}, t]
NMaximize[{f/10^10, T/4 <= t <= 3 T/4}, t]
update2: Here comes my real purpose. Actually, I am trying to make the following 3D region plot. But I found it is very time consuming (more than 3 hours), any ideas to speed up this region plot?
Clear["Global`*"]
d = 1/100;
mu0 = 4 Pi 10^-7;
kN = 97/100;
r = 0.0005;
Rr = 0.02;
eta = 1.3;
e = 3*10^8;
s0 = 3/100;
smax = 1/100; ks = smax/s0;
f = 1; tend = 1/f; T = 1/f;
s = s0*ks*Sin[2*Pi*f*t];
u = D[s, t];
umax = N#First[Maximize[u, t]];
du[i_?NumericQ, xh_?NumericQ, xRp_?NumericQ, xLc_?NumericQ] :=
Module[{Afai, Hc, L, B, tx, n, A, b, Dp0, Q0, Q1, Q, Dp, ode, sol,
sF, uF, width, h, Rp, Lc},
h = xh/100; Rp = xRp/100; Lc = xLc/100;
Afai = Pi ((Rp + h + d)^2 - (Rp + h)^2);
Hc = Rp - Sqrt[Afai/Pi];
L = (2 Afai)/(\[Pi] (h + 2 Rp));
B = (n mu0 i)/(2 h);
tx = 54830.3266978739 (1 - E^(-3.14250266080741 B^2.03187556833859));
n = Floor[(kN Lc Hc)/(Pi r^2)] ;
A = Pi*(Rp^2 - Rr^2);
b = 2*Pi*(Rp + h/2);
Dp0 = 2*tx/h*L;
Q0 = 0;
Q1 = ((1 - 3 (L tx)/(Dp h) + 4 (L^3 tx^3)/(Dp^3 h^3)) Dp h^3)/(
12 eta L) b;
Q = Piecewise[{{Q1, Dp > Dp0}, {Q0, True}}];
Dp = Abs[dp[t]];
ode = u A - A/e ((s0^2 - s^2)/(2 s0 )) dp'[t] == Q*Sign[dp[t]];
sol = First[
NDSolve[{ode, dp[0] == 0}, dp, {t, 0, tend} , MaxSteps -> 10^4,
MaxStepFraction -> 1/30]];
sF = ParametricPlot[{s, dp[t] A /. sol}, {t, 0, tend},
AspectRatio -> 1];
uF = ParametricPlot[{u, dp[t] A /. sol}, {t, 0, tend},
AspectRatio -> 1];
tdu = NMaximize[{dp''[t] A /10^8 /. sol, T/4 <= t <= 3 T/4}, {t,
T/4, 3 T/4}, AccuracyGoal -> 6, PrecisionGoal -> 6];
width = Abs[u /. tdu[[2]]];
{uF, width, B}]
RegionPlot3D[
du[1, h, Rp, Lc][[2]] <= umax/6, {h, 0.1, 0.2}, {Rp, 3, 10}, {Lc, 1,
10}, LabelStyle -> Directive[18]]
NMaximize::cvdiv is issued if the optimum improved a couple of orders of magnitude during the optimization process, and the final result is "large" in an absolute sense. (To prevent the message in a case where we go from 10^-6 to 1, for example.)
So yes, scaling the objective function can have an effect on this.
Strictly speaking this message is a warning, and not an error. My experience is that if you see it, there's a good chance that your problem is unbounded for some reason. In any case, this warning is a hint that you might want to double check your system to see if that might be the case.