Solve doesn't give an answer with system of equations

Question

I have to solve the following system of equations:

Solve[{k*Sech[d]*Cos[b]/Sqrt[A^2 + B^2] == 1, 
k*Sech[d]*Sin[b]/Sqrt[A^2 + B^2] == 0, A*k*Tanh[d]/(A^2 + B^2)+c1 == 1,
B*k*Tanh[d]/(A^2 + B^2)+c2 == 0, k*Sech[k + d]*Cos[a + b]/Sqrt[A^2 + B^2] == 1, 
k*Sech[k + d]*Sin[a + b]/Sqrt[A^2 + B^2] == 0.1, 
A*k*Tanh[k + d]/(A^2 + B^2)+c1 == 1.1, 
B*k*Tanh[k + d]/(A^2 + B^2)+c2 == 0}, {k, d, a, b, A, B, c1, c2}]

but Solve will just compute forever and give no result. I've tried also with Reduce and NSolve, but with no luck. I can use approximated answers, so I've tried to use the Taylor series of the second order of the functions Sech Tanh Cos and Sin, but still Solve couldn't give me an answer.

I there something else I could try?

Thank you.

Answer 1

Notice that most of your transcendal functions are neatly separated into pairs of equations.

This will get you most of the way to your solution

sys={k*Sech[d]*Cos[b]/Sqrt[A^2+B^2]==1, k*Sech[d]*Sin[b]/Sqrt[A^2+B^2]==0, 
  A*k*Tanh[d]/(A^2+B^2)+c1==1, B*k*Tanh[d]/(A^2+B^2)+c2==0, 
  k*Sech[k+d]*Cos[a+b]/Sqrt[A^2+B^2]==1, k*Sech[k+d]*Sin[a+b]/Sqrt[A^2+B^2]==1/10, 
  A*k*Tanh[k+d]/(A^2+B^2)+c1==11/10, B*k*Tanh[k+d]/(A^2+B^2)+c2==0};
sol=Eliminate[sys, {Sech[d], Tanh[d], Sech[k+d], Tanh[k+d]}]

which instantly tells you

(* B==0 && c2==0 && Cos[a+b]==10 Sin[a+b] && Sin[b]==0 && A!=0 *)

Follow that with

sys /. ToRules[sol] /. True -> Sequence[]

which instantly tells you

(* {(k Cos[b] Sech[d])/Sqrt[A^2] == 1,
    (10 k Sech[d+k] Sin[a+b])/Sqrt[A^2]==1,
       (k Sech[d+k] Sin[a+b])/Sqrt[A^2]==1/10,
     c1+(k Tanh[d])/A==1,
     c1+(k Tanh[d+k])/A==11/10}*)

Notice one of those equations is obviously redundant and can be eliminated. Then notice c1 can then be eliminated giving even one fewer equation. Then notice that information from the first step is telling you that b is a multiple of Pi and Cos[b] is either +1 or -1.

If you make use of all this information then you might be able to use Reduce to get to the final solution.

Answer 2

Define the set of equations as eq (with all numbers rationalized), and assume that all variables are real. Then,

eq /. k -> 0
(* {False, True, c1 == 1, c2 == 0, False, False, c1 == 11/10, c2 == 0} *)

So, k != 0.

Reduce[eq[[2]] && k != 0, b]
(* (k != 0 && A^2 + B^2 != 0 && Sech[d] == 0) || (C[1] ∈ Integers && 
    k != 0 && A^2 + B^2 != 0 && (b == 2 π C[1] || b == π + 2 π C[1])) *)

Since Sech[d] != 0 for real d, it follows that b is an integer multiple of π. Apply this result to obtain

eq1 = DeleteCases[Simplify[eq /. b -> n Pi, n ∈ Integers], True]
(* {((-1)^n k Sech[d])/Sqrt[A^2 + B^2] == 1, 
    c1 + (A k Tanh[d])/(A^2 + B^2) == 1, 
    c2 + (B k Tanh[d])/(A^2 + B^2) == 0, 
    (k Cos[a + n π] Sech[d + k])/Sqrt[A^2 + B^2] == 1, 
    (10 k Sech[d + k] Sin[a + n π])/Sqrt[A^2 + B^2] == 1, 
    c1 + (A k Tanh[d + k])/(A^2 + B^2) == 11/10, 
    c2 + (B k Tanh[d + k])/(A^2 + B^2) == 0} *)

Factor[First@eq1[[7]] - First@eq1[[3]]]
(* -((B k (Tanh[d] - Tanh[d + k]))/(A^2 + B^2)) *)

Hence, B == 0, and

eq1 /. B -> 0;
(* {((-1)^n k Sech[d])/Sqrt[A^2] == 1, 
    c1 + (k Tanh[d])/A == 1, 
    c2 == 0, 
    (k Cos[a + n π] Sech[d + k])/Sqrt[A^2] == 1, 
    (10 k Sech[d + k] Sin[a + n π])/Sqrt[A^2] == 1, 
    c1 + (k Tanh[d + k])/A == 11/10, 
    c2 == 0} *)

