# How can i get the solution of complicated equation?

This is the equation about zeta. NSolve[eq] could not solve this equation. (I think it is too complex to solve by NSolve.)

I want to know how can I solve this equation, which has such a complicated form.

This should be the code for the equation:

eq = (0. - 30.1996 I) ζ^6 +
(0. + 9.81486 I) ζ^5 Sqrt[(0. - 640.701 I) + ζ^2] +
(0. + 20.3847 I) ζ^4 ((0. - 640.701 I) + ζ^2) +
(0. + 20.3847 I) ζ^5 Sqrt[(0. - 1127.53 I) + ζ^2] -
(0. + 20.3847 I) ζ^3 ((0. - 640.701 I) + ζ^2) Sqrt[(0. - 1127.53 I) + ζ^2] +
(0. + 9.81486 I) ζ^4 ((0. - 1127.53 I) + ζ^2) -
(0. + 9.81486 I) ζ^3 Sqrt[(0. - 640.701 I) + ζ^2] ((0. - 1127.53 I) + ζ^2) +
408.549 (
(0. - 0.630868 I) ζ^3 - (0. + 14.0909 I) ζ^2 Sqrt[(0. - 640.701 I) + ζ^2] -
(0. + 1.21667 I) ζ ((0. - 640.701 I) + ζ^2) -
(0. + 6.45738 I) ζ^2 Sqrt[(0. - 1127.53 I) + ζ^2] +
(0. + 14.7217 I) ((0. - 640.701 I) + ζ^2) Sqrt[(0. - 1127.53 I) + ζ^2] +
(0. + 0.585806 I) ζ ((0. - 1127.53 I) + ζ^2) +
(0. + 7.08825 I) Sqrt[(0. - 640.701 I) + ζ^2] ((0. - 1127.53 I) + ζ^2)) == 0;
-
You can try FindRoot; if you post actual code people will be more willing to help though. –  b.gatessucks May 24 '13 at 7:57
Also it might be helpful to know the context in which the equation came up. What problem are you trying to solve? –  Thies Heidecke May 24 '13 at 8:24
Justed added the code using OCR. –  gwr May 24 '13 at 14:28

This can be simplified quite a bit, since most of the real parts are zero:

f[ζ_] =
FullSimplify[(0. - 30.1996 I) ζ^6 + (0. + 9.81486 I) ζ^5*
Sqrt[ζ^2 - (0. + 640.701 I)] + (0. + 20.3847 I) ζ^5*
Sqrt[ζ^2 - (0. + 1127.53 I)] + (0. +
20.3847 I) ζ^4 (ζ^2 - (0. + 640.701 I)) + (0. +
9.81486 I) ζ^4 (ζ^2 - (0. + 1127.53 I)) - (0. +
9.81486 I) ζ^3*
Sqrt[ζ^2 - (0. + 640.701 I)]*(ζ^2 - (0. +
1127.53 I)) - (0. +
20.3847 I) ζ^3 (ζ^2 - (0. + 640.701 I))*
Sqrt[ζ^2 - (0. + 1127.53 I)] +
408.549 ((0. - 0.630868 I) ζ^3 - (0. + 14.0909 I) ζ^2*
Sqrt[ζ^2 - (0. + 640.701 I)] - (0. +
6.45738 I) ζ^2*
Sqrt[ζ^2 - (0. + 1127.53 I)] - (0. +
1.21667 I) ζ (ζ^2 - (0. + 640.701 I)) + (0. +
0.585806 I) ζ (ζ^2 - (0. + 1127.53 I)) + (0. +
7.08825 I)*
Sqrt[ζ^2 - (0. + 640.701 I)] (ζ^2 - (0. +
1127.53 I)) + (0. +
14.7217 I) (ζ^2 - (0. +
640.701 I)) Sqrt[ζ^2 - (0. + 1127.53 I)])]

FindRoot[f[ζ] == 0, {ζ, 7}]

(* {ζ -> 6.98478 + 0.493405 I} *)

Where my guess for the root was from a quick look at the plots:

Plot[{Re[f[ζ]], Im[f[ζ]]}, {ζ, -10, 10}]

Edit: The Rationalize[] wasn't necessary

-

## Introduction

### Update 6/2014

Originally, I found three solutions; now it's six. I thought I knew there were three because rationalizing the equation results in a polynomial of degree 24 and NSolve finds 24 roots and then eliminate roots that were not zeros of the original equation. It turns out the equation was troublesome from the point of view of numerics and I missed three.

Other modifications:

• It seems more natural to use Rationalize to convert the coefficients to exact numbers in this case than SetPrecision.

• Likewise I replaced First @ eq with Subtract @@ eq.

## Rationalize the equation

One should keep in mind that according to the documentation on NSolve

NSolve deals primarily with linear and polynomial equations.

The OP's equation is an algebraic equation that can be turned into a polynomial equation, which NSolve can then solve easily. Since NSolve does not do this on its own, we have to rationalize "by hand." Rationalization tends to introduce extraneous solutions, so we have to check the answers returned by NSolve. The somewhat nasty coefficients of eq make it harder, since in rationalizating eq, round-off error leads to some of the square-roots not canceling out as they should. We can fix that by setting the precision of eq to Infinity.

We can find the square-roots in an expression expr with

DeleteDuplicates @ Cases[expr, Power[_, 1/2], Infinity]

Then for each square-root, we can multiply expr by the expression with the square-root replaced by its negative and simplify.

Below is the result of applying the method to the function obtained by replacing Equal in eq by Subtract with Apply (@@). We can solve the equation exactly.

eqExact = Rationalize[Subtract @@ eq];

