3
$\begingroup$

I have the following inequality

$F(\theta)=2e^{-\theta}[\cos\theta + \phi\sin\theta] - e^{-2\theta}[\cos2\theta + \phi \sin2\theta]>1 $.

Herre $\theta\ge0$ is real variable and $\phi$ is a real constant, say 100. How should I proceed to find all the points such that $F(\theta)$ is greater than 1? How to find the maximum values of $F(\theta)$ as a function of $\theta$?

F[x_]=2Exp[-x](Cos[100*x] + Sin[100*x]/100) - Exp[-2x](Cos[2*100*x] + Sin[2*100*x]/100)
$\endgroup$
  • 2
    $\begingroup$ Reduce[F[x] > 1, x]? Or Reduce[F[x] > 1, x, Reals]? $\endgroup$ – Michael E2 Jan 10 '18 at 5:10
  • $\begingroup$ Plotting the function shows that it is highly oscillatory with large amplitude for negative x. $\endgroup$ – bbgodfrey Jan 10 '18 at 5:12
  • $\begingroup$ The solution is unbounded as x approaches -Infinity. $\endgroup$ – bbgodfrey Jan 10 '18 at 5:20
  • $\begingroup$ Sorry, forgot to mention that x is greater than or equal to zero. $\endgroup$ – H. Kenan Jan 10 '18 at 5:32
8
$\begingroup$

This is basically a duplicate of 5663. Here I apply a variant of the NDSolve answer to your question:

