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
Related
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.
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.
The following code gives me the first k eigenvalues of a certain big matrix. Because of the symmetries of the matrix, the eigenvalues are in pairs, one positive and the other negative, with the same absolute value. This is indeed the case if I run the code with the exact matrices, without using the sparse version. However when I make them sparse, the resulting eigenvalues appear to lose the sign information, as now the pairs can be both negative, or both positive, depending on the number I put on "nspins" (which controls the size of the matrix). The variable "sparse" controls whether I use sparse matrices or not.
This issue gives me considerable trouble. Can anybody tell me why the sparse version of the computation gives wrong signs, and how to fix it?
sparse = 1; (*Parameter that controls whether I will use sparse \
matrices, 0 means not sparse, 1 means sparse*)
(*Base matrices of my big matrix*)
ox = N[{{0, 1}, {1, 0}}];
oz = N[{{1, 0}, {0, -1}}];
id = N[{{1, 0}, {0, 1}}];
(*Transformation into sparse whether desired*)
If[sparse == 1,
ox = SparseArray[ox];
oz = SparseArray[oz];
id = SparseArray[id];
]
(*Dimension of the big matrix, must be even*)
nspins = 8;
(*Number of eigenvalues computed*)
neigenv = 4;
(*Algorithm to create big matrices*)
Do[
Do[
If[j == i, mata = ox; matc = oz;, mata = id; matc = id;];
If[j == 1,
o[1, i] = mata;
o[3, i] = matc;
,
o[1, i] = KroneckerProduct[o[1, i], mata];
o[3, i] = KroneckerProduct[o[3, i], matc];
];
, {j, 1, nspins}];
, {i, 1, nspins}];
(*Sum of big matrices*)
ham = Sum[o[1, i].o[1, i + 1], {i, 1, nspins - 1}] +
o[1, nspins].o[1, 1] + 0.5*Sum[o[3, i], {i, 1, nspins}];
(*Print the desired eigenvalues*)
Do[Print [Eigenvalues[ham, k][[k]]], {k, 1, neigenv}];
I'm working on a script in mathematica that will take simulate a string held at either end and plucked, by solving the wave equation via numerical methods. (http://en.wikipedia.org/wiki/Wave_equation#Investigation_by_numerical_methods)
n = 5; (*The number of discreet elements to be used*)
L = 1.0; (*The length of the string that is vibrating*)
a = 1.0/3.0; (*The distance from the left side that the string is \
plucked at*)
T = 1; (*The tension in the string*)
[Rho] = 1; (*The length density of the string*)
y0 = 0.1; (*The vertical distance of the string pluck*)
[CapitalDelta]x = L/n; (*The length of each discreet element*)
m = ([Rho]*L)/n;(*The mass of each individual node*)
c = Sqrt[T/[Rho]];(*The speed at which waves in the string propogate*)
I set all my variables
Y[t] = Array[f[t], {n - 1, 1}];
MatrixForm(*Creates a vector size n-1 by 1 of functions \
representing each node*)
I define my Vector of nodal position functions
K = MatrixForm[
SparseArray[{Band[{1, 1}] -> -2, Band[{2, 1}] -> 1,
Band[{1, 2}] -> 1}, {n - 1,
n - 1}]](*Creates a matrix size n by n governing the coupling \
between each node*)
I create the stiffness matrix relating all the nodal functions to one another
Y0 = MatrixForm[
Table[Piecewise[{{(((i*L)/n)*y0)/a,
0 < ((i*L)/n) < a}, {(-((i*L)/n)*y0)/(L - a) + (y0*L)/(L - a),
a < ((i*L)/n) < L}}], {i, 1, n - 1}]]
I define the initial positions of each node using a piecewise function
NDSolve[{Y''[t] == (c/[CapitalDelta]x)^2 Y[t].K, Y[0] == Y0,
Y'[0] == 0},
Y, {t, 0, 10}];(*Numerically solves the system of second order DE's*)
Finally, This should solve for the values of the individual nodes, but it returns an error:
"NDSolve::ndinnt : Initial condition [Y0 table] is not a number or a rectangular array"
So , it would seem that I don't have a firm grasp on how matrices work in mathematica. I would greatly appreciate it if anyone could help me get this last line of code to run properly.
Thank you,
Brad
I don't think you should use MatrixForm when defining the matrices. MatrixForm is used to format a list of list as a matrix, usually when you display it. Try removing it and see if it works.
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.