rationalized =
Simplify @ Fold[
Expand[Times @@ (#1 /. {{}, {#2 -> -#2}})] &,
eqExact,
DeleteDuplicates@Cases[eqExact, Power[_, 1/2], Infinity]];

rootsRatExact = Solve[rationalized == 0, ζ];
rootsRat = NSolve[rationalized == 0, ζ]
(* 24 roots
{{ζ -> -24559.6 + 24559.6 I}, <<22>>, {ζ -> 24559.6 - 24559.7 I}}
*)

There are some significant differences between the two solutions:

(ζ /. rootsRat) - (ζ /. rootsRatExact) // Abs // Max
(*
3.15226*10^-10
*)

## Selecting the roots of the given equation

Update: Here is where I missed some zeros.

I used Pick to select roots at which the original equation eq has a small value, less than some small threshold, say 10^-1. We can check later that each is a root, but I did not check for other roots. The original roots were:

rootsEq = Pick[rootsRat, Abs[Subtract @@ eq] < 10^-1 /. rootsRat]
(*
{{ζ -> -3.78042 - 5.50655 I}, {ζ -> -3.20562 + 5.39914 I}, {ζ -> 6.98478 + 0.493405 I}}
*)

These correspond to roots 7, 9, and 20 in rootsRat:

Position[Subtract @@ eq /. rootsRat, _?(Abs[#] < 10^-1 &)]
(*
{{7}, {9}, {20}}
*)

If I check the exact equation for zeros with PossibleZeroQ, I get more roots:

Position[eqExact /. rootsRatExact, _?PossibleZeroQ]
(*
{{1}, {7}, {9}, {14}, {20}, {21}}
*)

[Note: PossibleZeroQ[.., Method -> "ExactAlgebraics"] takes forever on these potential roots, or at least longer than I was willing to wait.]

Interestingly, these additional roots are connected to the differences between the results returned by NSolve and Solve:

Position[Abs @ Chop[(ζ /. rootsRat) - (ζ /. rootsRatExact), 10^-13], _?Positive]
(*
{{1}, {2}, {3}, {14}, {21}, {22}, {23}, {24}}
*)

Let's let our new roots be the following and we can check them below:

rootsEqNew = Pick[rootsRatExact, PossibleZeroQ[eqExact /. rootsRatExact]];
rootsEqNew // N
(*
{{ζ -> -24559.6 + 24559.6 I},   {ζ -> -3.78042 - 5.50655 I}, {ζ -> -3.20562 + 5.39914 I},
{ζ -> -0.0832786 - 722.827 I}, {ζ -> 6.98478 + 0.493405 I}, {ζ -> 722.642 - 0.100823 I}}
*)

### Checks

At first, at doesn't look too good for the new additions:

eqExact /. rootsEqNew // N
(*
{ 0.            + 9.7614*10^12 I,    (*  {1} *)
-1.49012*10^-8 + 3.91155*10^-8 I,   (*  {7} *)
-1.39698*10^-8 - 3.63216*10^-8 I,   (*  {9} *)
-2.            + 1536. I,           (* {14} *)
1.49012*10^-8 + 1.11759*10^-8 I,   (* {20} *)
0.            + 1024. I}           (* {21} *)
*)

The problem is in evaluating the equation with machine precision.

N[eqExact /. rootsEqNew, 50]
(* N::meprec warning about $MaxExtraPrecision being reached *) (* {069.62973568978663 + 069.69302870899077 I, 090.5174054423328 + 090.55817837498498 I, 090.50250822096415 + 090.54414468499085 I, 080.1824915073549 + 079.76650578675965 I, 090.47483650216002 + 090.49782363232914 I, 080.17292602755023 + 079.76710897249409 I} *) The warning does not appear to be significant. Bumping up$MaxExtraPrecision to 2000 still produces the warning and zeros with accuracies around 2020 to 2040. If they are zeros, N probably will always produce the warning, since 0. cannot have a Precision (other than MachinePrecision).

-
NSolve[Rationalize[eqs],\[Zeta], WorkingPrecision ->500] will give results in agreement with your 6. MachinePrecision is not sufficient to validate three of the roots. –  Daniel Lichtblau Jun 22 '14 at 20:32
@DanielLichtblau Oh, of course. Thanks. –  Michael E2 Jun 22 '14 at 22:53
Wasn't as obvious as one might like, since NSolve with defaults was falling flat on this. I found the underlying problems so at some point it will do better (getting all but the last solution, which it discards due to size of residual at relatively modest precision). –  Daniel Lichtblau Jun 25 '14 at 17:55

As suggested by b.gatessucks, though this seems to produce imperfect results---and I don't understand why Intersection[out,out] does not remove repeated roots...

eq2 = FullSimplify[eq == 0];
out = ParallelTable[ ζ /. Quiet@FindRoot[eq2, { ζ, 500 RandomComplex[]}], {5000}];
test = Intersection[out, out];
tol = 10^-1;
list = {test[[1]]};
Do[
If[Norm[test[[i]] - test[[i + 1]]] > tol,
AppendTo[list, test[[i + 1]]]], {i, Length[test] - 1}];
list[[Flatten@
Position[
Chop[ eq /. ζ -> list[[#]] & /@ Range[Length[list]], 10^-6],
0]]]

This is not pretty, nor particularly robust.

-
Intersection[out, out] doesn't remove repeated roots because they are not exactly the same, only approximately the same. Use something like DeleteDuplicates[out, Chop[#1 - #2] == 0 &]. (You'll find that FindRoot[eq2, { ζ, 500 RandomComplex[]}] does a pretty bad job and produces hundreds of non-roots.) –  Michael E2 Dec 26 '13 at 16:09