求助求助：怎样解一个七元七次方程组

helloling

通过附件上的方法， 本人解出了四元十一次的方程组 。但是这种方法在遇到七元十三次方程组时，遇到了困难，机子运行半个小时都没解出来！请问各位高手，我应该怎么办？？这个方程组已经困扰我两个礼拜了，急切盼望各位帮忙！七元十三次方程组我以通过附件传了上来……

[ 本帖最后由 helloling 于 2007-8-27 09:49 编辑 ]

FreddyMusic

please attached the mathematica code or *.nb file. Thanks

helloling

不好意思啊 第一次到这里  说是不支持上传*nb文件啊

FreddyMusic

把你的文件用 winzip 压缩成, *.rar 就可上传了。

helloling

已经上传了  谢谢帮忙啦

FreddyMusic

My laptop is not very high speed.

You can solve this equation by this way.

1. Options[NSolve]

2. reduce the WorkingPrecision -> 1 ,or reduce some other option,  so that we can win the time.( I am testing )

3.  Try to find the initial point(s)

4. FindRoot[eqns, {Subscript[x, 1], 0}, {Subscript[x, 2], 0}, {Subscript[
  x, 3 ], 0}, {Subscript[x, 4], 0}, {Subscript[x, 5 ], 1}, {Subscript[
  x, 6 ], 1}, {Subscript[x, 7 ], 1}]
   FindRoot near the initial point at the 3#

If it not works. come back.

helloling

如果没看错，版主用的是牛顿迭代法，这里最关键的应该就是选初值了，但是我遇到的那个问题有些不同。因为事实上，原题中第一项的x1 + x2 + x3 + x4 + x5+x6+ x7 ==Pi*7/4*1/2，这里的1/2是一个一定范围内的变量m，那么如果用牛顿迭代法，岂不是每一个m都要凑一个初值？我这么猜。
     我曾经在一本文献上看到，用resultant函数可以解这道题，但具体怎么操作，文章里并没有讲。

FreddyMusic

you can check ref/Method, default is  Method -> "QuasiNewton"

you can select other Method -> "ExplicitRungeKutta".

you equation is complicated, resultant function might be a solution.

you can also start from last two equations for analisys. That seems easy ?

Subscript[x, 2] + Subscript[x, 6 ] - 2 Subscript[x, 4 ] == 0,
Subscript[x, 1] + Subscript[x, 3 ] + Subscript[x, 5 ] + Subscript[x,
  7 ] - 4 Subscript[x, 4 ] == 0

helloling

是的 通过最后两个式子 已经可以算出X4  但是其他的还是没有办法
   无从下笔了……

FreddyMusic

One of the skill I learn from Mathematica is try to visualize your function and problem.
Visualization and Graphics means we can see and find it. That's the way we approach the core.
That means you need to plot it from a kind of prospect. That will help you to think and find tips.
QuasiNewton method has the advantage for quick convergence, but not good at precision goal.

Two weeks no progress that is normal. I have no big progress since two years before. :D

helloling

烦啊烦   :L

xjzuo

这个问题建议用1stopt求解，应当较容易．
matlab fsolve也可求解，只是初值较难猜一些．

shamohu

有多组解，这是用1stOpt得出的一组：

x1: 0.905367676340257
x2: 0.714746150249226
x3: 0.588502005510487
x4: 0.392699081714285
x5: 0.306645373933041
x6: 0.0706520131793557
x7: -0.229718728926651

lyjack520

:) :) :)

smarten

用FindRoot是可以解的，就是初值的选取有点问题。我在想能不能和曲线拟和一样让Mathematica做粗略估计，然后再refinement？
现在就是一般的试试看，可能叫碰运气。
很容易看到，当x_i相等时，最后两个方程满足。所以肯定的初值选x_i为相等的值。如果我选0，很容易得到和1stOpt一样的解。我怀疑是不是1stOpt是把0当着default.
Mathematica code:

