1
$\begingroup$

I want to solve an equation and Plot a graph of $\delta(\tau)$, where $0<\tau,\delta<1$. In principal $\delta(0)=1,\delta(1)=0$. However, when I solve the equation, the points near $\tau=1$ can't get exactly. Below is my sample code:

Clear["Global`*"];
eps = 10^-13;
stepSize = 0.001; 
omegaD = 0.5; 
df = 0.008; 
c1 = omegaD/df; 
c0 = c0 /. FindRoot[1/c0 Log[Cosh[c1 c0]] == Sqrt[c1^2 + 1] - 1, {c0, Log[2]}];
list = Table[{τ, δ /. FindRoot[τ Log[Cosh[c0 Sqrt[c1^2 + \delta^2]/τ]/Cosh[c0 δ/τ]] == c0 (Sqrt[c1^2 + 1] - 1), 
                              {δ, 1}]}, {τ, eps, 1.0,stepSize}];
p1 = ListLinePlot[list]

Program complains that:

The line search decreased the step size to within tolerance specified \
by AccuracyGoal and PrecisionGoal but was unable to find a sufficient \
decrease in the merit function. You may need more than \
MachinePrecision digits of working precision to meet these tolerances.@ 

Also clearly shown in the graph, the points near $\tau=1$ is missing.

enter image description here

So I tried to add an option WorkingPrecision->30 at the end of the FindRoot function, the program complain the following this time:

the precision of the argument function ... is less than WorkingPrecision (30.)

Even I decrease 30 to other number, it still complaining.

Question is how to add the missing points correctly at the boundary?

$\endgroup$
  • 1
    $\begingroup$ The precision of your arguments must be at least as high as the WorkingPrecision you are requesting. You should change your parameters to exact values, e.g. stepSize = 1/1000; omegaD = 1/2; df = 8/1000; and retry. $\endgroup$ – MarcoB Oct 26 '15 at 15:41
  • $\begingroup$ As a sidenote to what @MarcoB correctly said, you can also just write 0.01//Rationalize for instance. That might be more convenient for you $\endgroup$ – Lukas Oct 26 '15 at 16:30
5
$\begingroup$

First, the Table does not run up to t == 1.:

Table[τ, {τ, 1/20, 1, stepSize}]
(*  {1.*10^-13, 0.001,..., 0.998, 0.999}  *)

Update -- Now with the corrected formula (a typo fixed in the OP), let's try

list = Table[{τ, δ /. 
    FindRoot[τ Log[Cosh[c0 Sqrt[c1^2 + δ^2]/τ]/Cosh[c0 δ/τ]] == c0 (Sqrt[c1^2 + 1] - 1),
     {δ, 1}]},
  {τ, Union[Range[eps, 1.0, stepSize], {1.}]}]
p1 = ListLinePlot[list]

Mathematica graphics

We get the desired plot.

$\endgroup$
  • $\begingroup$ IF you do it analytically, you may find it is indeed 0. That is why I think I need more precision. I will show the analytical derivation when I am at computer. $\endgroup$ – an offer can't refuse Oct 27 '15 at 4:20
  • 1
    $\begingroup$ It's my mistake, I wrongly typed a character in my code. $\endgroup$ – an offer can't refuse Oct 27 '15 at 6:53
  • $\begingroup$ @buzhidao Thanks. I've updated the answer to your new input. $\endgroup$ – Michael E2 Oct 27 '15 at 11:34
  • 1
    $\begingroup$ @downvoter, Why? It would be helpful to the site to indicate a reason you think there is an issue with the answer! $\endgroup$ – Michael E2 Oct 27 '15 at 11:36
  • $\begingroup$ Thanks, I've also got that figure after I spot that misprint. $\endgroup$ – an offer can't refuse Oct 27 '15 at 12:18

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.