Solving a complicated equation of order 5. completely parametrically

Question

I have this equation and it takes so much time to solve. i would appreciate some guidance how to solve it. 0<l<1 and 0<gamma<1 and -Pi/2<theta<Pi/2 and w is real and positive. other variable are just constant numbers and all positive.

Subscript[\[Lambda], 1] = 
Subscript[s, 1]*Sqrt[q^2 + w^2 + 1] /. 
q -> (w*Sin[\[Theta]] + I*\[Gamma])/Cos[\[Theta]] // FullSimplify;

Subscript[\[Lambda], 2] = 
Subscript[s, 2]*Sqrt[q^2 + w^2 + l^2] /. 
q -> (w*Sin[\[Theta]] + I*\[Gamma])/Cos[\[Theta]] // FullSimplify;

Solve[Subscript[\[Lambda], 
 1]*(l^2 + (-Subscript[\[Alpha], 2] + Subscript[\[Alpha], 3])*
   Subscript[\[Lambda], 2]^2 + (1 + 
     Subscript[\[Alpha], 
      1])*(w^2 + (I*\[Gamma]*Sec[\[Theta]] + 
        w*Tan[\[Theta]])^2))*
     ((-Subscript[C, 1133])*
   Subscript[\[Alpha], 
    3]*(w^2 + (I*\[Gamma]*Sec[\[Theta]] + w*Tan[\[Theta]])^2) + 
  Subscript[C, 
    3333]*(l^2 - 
     Subscript[\[Alpha], 2]*Subscript[\[Lambda], 1]^2 + 
             (1 + 
        Subscript[\[Alpha], 
         1])*(w^2 + (I*\[Gamma]*Sec[\[Theta]] + 
           w*Tan[\[Theta]])^2))) - 
Subscript[\[Lambda], 
 2]*(l^2 + (-Subscript[\[Alpha], 2] + Subscript[\[Alpha], 3])*
   Subscript[\[Lambda], 1]^2 + 
        (1 + 
     Subscript[\[Alpha], 
      1])*(w^2 + (I*\[Gamma]*Sec[\[Theta]] + 
        w*Tan[\[Theta]])^2))*((-Subscript[C, 1133])*
   Subscript[\[Alpha], 
    3]*(w^2 + (I*\[Gamma]*Sec[\[Theta]] + w*Tan[\[Theta]])^2) + 
        
  Subscript[C, 
    3333]*(l^2 - 
     Subscript[\[Alpha], 2]*
      Subscript[\[Lambda], 2]^2 + (1 + 
        Subscript[\[Alpha], 
         1])*(w^2 + (I*\[Gamma]*Sec[\[Theta]] + 
           w*Tan[\[Theta]])^2))) == 0, w]

Answer 1

Considerable progress can be made as follows. First, replace Subscript in the equation, because it slows calculations and is inconvenient besides. This can be done by defining

f[z1_, z2_] := ToExpression[StringJoin @@ (ToString /@ {z1, z2})]

and then use /.Subscript -> f on the equation appearing in Solve in the question. The result is

eq = 
s1 Sqrt[1 + w^2 + (I γ Sec[θ] + w Tan[θ])^2] (l^2 + (1 + α1) (w^2 + (I γ 
    Sec[θ] + w Tan[θ])^2) + s2^2 (-α2 + α3) (l^2 + w^2 + (I γ Sec[θ] + 
    w Tan[θ])^2)) (-C1133 α3 (w^2 + (I γ Sec[θ] + w Tan[θ])^2) + 
    C3333 (l^2 + (1 + α1) (w^2 + (I γ Sec[θ] + w Tan[θ])^2) - 
    s1^2 α2 (1 + w^2 + (I γ Sec[θ] + w Tan[θ])^2))) - 