{max, one} = {"Maximum", "One"} /. Last @ Reap[
    NDSolveValue[
        {
        v'[x]==F'[x],
        v[0]==F[0],
        WhenEvent[v'[x]<0,Sow[x, "Maximum"]],
        WhenEvent[v[x]==1, Sow[x,"One"]]
        },
        v,
        {x, 0, 1}
    ],
    _,
    Rule
];

Here is a plot showing the maximum, and the points where F[x] is 1:

Plot[
    F[x],
    {x, 0, 1},
    Epilog -> {
        Red, Point[Thread[{max, F[max]}]],
        Blue, Point[Thread[{one, F[one]}]]
    }
]

enter image description here

$\endgroup$
  • $\begingroup$ Thank you very much. Can I find the numerical values of those red dots (maxima )? If not all, at least some of them? $\endgroup$ – H. Kenan Jan 10 '18 at 6:03
  • $\begingroup$ @user149973 If you run my code, than the numerical values of the x coordinates are contained in the max variable. $\endgroup$ – Carl Woll Jan 10 '18 at 6:05
  • $\begingroup$ Thanks a lot! I tried to hit the upvote. But my score is not enough to do it. $\endgroup$ – H. Kenan Jan 10 '18 at 6:07
  • $\begingroup$ thanks for the help. Little more help. If I change cos(x) and sin(x) to hyperbolic cosh(x) and sinh(x) and run the code, I find an error: "....should be a pair of numbers, or a Scaled or Offset form". Could you please help to sort it out? $\endgroup$ – H. Kenan Jan 11 '18 at 20:30
  • $\begingroup$ @user149973 - look at the derivative of the modified function F2[x], Assuming[x > 0, Reduce[F2'[x] < 0, x, Reals] // Simplify] evaluates to True so the function is monotonically decreasing for x > 0Then the maximum occurs at x == 0 F2[0] is 1 $\endgroup$ – Bob Hanlon Apr 9 '18 at 3:08
2
$\begingroup$

A cheat using MeshShading for F(x)>1:

p = Plot[F[x], {x, 0, 1}, GridLines -> {None, {1}}, 
   MeshFunctions -> (#2 &), Mesh -> {{1}}, 
   MeshShading -> {Red, Black}];
pts = p[[1, 1, 1]];
lns = Cases[p[[1]], {Black, Line[x__]} :> x, Infinity];
gl = MinMax[#[[All, 1]]] & /@ (pts[[#]] & /@ lns)
Plot[F[x], {x, 0, 1}, MeshFunctions -> (#2 &), Mesh -> {{1}}, 
 MeshShading -> {Red, Black}, GridLines -> {Flatten[gl], {1}}, 
 GridLinesStyle -> Blue]

Approximate end-points:

{{2.04082*10^-8, 0.0156412}, {0.0477311, 0.0621775}, {0.0635002, 
  0.0778018}, {0.111333, 0.124225}, {0.127114, 0.139847}, {0.17508, 
  0.186129}, {0.190876, 0.201735}, {0.239076, 0.247788}, {0.254898, 
  0.263366}, {0.303622, 0.308897}, {0.319546, 0.324378}}

enter image description here

$\endgroup$
0
$\begingroup$

One can solve the example problem exactly with Solve or approximately with NSolve. You need to find a closed interval that contains the solutions. Then both NSolve and Solve can find the solutions. Solve finds them in terms of Root objects. It's not hard to figure out by hand what an interval would be. For instance, with NSolve (replace NSolve by Solve to get exact expression; see further down):

nsols = NSolve[F[x] == 1 && 0 < x < 1, x, Reals]
(*
  {{x -> 0.0156506}, {x -> 0.0477309}, {x -> 0.0621608}, {x -> 0.0635038},
   {x -> 0.0778032}, {x -> 0.111331},  {x -> 0.124217},  {x -> 0.127115},
   {x -> 0.139848},  {x -> 0.175079},  {x -> 0.186125},  {x -> 0.190881},
   {x -> 0.201739},  {x -> 0.239072},  {x -> 0.247788},  {x -> 0.254904},
   {x -> 0.263371},  {x -> 0.303617},  {x -> 0.308899},  {x -> 0.319545}, {x -> 0.324386}}
*)

Bounding the roots

If you want Mathematica to figure out the bounds on the roots, then the following will do it, but it takes a little human intervention to figure out just what to do.

First, rewrite the equation in terms of variables representing the transcendental functions. For the trigonometric functions, add constraints according to their range. This will result in an upper bound that is too large, but any reasonable upper bound will suffice.

msol = Maximize[{u, 
    2/u (c1 + s1/100) - 1/u^2 (c2 + s2/100) == 1 &&
     -1 <= c1 <= 1 && -1 <= s1 <= 1 && -1 <= c2 <= 1 && -1 <= s2 <= 1},
   u];

Replace the trig. variables by the interval Interval[{-1, 1}]. The Sqrt of an interval won't simplify if the interval contains negative numbers, so we have to remove them.

msol[[1, 1, All, 1]] /. s1 | c1 | s2 | c2 -> Interval[{-1, 1}];
% /. Sqrt[Interval[i__]] :> 
   Sqrt[Interval @@ Select[Clip[{i}, {0, Infinity}], Last[#] > 0 &]];
xmax = % /. Interval -> List // Flatten // Max // Log
(*  Log[1/100 (101 + Sqrt[20301])]  *)

The solutions:

nsols = NSolve[
  F[x] == 1 && 0 < x < xmax,
   x, Reals]
(*  same as above  *)

sols = Solve[  (* takes over a minute, ~90 sec. for me *)
  F[x] == 1 && 0 < x < xmax,
   x, Reals]
(*
  {{x -> Root[{50 - 100 E^#1 + 50 E^(2 #1) - 2 E^#1 Tan[50 #1] + 
       50 Tan[50 #1]^2 + 100 E^#1 Tan[50 #1]^2 + 
       50 E^(2 #1) Tan[50 #1]^2 + Tan[100 #1] + 
       Tan[50 #1]^2 Tan[100 #1] - 50 Tan[100 #1]^2 - 
       100 E^#1 Tan[100 #1]^2 + 50 E^(2 #1) Tan[100 #1]^2 - 
       2 E^#1 Tan[50 #1] Tan[100 #1]^2 - 
       50 Tan[50 #1]^2 Tan[100 #1]^2 + 
       100 E^#1 Tan[50 #1]^2 Tan[100 #1]^2 + 
       50 E^(2 #1) Tan[50 #1]^2 Tan[100 #1]^2 &, 
     0.0156505598145967921159614}]},...}}
*)

Getting the intervals

We can select the intervals where F[x] > 1 by testing points in the interiors of the intervals defined by the roots.

Select[Partition[Flatten[{0., x /. nsols, Infinity}], 2, 1], 
 Replace[#, {{a_Real, b_Real} :> 
     F[(a + b)/2] - 1 > 0, {a_Real, b_Real} :> F[a + 1] - 1 > 0}] &]
(*
  {{0., 0.0156506}, {0.0477309, 0.0621608}, {0.0635038, 0.0778032},
   {0.111331, 0.124217}, {0.127115, 0.139848}, {0.175079, 0.186125},
   {0.190881, 0.201739}, {0.239072, 0.247788}, {0.254904, 0.263371},
   {0.303617, 0.308899}, {0.319545, 0.324386}}
*)

Select[Partition[Flatten[{0, x /. sols, Infinity}], 2, 1], 
 Replace[#, {{a_?NumericQ, b_?NumericQ} :> 
     F[(a + b)/2] - 1 > 0, {a_Real, b_Real} :> F[a + 1] - 1 > 0}] &]
(*
  {{0, Root[{50 - 100 E^#1 + 50 E^(2 #1) - 2 E^#1 Tan[50 #1] + 
      50 Tan[50 #1]^2 + 100 E^#1 Tan[50 #1]^2 + 
      50 E^(2 #1) Tan[50 #1]^2 + Tan[100 #1] + 
      Tan[50 #1]^2 Tan[100 #1] - 50 Tan[100 #1]^2 - 
      100 E^#1 Tan[100 #1]^2 + 50 E^(2 #1) Tan[100 #1]^2 - 
      2 E^#1 Tan[50 #1] Tan[100 #1]^2 - 50 Tan[50 #1]^2 Tan[100 #1]^2 + 
      100 E^#1 Tan[50 #1]^2 Tan[100 #1]^2 + 
      50 E^(2 #1) Tan[50 #1]^2 Tan[100 #1]^2 &, 
    0.0156505598145967921159614}],...}}
*)
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.