I am trying to solve a nonlinear system of equations by using the Solve (and NSolve) command, but the evaluation get stuck.
For a very similar system, basically the same but with the derivatives of the equations I get no problems. I define the functions I need, write the equations, define the variables, define the solutions through the Solve command, and, once obtained with another system the initial values, I try to solve the system with NSolve.
Defining the functions:
a[x_] := A (1 - ms[x])
b[x_]:=2 ((ArcSinh[nn[x]/ms[x]] ms[x]^3 + nn[x] ms[x] Sqrt[nn[x]^2 + ms[x]^2])/(8 \[Pi]^2) + (ArcSinh[pp[x]/ms[x]] ms[x]^3 + pp[x] ms[x] Sqrt[pp[x]^2 + ms[x]^2])/(8 \[Pi]^2))
where A is a constant. Here I deleted some multiplicative constants to simplify the problem.
Then I have the equations:
eq1[x_]:= B a[x] + C a[x]^2 + D a[x]^3 - F b[x]
eq2[x_]:= pp[x]^3 - nn[x]^3
eq3[x_]:= G - (pp[x]^3 + nn[x]^3)
eq4[x_]:= Sqrt[nn[x]^2 + ms[x]^2] - Sqrt[pp[x]^2 + ms[x]^2] - Sqrt[m + ee[x]^2] + H (pp[x]^3 - nn[x]^3)
where B, C, D, G, m and H are constants. Here too, I deleted some multiplicative constants, to simplify the code for you.
Finally, I define the variables:
Var = {ee[x], pp[x], nn[x], ms[x]}
then solve the system "implicitly":
Sol =
Solve[{eq1[x] == 0, eq2[x] == 0, eq3[x] == 0, eq4[x] == 0}, Var]
(N.B: it is here that the code get stuck!!!! Despite, as I said, with a similar system with derivatives of the equations, everything work fine.)
and make a list of the equations:
eqs =
Table[Var[[i]] == (Var[[i]] /. Sol[[1]]), {i, Length[Var]}];
To conclude, after having obtained the initial conditions, I would try to solve the system:
system0 = Flatten[{eqs, ee[xi] == eei, pp[xi] == ppi, nn[xi] == nni, ms[xi] == msi}];
sol0 = NSolve[system0, {ee, kpp, nn, ms}, {x, xi, xf}, Flatten[{MaxSteps -> 10^4, MaxStepFraction -> 10^-2, WorkingPrecision -> 30, InterpolationOrder -> All}, 1]];
where I previously set xi = 10^-8 and xf = 10.
Trying to be more clear, when I try to evaluate the system through the Solve command, the evaluation continues indefinitely and I cannot understand why, where is the mistake. Despite a similar system with the derivative of the previous equations and NSolve replaced with NDSolve, works without any problem, and the execution of the "equivalent" line (Sol = Solve[{eq1[x] == 0, eq2[x] == 0, eq3[x] == 0, eq4[x] == 0}, Core]) is extremely fast (~1 sec).
Any help to understand where I am wrong is welcome, as well any suggestion to solve numerically this kind of system of equations.
Trying to be more clear, when I try to evaluate the system through the Solve command, the evaluation continues indefinitely and I cannot understand why, where is the mistake. Despite a similar system with the derivative of the previous equations and NSolve replaced with NDSolve, works without any problem, and the execution of the "equivalent" line (Sol = Solve[{eq1[x] == 0, eq2[x] == 0, eq3[x] == 0, eq4[x] == 0}, Core]) is extremely fast (~1 sec).
Any help to understand where I am wrong is welcome, as well any suggestion to solve numerically this kind of system of equations.
Related
I have been away from Mathematica for quite a while and am trying to fix some old notebooks from v4 that are no longer working under v11. I'm also a tad rusty.
I am attempting to use functional minimization to fit a polynomial of variable degree to an arbitrary function (F) given a starting guess (ao) and domain of interest (d). Note that while F is arbitrary, its nature is such that the integral of the product of F and a polynomial (or F^2) can always be evaluated algebraically.
For the sake of example, I'll use the following inputs:
ao = { 1, 2, 3, 4 }
d = { -1, 1 }
F = Sin[x]
To do so, I create an array of 'indexed' variables
polyCoeff = Array[a,Length[a],0]
Result: polycoeff = {a[0], a[1], a[2], a[3]}
I then create the polynomial itself using the following
genPoly[{},x_] := 0
genPoly[a_List,x_] := First[a] + x genPoly[Rest[a],x]
poly = genPoly[polyCoeff,x]
Result: poly = a[0] + x (a[1] + x (a[2] + x a[3]))
I then define my objective function as the integral of the square of the error of the difference between this poly and the function I am attempting to fit:
Q = Integrate[ (poly - F[x])^2, {x, d[[1]],d[[2]]} ]
result: Q = 0.545351 - 2. a[0.]^2 + 0.66667 a[1.]^2 + .....
And this is where things break down. poly looks just as I expected: a polynomial in x with coefficients that look like a[0], a[1], a[2], ... But, Q is not exactly what I expected. I expected and got a new polynomial. But not the coefficients contained a[0.], a[1.], a[2.], ...
The next step is to create the initial guess for FindMinimum
init = Transpose[{polyCoeff,ao}]
Result: {{a[0],1},{a[1],2},{a[3],3},{a[4],4}}
This looks fine.
But when I make the call to FindMinimum, I get an error because the coefficients passed in the objective (a[0.],a[1.],...) do not match those passed in the initial guess (a[0],a[1],...).
S = FindMinimum[Q,init]
So I think my question is how do I keep Integrate from changing the arguments to my coefficients? But, I am open to other approaches as well. Keep in mind though that this is "legacy" work that I really don't want to have to completely revamp.
Thanks much for any/all help.
given the constants
mu = 20.82;
ex = 1.25;
kg1 = 1202.76;
kp = 76.58;
kvb = 126.92;
I need to invert the function
f[Vpx_,Vgx_] := Vpx Log[1 + Exp[kp (1/mu + Vgx/(Vpx s[Vpx]))]];
where
s[x_] := 1 + kvb/(2 x^2);
so that I get a function of two variables, the second one being Vgx.
I tried with
t = InverseFunction[Function[{Vpx, Vgx}, f[Vpx, Vgx]], 1, 2];
tested with t[451,-4]
It takes so much time that every time I try it I stop the evaluation.
On the other side, working with only one variable, everything works:
Vgx = -4;
t = InverseFunction[Function[{Vpx}, f[Vpx,Vgx]]];
t[451]
It's my fault? the method is inappropriate? or it's a limitation of Wolfram Mathematica?
Thanks
Teodoro Marinucci
P.S. For everyone interested it's a problem related to the Norman Koren model of triodes.
As I said in my comment, my guess is that InverseFunction first tries to solve symbolically for the inverse, e.g. Solve[Function[{Vpx, Vgx}, f[Vpx, Vgx]][X, #2] == #1, X], which takes a very long time (I didn't let it finish). However, I came across a system option that seems to turn this off and produce a function:
With[{opts = SystemOptions["ExtendedInverseFunction"]},
Internal`WithLocalSettings[
SetSystemOptions["ExtendedInverseFunction" -> False],
t = InverseFunction[Function[{Vpx, Vgx}, f[Vpx, Vgx]], 1, 2],
SetSystemOptions[opts]
]];
t[451, -4]
(* 199.762 *)
A couple of notes:
According to the documentation, InverseFunction with exact input should produce an exact answer. Here some of the parameters are approximate (floating-point) real numbers, so the answer above is a numerical approximation.
The actual definition of t depends on f. If f changes, then a side effect will be that t changes. If that is not something you explicitly want, then it is probably better to define t this way:
t = InverseFunction[Function[{Vpx, Vgx}, Evaluate#f[Vpx, Vgx]], 1, 2]
As my late Theoretical Physics professor said, "a simple and beautiful solution is likely to be true".
Here is the piece of code that works:
mu = 20.82; ex = 1.25; kg1 = 1202.76; kp = 76.58; kvb = 126.92;
Ip[Vpx_, Vgx_] = Power[Vpx/kp Log[1 + Exp[kp (1/mu + Vgx/Sqrt[kvb + Vpx^2])]], ex] 2/kg1;
Vp[y_, z_] := x /. FindRoot[Ip[x, z] == y, {x, 80}]
The "real" amplification factor of a tube is the partial derivative of Ip[Vpx, Vgx] by respect to Vgx, with give Vpx. I would be happier if could use the Derivative, but I'm having errors.
I'll try to understand why, but for the moment the definition
[CapitalDelta]x = 10^-6;
[Micro][Ipx_, Vgx_] := Abs[Vp[Ipx, Vgx + [CapitalDelta]x] - Vp[Ipx, Vgx]]/[CapitalDelta]x
works well for me.
Thanks, it was really the starting point of the FindRoot the problem.
I have a function f(x,t) and I'd like to plot the function of the solution x(t) of f(x(t),t)=0 using Mathematica. How can I do it?
Mathematica is often quite different to other programming languages I can use. Normally, I would try something looking like:
Create arrays X, T
For t in T do
solve (numerically) f(x,t)=0, append the solution to X
Plot X
However, I don't know really well how to use loops in Mathematica yet, and the same for arrays, so I'm having serious problems doing this.
Is there some rapid, direct way of solving this problem with Mathematica? If not, could somebody please help me out with this?
Also, does anybody have a better title for the question?
Edit: Following the suggestion of #LutzL, I would try something like the following:
Table[FindRoot[f[x,t]==0,{x,x_0}],{t,start,stop,step}]
Would this work correctly?
I still have a problem, because my function f(x,t) is highly nonlinear, and thus i would like to input a good starting point for every t. Specifically, I know the solution for t=0 and I would like to use for time step t_{n+1} the solution for t_n. Is there a way to do this?
Edit 2: I solved the problem the following way:
tmax = 10; nsteps = 100*tmax;
thrust = {v/2 - g}; angle = {Pi/2};
For[i = 1, i <= nsteps, i++,
sol = {thr, \[Theta]} /.
FindRoot[{eq1[i*tmax/nsteps],
eq2[i*tmax/nsteps]}, {{thr, Last[thrust]}, {\[Theta],
Last[angle]}}]; AppendTo[thrust, sol[[1]]];
AppendTo[angle, sol[[2]]]];
ListPlot[Table[{i*tmax/nsteps, thrust[[i + 1]]}, {i, 0, nsteps}]]
ListPlot[Table[{i*tmax/nsteps, angle[[i + 1]]/Pi}, {i, 0, nsteps}]]
where eq1 and eq2 are my equations and thrust and angle are the solutions
A way to do it would be to create a list and then to plot it.
You have x(0) and you want x(t) for t>0. You can use the expression Szabolcs provides:
root(t_NumericQ, x0_):= Module[{z}, z = z /. FindRoot[f[z, t] == 0, {z, x0}]]
And then you compute and plot a list.
list[tin_, tend_, tstep_, x0_] := Module[{z = x0, t = tin}, lis = {};
While[t < tend, z = root[t, z]; lis = Append[lis, {t, z}]; t = t + tstep; ];
ListPlot[lis]]
Or you can change the last line for a x=Interpolation[lis] and x[t] will be an interpolation function for the solution x(t)
Moreover you can test whether other solutions for x(t) are possible replacing root[t,z] for RandomReal[{x_1,x_2}] where x_1and x_2 are in the range of the x space you want to explore.
I am looking for some help with a Poisson Solver I am writing in Mathematica. The code is quite long with Arrays plugged in, but the full details can be found at http://pastebin.com/uSrSDcW6
I am calculating voltages given charge densities using the central difference method derived from Poisson's Eqn. After calculating the voltage, I test the data set for convergence. I am setting convergence thresholds on the order of 10^-1000+. I have the loop set up to kick out after 10000 iterations incase something goes awry, as a fail safe. I have a loop counter in place for sanity. The program seems to run fine as long as the convergence threshold is set to 10^-100.
My question is this: No matter what I update the threshold too, ex, 10^-100, 10^-150, the computation stops after 633 iterations and kicks out of the loop. I would appreciate any help with this, I am completely stuck. I've added comments to the program that should be explanatory for anyone on this forum. Again, I know this description is limited, so please see the attached url http://pastebin.com/uSrSDcW6 for the full program.
*Update10/9/12***I've isolated my issue down to the 16 digit machine precision. I need to open that up to my machine max precision of 10^309. Mathematica Help is sparse on how to do this. ex "N[MachinePrecision, 50]". Where would I set this in my program to apply it to all computation? Ill paste the loop here if that helps
Vnew / Vold / RHO are 10x10x34 Matrices
Epsilon is a constant
(Initialize ConvergenceLoop to O - This will serve as a fail safe to kick out of the loop if necessary)
ConvergenceLoop = 0;
(Initialize Convergence to zero)
Convergence = 0;
While[Convergence == 0 && ConvergenceLoop < 10000,
(Run through all i,j,k elements,calculating new voltage values)
Do[Vnew[[i]][[j]][[k]] = (1/(2/deltaX^2 + 2/deltaY^2 +
2/deltaZ^2)) *(((Vold[[i + 1]][[j]][[k]] +
Vold[[i - 1]][[j]][[k]])/(deltaX^2)) + ((Vold[[i]][[j + 1]][[k]] +
Vold[[i]][[j - 1]][[k]])/(deltaY^2)) + ((Vold[[i]][[j]][[k + 1]] +
Vold[[i]][[j]][[k - 1]])/(deltaZ^2)) + ((Rho[[i]][[j]][[k]]/Epsilon))), {i, 2, 9}, {j, 2,9}, {k, 2, 33}];
(Assume converged so the loop is triggered when the test hits the first value exceeding the defined convergence threshold)
Convergence = 1;
(This is the convergence test. User defined Convergence threshold)
Do[If[Vold[[i]][[j]][[k]] == 0, Null,
If[(Vnew[[i]][[j]][[k]] - Vold[[i]][[j]][[k]])/Vold[[i]][[j]][[k]] > .0000001, Convergence = 0;
(*This is purely diagnostic. I added a Tracker point to follow the convergence along.
user defined at any element*)
If[i == 5 && j == 5 && k == 10,
Print[ "Tracker Point" (Vnew[[i]][[j]][[k]] -
Vold[[i]][[j]][[k]])/Vold[[i]][[j]][[k]]], Null],Null]], {i, 2, 9}, {j, 2, 9}, {k, 2, 33}];
(Ignore the first iteration until Vnew and Vold are nonzero)
If[ConvergenceLoop < 2, Convergence = 0, Null];
(Forces Vold to evolve with Vnew)
Vold = Vnew;
ConvergenceLoop ++;]
(Added SessionTime for future planning purposes)
If[ConvergenceLoop == 10000,
Print["Convergence Loop Limit Reached. " (SessionTime[]/3600) ],
Print["Convergence Loop Limit Not Reached."]];
(We broke out of the while loop,meaning our data converged,so print the converged values)
If[Convergence == 1,
Print[ ConvergenceLoop "Congratulations Converged!" MatrixForm [Vnew]], Print["Did Not Converge!"]];
Since based on the comments above you have narrowed this to a precision problem as I suspected, please read these:
Funny behaviour when plotting a polynomial of high degree and large coefficients
Global precision setting
Confused by (apparent) inconsistent precision
I have a problem to plot a solution of a system of equotations in Mathematica. My system of equotations has two variables (s12 and t). It's not possible to solve it explicitly (s12:=f(t)), but I am able to get a solution for each positive t. But what I want, is a plot with t on the x-achses and s12(t) on the y-achses.
My best gues is that since I get the single solution always with the comment
"*Solve::ratnz: Solve was unable to solve the system with inexact coefficients. The answer was obtained by solving a corresponding exact system and numericizing the result*" this doesn not work with infinite solution for mathematica.
I might have to surpress this warning or does anyone has another idea?. I only need a rough plot.
The problem is as follows:
ClearAll["Global`*"];
cinv1 = 40;
cinv2 = 4;
cinv3 = 3;
h2 = 1.4;
h3 = 1.2;
alpha = 0.04;
z = 20;
p = 0.06;
cop1 = 0;
cop2 = 1;
cop3 = 1.5;
l2 = 0.1;
l3 = 0.17;
teta2 = 0.19;
teta3 = 0.1;
co2 = -0.1;
smax = 40;
c = 1;
Plot[Solve[{s12 == ((cinv1 -
cinv2) + ((cinv2 - cinv3)*((s12 teta2)/(
Sqrt[ (teta2 - teta3)] Sqrt[
c s12^2 teta2 - (2 alpha z)/c]))))/((1/(teta2 -
teta3))*((teta2*cop3 - teta3*cop2) + (teta2*h3*l3*E^(p*t) -
teta3*h2*l2*E^(p*t)))), s12 > 0}, s12, Reals], {t, 0, 10}]
As already said, when I use a specific t, I get a solution, otherwise I receive the message as follows:
"*Solve::ratnz: Solve was unable to solve the system with inexact coefficients. The answer was obtained by solving a corresponding exact system and numericizing the result*"
"*Solve::ratnz: Solve was unable to solve the system with inexact coefficients. The answer was obtained by solving a corresponding exact system and numericizing the result*"
"*Solve::ratnz: Solve was unable to solve the system with inexact coefficients. The answer was obtained by solving a corresponding exact system and numericizing the result*"
*"General::stop: "Further output of \!\(\*
StyleBox[
RowBox[{\"Solve\", \"::\", \"ratnz\"}], \"MessageName\"]\) will be suppressed during this calculation""*
Thanks a lot for your help,
Andreas
The system has 4 solutions, 3 of them positive in the range of interest:
s2 = Solve[{s12 - ((cinv1 - cinv2) + ((cinv2 - cinv3) ((s12 teta2)/
(Sqrt[(teta2 - teta3)] Sqrt[c s12^2 teta2 - (2 alpha z)/c]))))/
((1/(teta2 - teta3))*((teta2*cop3 - teta3*cop2) +
(teta2*h3*l3*E^(p*t) - teta3*h2*l2*E^(p*t))))} == 0, s12];
Plot[s12 /. s2 , {t, 0, 59}]
Important fact to add:
The proposed solution above is correct, but it uses complex numbers to solve. The graph in the solution above shows only the real part of the complex number. This might lead to some confusion as it did to me.
Though, there is a solution with solely real numbers. Since Mathematica cannot solve the equotation in a "continous way" with real numbers, I finally did a three step approach:
I solved the equotation at discrete points in time
I plotted the solution with ListLinePlot.
I used Interpolation[] to allow for rough detection of intresections with other curves
a = Table[NSolve[{s12 - ((cinv1 - cinv2) +
((cinv2 - cinv3)*((s12 teta2)/(\[Sqrt] (teta2 - teta3)
\[Sqrt](c s12^2 teta2 - (2 alpha z)/c)))))/
((1/(teta2 - teta3))*((teta2*cop3 -teta3*cop2) + (teta2*h3*l3*E^(p*t) -
teta3*h2*l2*E^(p*t)))) == 0}, s12][[1]], {t, 0, 100}];
b = Table[t, {t, 0, 100}];
f1a = s12 /. a;
f1 = Transpose[{b, f1a}];
ceiling1 = ListLinePlot[{f1},
PlotRange -> {{0, 20}, {0, 40}},PlotStyle -> {Black, Dotted, Thickness[0.003]}];
In a next step I also needed to find the intersection of multiple curves created that way. To get a rough estimate, I did the following:
curve1 = Interpolation[f1];
intersec2a = FindRoot[curve1[x2] - t12[x2, l2], {x2, 0}];
intersec2 = x2 /. intersec2a;
Hope this helps