1. result = FindRoot[eqns, {Subscript[x, #], 0} & /@ Range[7],
   
2.   Method -> "Secant", MaxIterations -> 5000, AccuracyGoal -> Infinity,
   
3.    PrecisionGoal -> 100, WorkingPrecision -> 20]

复制代码

解当然是20位小数：

1. {Subscript[x, 1] -> 0.85231386996076290310,
   
2. Subscript[x, 2] -> 0.68550290723010348771,
   
3. Subscript[x, 3] -> 0.61202102186331554849,
   
4. Subscript[x, 4] -> 0.39269908169872415481,
   
5. Subscript[x, 5] -> 0.25266755226815483349,
   
6. Subscript[x, 6] -> 0.099895256167344821903,
   
7. Subscript[x, 7] -> -0.14620611729733666585}

复制代码

误差code：

1. eqns[[#, 1]]-eqns[[#, 2]] & /@ Range[7] //. result

复制代码

误差值：

1. {0.*10^-20, 0.*10^-18, 0.*10^-18, 0.*10^-16, 0.*10^-15, 0.*10^-20,
   
2. 0.*10^-20}

复制代码

比较：误差和1stOpt差不多，1stOpt的误差：{1.08932*10^-10, -5.32907*10^-15, 1.62093*10^-14, 4.52971*10^-14,
5.56444*10^-13, 1.16573*10^-14, -6.13398*10^-15}。
稍微的差别是因为精度要求的问题。而且我把1stOpt的解放到里面去印证是稳定的。

所以下面的问题是怎么让Mathematica先估计初值，然后求出精确值。

[ 本帖最后由 smarten 于 2008-8-6 11:03 编辑 ]

smarten

下面的方法好像能得到稳定的解，对初值没那么挑剔，就是慢慢提高精度。为了运行快点，开始的时候迭代次数低，然后越来越高。

1. result = FindRoot[eqns, {Subscript[x, #], 0.5} & /@ Range[7],
   
2.   Method -> "Secant", MaxIterations -> 1000, AccuracyGoal -> Infinity,
   
3.    PrecisionGoal -> 100, WorkingPrecision -> 1]
   
4. error = eqns[[#, 1]] - eqns[[#, 2]] & /@ Range[7] //. result;

复制代码

这儿初值是给的0.5,其他的也没问题。

循环：

1. For[i = 1, i <= 20, iter = Floor[1000 Sqrt[i]];
   
2. result = FindRoot[
   
3.    eqns, {result[[#, 1]], result[[#, 2]]} & /@ Range[7],
   
4.    Method -> "Secant", MaxIterations -> iter,
   
5.    AccuracyGoal -> Infinity, PrecisionGoal -> 100,
   
6.    WorkingPrecision -> i];
   
7. error = eqns[[#, 1]] - eqns[[#, 2]] & /@ Range[7] //. result;
   
8. Print[i, "\t", result, "\t", error.error]; i = i + 1]

复制代码

得到：

1. 20        {Subscript[x, 1]->0.85231386996076290309,Subscript[x, \
   
2. 2]->0.68550290723010348750,Subscript[x, \
   
3. 3]->0.61202102186331554871,Subscript[x, \
   
4. 4]->0.39269908169872415481,Subscript[x, \
   
5. 5]->0.25266755226815483353,Subscript[x, \
   
6. 6]->0.099895256167344822117,Subscript[x, 7]->-0.14620611729733666611}        \
   
7. 0.*10^-30

复制代码

其实看看运行，就知道，Mathematica很快就找到最佳的初始值，0，然后就比较快。

另外就是如果你满足Mathematica的精度，用1/10来代替0.1,以及你选的初值靠近1/10，就会得到另外的一组稳定的值，但是误差相对比较大，大概7.4（就是第一个方程不能满足）。如果不是这个，你就是把初值改为100或者-100,都没问题。

yue586

佩服佩服！版主给了一个考虑问题的方法。初值的设定一直是个麻烦事，这样要是灵的话就太好了。

smarten

想了想，觉得可以这样做，先把方程右边变为零，然后把左边的平方求最小值（最好用NMinimize)。把最小值的点作为初值，求出精确解。

1. ClearAll["Global`*"];
   
2. eqns = {Subscript[x, 1] + Subscript[x, 2] + Subscript[x, 3 ] +
   
3.      Subscript[x, 4] + Subscript[x, 5 ] + Subscript[x, 6 ] +
   
4.      Subscript[x, 7 ] - Pi*7/4*1/2 == 0,
   
5.    \!\(
   
6. \*UnderoverscriptBox[\(\[Sum]\), \(i = 1\), \(7\)]\((5 \*
   
7. StyleBox[
   
8. SubscriptBox["x", "i"], "suffix"] - 20
   
9. \*SuperscriptBox[
   
10. SubscriptBox[\(x\), \(i\)], \(3\)] + 16
    
11. \*SuperscriptBox[
    
12. SubscriptBox[\(x\), \(i\)], \(5\)])\)\) == 0,
    
13.    \!\(
    
14. \*UnderoverscriptBox[\(\[Sum]\), \(i = 1\), \(7\)]\((\(-7\)
    
15. \*SubscriptBox[\(x\), \(i\)] + 56
    
16. \*SuperscriptBox[
    
17. SubscriptBox[\(x\), \(i\)], \(3\)] - 112
    
18. \*SuperscriptBox[
    
19. SubscriptBox[\(x\), \(i\)], \(5\)] + 64
    
20. \*SuperscriptBox[
    
21. SubscriptBox[\(x\), \(i\)], \(7\)])\)\) == 0, \!\(
    
22. \*UnderoverscriptBox[\(\[Sum]\), \(i = 1\), \(7\)]\((\(-11\)
    
23. \*SubscriptBox[\(x\), \(i\)] + 220
    
24. \*SuperscriptBox[
    
25. SubscriptBox[\(x\), \(i\)], \(3\)] - 1232
    
26. \*SuperscriptBox[
    
27. SubscriptBox[\(x\), \(i\)], \(5\)] + 2816
    
28. \*SuperscriptBox[
    
29. SubscriptBox[\(x\), \(i\)], \(7\)] - 2816
    
30. \*SuperscriptBox[
    
31. SubscriptBox[\(x\), \(i\)], \(9\)] + 1024
    
32. \*SuperscriptBox[
    
33. SubscriptBox[\(x\), \(i\)], \(11\)])\)\) == 0, \!\(
    
34. \*UnderoverscriptBox[\(\[Sum]\), \(i = 1\), \(7\)]\((13
    
35. \*SubscriptBox[\(x\), \(i\)] - 364
    
36. \*SuperscriptBox[
    
37. SubscriptBox[\(x\), \(i\)], \(3\)] + 2912
    
38. \*SuperscriptBox[
    
39. SubscriptBox[\(x\), \(i\)], \(5\)] - 9984
    
40. \*SuperscriptBox[
    
41. SubscriptBox[\(x\), \(i\)], \(7\)] + 16640
    
42. \*SuperscriptBox[
    
43. SubscriptBox[\(x\), \(i\)], \(9\)] - 13312
    
44. \*SuperscriptBox[
    
45. SubscriptBox[\(x\), \(i\)], \(11\)] + 4096
    
46. \*SuperscriptBox[
    
47. SubscriptBox[\(x\), \(i\)], \(13\)])\)\) == 0,
    
48.    Subscript[x, 2] + Subscript[x, 6 ] - 2 Subscript[x, 4 ] == 0,
    
49.    Subscript[x, 1] + Subscript[x, 3 ] + Subscript[x, 5 ] + Subscript[
    
50.      x, 7 ] - 4 Subscript[x, 4 ] == 0};

复制代码

1. res = NMinimize[Total[eqns[[#, 1]]^2 & /@ Range[7]],
   
2.   Subscript[x, #] & /@ Range[7], AccuracyGoal -> Infinity,
   
3.   PrecisionGoal -> 100, WorkingPrecision -> 10,
   
4.   Method -> "SimulatedAnnealing"]

复制代码

1. result = FindRoot[
   
2.   eqns, {res[[2, #, 1]], res[[2, #, 2]]} & /@ Range[7],
   
3.   Method -> "Secant", MaxIterations -> 5000, AccuracyGoal -> Infinity,
   
4.    PrecisionGoal -> 100, WorkingPrecision -> 20]

复制代码

得到解：
{Subscript[x, 1] -> -0.14620611729733667152,
Subscript[x, 2] -> 0.099895256167344818036,
Subscript[x, 3] -> 0.61202102186331554256,
Subscript[x, 4] -> 0.39269908169872415480,
Subscript[x, 5] -> 0.85231386996076290551,
Subscript[x, 6] -> 0.68550290723010349158,
Subscript[x, 7] -> 0.25266755226815484268}
误差：
In[56]:= eqns[[#, 1]] & /@ Range[7] //. result

Out[56]= {0.*10^-20, 0.*10^-18, 0.*10^-18, 0.*10^-16, 0.*10^-15,
0.*10^-20, 0.*10^-20}

yue586

同前面解的值一样，只是顺序不一样。