s2 Sqrt[l^2 + w^2 + (I γ Sec[θ] +  w Tan[θ])^2] (l^2 + (1 + α1) (w^2 + (I γ 
    Sec[θ] + w Tan[θ])^2) + s1^2 (-α2 + α3) (1 + w^2 + (I γ Sec[θ] + 
    w Tan[θ])^2)) (-C1133 α3 (w^2 + (I γ Sec[θ] + w Tan[θ])^2) + 
    C3333 (l^2 + (1 + α1) (w^2 + (I γ Sec[θ] + w Tan[θ])^2) - 
    s2^2 α2 (l^2 + w^2 + (I γ Sec[θ] + w Tan[θ])^2))) == 0

Notice that w appears only in the combination, w^2 + (I γ Sec[θ] + w Tan[θ])^2, so significant simplification can be achieved by the substitution,

eq1 = eq /. w^2 -> x - (I γ Sec[θ] + w Tan[θ])^2
(* -s2 Sqrt[l^2 + x] (C3333 (l^2 + x (1 + α1) - s2^2 (l^2 + x) α2) - 
   C1133 x α3) (l^2 + x (1 + α1) + s1^2 (1 + x) (-α2 + α3)) + 
   s1 Sqrt[1 + x] (C3333 (l^2 + x (1 + α1) - s1^2 (1 + x) α2) - 
   C1133 x α3) (l^2 + x (1 + α1) + s2^2 (l^2 + x) (-α2 + α3)) == 0 *)

with w obtained from x by

Simplify[Solve[w^2 + (I γ Sec[θ] + w Tan[θ])^2 == x, w], -Pi/2 < θ < Pi/2]
(* {{w -> -Cos[θ] (Sqrt[x + γ^2] + I γ Tan[θ])}, 
    {w -> Sqrt[x + γ^2] Cos[θ] - I γ Sin[θ]}} *)

An obvious choice to obtain real w > 0 is θ = 0, which yields, w -> Sqrt[x + γ^2], positive real for x > -γ^2. An approach for obtaining x begins by eliminating the Sqrts from eq1 and factoring the result.

eq1sq = Subtract @@ (eq1[[1, 1]]^2 == eq1[[1, 2]]^2);
fac1 = FactorList[eq1sq];
LeafCount /@ First[Transpose[%]]
(* {1, 24, 4908} *)

The second factor is of manageable size and can be solved readily.

x12 = Solve[fac1[[2, 1]] == 0, x] // Simplify // Flatten
(* {x -> (-s1^2 + l^2 s2^2)/(s1^2 - s2^2)} *)

That it actually satisfies the original equation is verified by

Simplify[eq1 /. x12, s1 > 0 && s2 > 0]
(* True *)

Here is a sample plot of w vs {s1, s2}

Quiet@Plot3D[Sqrt[(-s1^2 + l^2 s2^2)/(s1^2 - s2^2) + γ^2] 
    /. {l -> 1/2, γ -> 1/2}, {s2, 0, 5}, {s1, 0, 5}, 
    AxesLabel -> {s2, s1, w}, PlotLabel -> "{l -> 1/2, γ -> 1/2}", 
    LabelStyle -> {Bold, Black}, PlotPoints -> 100]

The larger factor also can be solved by

Collect[fac1[[3, 1]], x, Simplify];
Solve[% == 0, x]

but the four resulting solutions are unmanageably complicated. Moreover, two or three of them (depending on the choice of parameter values) do not satisfy the original equation. Of course, eq1 can be solved numerical for any specific parameters; i.e.,

param1 = C1133 -> 0.820599, C3333 -> 0.84379, l -> 0.157808, s1 -> 0.94172, 
    s2 -> 0.768998, α1 -> 0.651002, α2 -> 0.8877, α3 -> 0.474658}
Flatten@Solve[Simplify[0 == eq1 /. SetPrecision[param1, 30]]]
(* {x -> -2.951519117927659465922, x -> -2.096574605386734359552, 
    x -> -0.01329052999440164484502} *)

The third root leads to a positive real value for w for most values of γ.