I want to solve multiple equations so I thought using NMinimize
. The basic idea is that if you have multiple equations with multiple variables :
$$\left\{\begin{split}&f(x,y,z)=0\\ &g(x,y,z)=0 \\& h(x,y,z)=0\\\end{split}\right.$$
You can find the solution by minimizing : $|f(x,y,z)|+|g(x,y,z)|+|h(x,y,z)|$.
So this is what I'm trying to do here in this code with the functions p[a0, b0, c, d, x, y] - p[a0, b0, c, d, w, z]
,Hx[a0, b0, c, d, x, y] - Hx[a0, b0, c, d, w, z]
,
Hy[a0, b0, c, d, x, y] - Hy[a0, b0, c, d, w, z]
.
My problem is that when I'm changing a little bit the condition : z>...
the result becomes different.
Here is the introduction to the NMinimize
:
a0=0.0748294;
b0=0.629316;
h[x_, y_] =
a*x*Log[x] + b*(1 - x - y)*Log[1 - x - y] + c*y*Log[y] - x^2 - d*x*y;
"------------------------------"
Hx[x_, y_] = D[h[x, y], x];
Hy[x_, y_] = D[h[x, y], x];
hxx[x_, y_] = D[h[x, y], x, x];
hxy[x_, y_] = D[h[x, y], x, y];
hyy[x_, y_] = D[h[x, y], y, y];
det[x_, y_] = Det[{{hxx[x, y], hxy[x, y]}, {hxy[x, y], hyy[x, y]}}];
p[x_, y_] = h[x, y] - x*Hx[x, y] - y*Hy[x, y];
h[a_, b_, c_, d_, x_, y_] = h[x, y];
p[a_, b_, c_, d_, x_, y_] = p[x, y];
Hx[a_, b_, c_, d_, x_, y_] = Hx[x, y];
Hy[a_, b_, c_, d_, x_, y_] = Hy[x, y];
det[a_, b_, c_, d_, x_, y_] = det[x, y];
x = 0.001;
y = 0.001;
w = 0.4;
And here are the several NMinimize
changing a little bit the condition. As you can see, the condition I'm changing is z>0.2
,z>0.3
,z>0.4
. And as you can see all the results give $z>0.4$ so none of them contradicts any of the conditions.
sol = NMinimize[{Abs[p[a0, b0, c, d, x, y] - p[a0, b0, c, d, w, z]] +
Abs[Hx[a0, b0, c, d, x, y] - Hx[a0, b0, c, d, w, z]] +
Abs[Hy[a0, b0, c, d, x, y] - Hy[a0, b0, c, d, w, z]],
c > 0 && d > 0 && z > 0.2 && z < 1 - w &&
det[a0, b0, c, d, w, z] > 0}, {c, d, z}, Reals,
AccuracyGoal -> 20, PrecisionGoal -> 22, MaxIterations -> 1000]
sol = NMinimize[{Abs[p[a0, b0, c, d, x, y] - p[a0, b0, c, d, w, z]] +
Abs[Hx[a0, b0, c, d, x, y] - Hx[a0, b0, c, d, w, z]] +
Abs[Hy[a0, b0, c, d, x, y] - Hy[a0, b0, c, d, w, z]],
c > 0 && d > 0 && z > 0.3 && z < 1 - w &&
det[a0, b0, c, d, w, z] > 0}, {c, d, z}, Reals,
AccuracyGoal -> 20, PrecisionGoal -> 22, MaxIterations -> 1000]
sol = NMinimize[{Abs[p[a0, b0, c, d, x, y] - p[a0, b0, c, d, w, z]] +
Abs[Hx[a0, b0, c, d, x, y] - Hx[a0, b0, c, d, w, z]] +
Abs[Hy[a0, b0, c, d, x, y] - Hy[a0, b0, c, d, w, z]],
c > 0 && d > 0 && z > 0.4 && z < 1 - w &&
det[a0, b0, c, d, w, z] > 0}, {c, d, z}, Reals,
AccuracyGoal -> 20, PrecisionGoal -> 22, MaxIterations -> 1000]
The results :
-> {0., {c -> 0.584662, d -> 2.09663, z -> 0.486347}}
-> {1.94289*10^-16, {c -> 0.560407, d -> 2.26232, z -> 0.507207}}
-> {1.8735*10^-16, {c -> 0.114809, d -> 3.31333, z -> 0.571615}}
As you can see they are all different. How can I do to find the exact result ?
EDIT :
What I ended up doing is to write :
sol = Table[
NMinimize[{((p[a0, b0, c, d, x, y] -
p[a0, b0, c, d, w, z])^2 + (Hx[a0, b0, c, d, x, y] -
Hx[a0, b0, c, d, w, z])^2 + (Hy[a0, b0, c, d, x, y] -
Hy[a0, b0, c, d, w, z])^2)*1000000,
c > 0 && d > 0 && z > nn && z < 1 - w &&
det[a0, b0, c, d, w, z] > 0}, {c, d, z}, Reals,
AccuracyGoal -> 20, PrecisionGoal -> 22,
MaxIterations -> 1000], {nn, 0.3, 0.575, 0.025}]
And I plotted the results, as one can see it converges :
ListPlot[sol[[All, 1]]]
ListPlot[Table[z /. sol[[n, 2, 3]], {n, 1, Length[sol]}]]
ListPlot[Table[d /. sol[[n, 2, 2]], {n, 1, Length[sol]}]]
ListPlot[Table[c /. sol[[n, 2, 1]], {n, 1, Length[sol]}]]
I'm not sure it's a good method, even now convergence is generally a good sign.
FindAllCrossings3D
but I get multiple results when I'd like to have only one and the value ofAbs[p[a0, b0, c, d, x, y] - p[a0, b0, c, d, w, z]] + Abs[Hx[a0, b0, c, d, x, y] - Hx[a0, b0, c, d, w, z]] + Abs[Hy[a0, b0, c, d, x, y] - Hy[a0, b0, c, d, w, z]]
is a bit higher than with NMinimize. So it's a great code but I don't manage to get the right results for my case. How can I do this Levenberg-Marquardt method with Mathematica ? $\endgroup$