Hence, c2 == 0, and

eq2 = DeleteCases[% /. c2 -> 0, True]
(* {((-1)^n k Sech[d])/Sqrt[A^2] == 1, 
    c1 + (k Tanh[d])/A == 1, 
    (k Cos[a + n π] Sech[d + k])/Sqrt[A^2] == 1, 
    (10 k Sech[d + k] Sin[a + n π])/Sqrt[A^2] == 1, 
    c1 + (k Tanh[d + k])/A == 11/10} *)

This allows a to be calculated.

as = Simplify[Solve[First@eq2[[3]]/First@eq2[[4]] == 1, a][[1,1]]/.C[1] -> m, m ∈ Integers]
(* a -> m π - n π + ArcCot[10] *)
eq3 = Union[eq2 /. as]
(* {((-1)^n k Sech[d])/Sqrt[A^2] == 1, 
    (k Cos[m π + ArcCot[10]] Sech[d + k])/Sqrt[A^2] == 1, 
    (10 k Sech[d + k] Sin[m π + ArcCot[10]])/Sqrt[A^2] == 1, 
    c1 + (k Tanh[d])/A == 1, 
    c1 + (k Tanh[d + k])/A == 11/10} *)

Note that there now are more equations than variables, so one must be redundant. Now, assume that n and m are even integers.

Reduce[eq3 /. {m -> 0, n -> 0}, Reals] // Simplify
(* A == Log[19531250/(30100251 - 2278951 Sqrt[101])]/Sqrt[101] && 
   10 c1 == 11 && d == Log[1/10 (-1 + Sqrt[101])] && 
   10 k == Log[19531250/(30100251 - 2278951 Sqrt[101])] *)

along with the message,

Reduce::ztest1: Unable to decide whether numeric quantity ... is equal to zero. Assuming it is.

Unfortunately, it does not provide the complete expression that it assumes equal to zero, so we cannot evaluate it. Next, assume that n and m are odd integers.

Reduce[eq3 /. {m -> 1, n -> 1}, Reals] // Simplify
(* A == (-Log[2] - 10 Log[5] + Log[30100251 + 2278951 Sqrt[101]])/Sqrt[101] && 
   10 c1 == 11 && 
   d == Log[1/10 (1 + Sqrt[101])] && 
   10 k + Log[30100251 + 2278951 Sqrt[101]] == Log[2] + 10 Log[5] *)

Along with a similar message. On the other hand,

Reduce[eq3 /. {m -> 0, n -> 1}, Reals]
(* False *)
Reduce[eq3 /. {m -> 1, n -> 0}, Reals]
(* False *)

Finally, the question remains of whether the unknown expressions that Reduce assumes equal to zero actually are. To proceed, assume c2 == 11/10, as given in both tentative answers, and also that d == -k`, which also is given in the tentative answers, although not so obviously.

FullSimplify[Log[1/10 (-1 + Sqrt[101])] == 
             -Log[19531250/(30100251 - 2278951 Sqrt[101])]/10]
(* True *)

DeleteCases[Union[Simplify[eq3 /. c1 -> 11/10 /. d -> -k] /. {m -> 0, n -> 0}], True]
(* k == ArcCosh[Sqrt[101]/10] && 
   A == 100 Sqrt[1/101 (-1 + Sqrt[101]/10) (1 + Sqrt[101]/10)] ArcCosh[Sqrt[101]/10] *)

along with the same warning message, but this time with the assumed expression given.

Reduce::ztest1: Unable to decide whether numeric quantity ArcCosh[Sqrt[101]/10]+Log[2]+Log[5]-Log[1+Sqrt[101]] is equal to zero. Assuming it is.

Test it.

FullSimplify[ArcCosh[Sqrt[101]/10] + Log[2] + Log[5] - Log[1 + Sqrt[101]]]
(* 0 *)

Why Reduce did not do this is unclear. Likewise, for odd integers,

FullSimplify[Log[1/10 (1 + Sqrt[101])] == 
                 -(Log[2] + 10 Log[5] - Log[30100251 + 2278951 Sqrt[101]])/10]
(* True *)

DeleteCases[Union[Simplify[eq3 /. c1 -> 11/10 /. d -> -k] /. {m -> 1, n -> 1}], True]
(* {-((10 k)/(Sqrt[101] Sqrt[A^2])) == 1, 
   -((k Sech[k])/Sqrt[A^2]) == 1, 
   (10 k Tanh[k])/A == 1} *)
Reduce[%, {k, A}, Reals]
(* k == -ArcCosh[Sqrt[101]/10] && 
   A == 100 Sqrt[1/101 (-1 + Sqrt[101]/10) (1 + Sqrt[101]/10)] ArcCosh[Sqrt[101]/10] *)
FullSimplify[-ArcCosh[Sqrt[101]/10] + Log[2] + Log[5] - Log[-1 + Sqrt[101]]]
(* 0 *)

All unknowns now are evaluated. By the way, I attempted to use Reduce[eq, Reals] to obtain the complete solution directly, but it failed after several hours for lack of memory on my 16 GB PC.