Solving system of quadratic equations - wolfram-mathematica

Question

Can anyone see a way to solve the system below? I tried Reduce but evaluation takes a while so I'm not sure it would work
terms = {{g^2, g h, h^2, -o^2, -o p, -p^2}, {g^2, g k,
k^2, -o^2, -o q, -q^2}, {g^2, g m, m^2, -o^2, -o r, -r^2}, {g^2,
g n, n^2, -o^2, -o s, -s^2}, {h^2, h k,
k^2, -p^2, -p q, -q^2}, {h^2, h m, m^2, -p^2, -p r, -r^2}, {h^2,
h n, n^2, -p^2, -p s, -s^2}, {k^2, k m,
m^2, -q^2, -q r, -r^2}, {k^2, k n, n^2, -q^2, -q s, -s^2}, {m^2,
m n, n^2, -r^2, -r s, -s^2}};
vars = Variables#Flatten#terms;
coefs = Array[c, Dimensions[terms]];
eqs = MapThread[#1.#2 == 0 &, {terms, coefs}];
Reduce[eqs, vars, Reals]

Answer 1

You can approach your problem from the optimization perspective, building the sum of squares of the r.h.s. of your equations.
Define your matrix:
mat[{g_, h_, k_, m_, n_, o_, p_, q_, r_, s_}] := {{g^2, g h,
h^2, -o^2, -o p, -p^2}, {g^2, g k, k^2, -o^2, -o q, -q^2}, {g^2,
g m, m^2, -o^2, -o r, -r^2}, {g^2, g n,
n^2, -o^2, -o s, -s^2}, {h^2, h k, k^2, -p^2, -p q, -q^2}, {h^2,
h m, m^2, -p^2, -p r, -r^2}, {h^2, h n,
n^2, -p^2, -p s, -s^2}, {k^2, k m, m^2, -q^2, -q r, -r^2}, {k^2,
k n, n^2, -q^2, -q s, -s^2}, {m^2, m n, n^2, -r^2, -r s, -s^2}};
Now define the code that solve the algebraic equation as a constrained optimization:
Clear[SolveAlgebraic];
SolveAlgebraic[
coefs_ /; Dimensions[coefs] == {10, 6} && MatrixQ[coefs, NumberQ],
opts : OptionsPattern[NMinimize]] :=
Module[{g, h, k, m, n, o, p, q, r, s, eqs, vars, val, sol},
eqs = MapThread[#1.#2 &, {mat[
vars = {g, h, k, m, n, o, p, q, r, s}], coefs}];
{val, sol} =
NMinimize[{Total[eqs^2],
vars.vars > 1 && Apply[And, Thread[vars >= 0]]}, vars, opts];
{val, vars /. sol}
]
Now define a function that constructs a set of c[,] with a given solution:
CoefficientWithSolution[sol_ /; Length[sol] == 10] :=
Block[{cc,
v}, ((Array[
cc, {10, 6}]) /. (First[
Quiet#Solve[(MapThread[
Dot, {mat[Array[v, 10]], Array[cc, {10, 6}]}] == 0 //
Thread), Array[cc, {10, 6}] // Flatten]] /.
Thread[Array[v, 10] -> (sol)]) /. _cc :> 1)]
Generate a matrix:
In[188]:= coefs =
CoefficientWithSolution[{1, 2, 3, 4, 5, 6, 7, 8, 9, 10}]
Out[188]= {{1, 1, 1, 1, 1, -(71/49)}, {1, 1, 1, 1, 1, -(71/64)}, {1,
1, 1, 1, 1, -(23/27)}, {1, 1, 1, 1, 1, -(13/20)}, {1, 1, 1, 1,
1, -(43/32)}, {1, 1, 1, 1, 1, -(28/27)}, {1, 1, 1, 1,
1, -(4/5)}, {1, 1, 1, 1, 1, -(11/9)}, {1, 1, 1, 1, 1, -(19/20)}, {1,
1, 1, 1, 1, -(11/10)}}
Solve equations with higher working precision, and coerce to machine numbers:
In[196]:= SolveAlgebraic[coefs, WorkingPrecision -> 30] // N
Out[196]= {1.41177*10^-28, {0.052633, 0.105266, 0.157899, 0.210532,
0.263165, 0.315798, 0.368431, 0.421064, 0.473697, 0.52633}}
Verify that the expected solution is found:
In[197]:= Rest[Last[%]]/First[Last[%]]
Out[197]= {2., 3., 4., 5., 6., 7., 8., 9., 10.}
Hope this helps.