Решающая система квадратных уравнений

Question

Может кто-нибудь увидеть способ решения системы ниже?Я пробовал Reduce, но оценка занимает некоторое время, поэтому я не уверен, что это сработает

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

Вы можете подойти к своей проблеме с точки зрения оптимизации, построив сумму квадратов правых от ваших уравнений.

Определите вашу матрицу:

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}};

Теперь определите код, который решаеталгебраическое уравнение как ограниченная оптимизация:

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}
  ]

Теперь определим функцию, которая создает набор из c [, ] с заданным решением:

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)]

Сгенерируйте матрицу:

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)}}

Решите уравнения с более высокой рабочей точностью и приведите номера машин:

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}}

Убедитесь, что найдено ожидаемое решение:

In[197]:= Rest[Last[%]]/First[Last[%]]

Out[197]= {2., 3., 4., 5., 6., 7., 8., 9., 10.}

Надеюсь, это поможет.