1
$\begingroup$

I have the following problem

A = 10; B = -2; tab = 
Table[{sol, points} = 
Reap@NDSolveValue[{Sqrt[-1]*x'[t] == 
   B*x[t] - R*x[t]*Abs[x[t]]^2 - A*y[t], 
   Sqrt[-1]*y'[t] == B*y[t] - R*y[t]*Abs[y[t]]^2 - A*x[t], 
   x[0] == 1, y[0] == -1, 
   WhenEvent[Re[x'[t]] > 0, If[t > 0.1, Sow[y[t]]]]}, {x, y}, {t, 
  0, 50}, MaxSteps -> Infinity]; {R, #} & /@ 
Union[Flatten[points], SameTest -> (Abs[#1 - #2] < .02 &)], {R, 0, 
20, 0.01}];
ListPlot[Re@Flatten[tab, 1], AspectRatio -> .75/GoldenRatio, 
ImageSize -> Large, PlotStyle -> PointSize[Tiny], 
AxesLabel -> {R, x}]

enter image description here

The output is very strange, is there a way to make it look like a proper bifurcation diagram?

Improve this question
$\endgroup$
4
  • 1
    $\begingroup$ What kind of plot were you expecting? The variation in the y-axis is quite small, if you include PlotRange->{0,All} it will appear insignificant, as in @GregoryRut's answer below. $\endgroup$
    – Chris K
    Commented Jul 12, 2018 at 13:48
  • $\begingroup$ @ChrisK I was trying to plot a bifurcation diagram which would look like link, not the same of course, but with an overall shape like a usual bifurcation diagram. The parameters are all flexible, also the conditions. I am just varying different parameters/conditions to arrive at something similar to the above mentioned shape. It has to be for the parameter $R$. $\endgroup$
    – AtoZ
    Commented Jul 12, 2018 at 14:04
  • 1
    $\begingroup$ Could be that your model has no bifurcations in the range of R you've studied. I've NDSolved the equations for a few R in your range and it seems the bifurcation diagram you get is basically correct. $\endgroup$
    – Chris K
    Commented Jul 12, 2018 at 15:50
  • $\begingroup$ @ChrisK, I have posted an answer to my post, probably you can have a look at the code there. $\endgroup$
    – AtoZ
    Commented Jul 13, 2018 at 11:02

2 Answers 2

Reset to default
2
$\begingroup$

I think it might be related with WorkingPrecision. I tried this (Table->ParallelTable, added WorkingPrecision->25, changed {R, 0,20, 0.01} to {R, 0,20, 1/100})

A = 10; B = -2; tab = 
 ParallelTable[{sol, points} = 
   Reap@NDSolveValue[{Sqrt[-1]*x'[t] == 
       B*x[t] - R*x[t]*Abs[x[t]]^2 - A*y[t], 
      Sqrt[-1]*y'[t] == B*y[t] - R*y[t]*Abs[y[t]]^2 - A*x[t], 
      x[0] == 1, y[0] == -1, 
      WhenEvent[Re[x'[t]] > 0, If[t > 0.1, Sow[y[t]]]]}, {x, y}, {t, 
      0, 50}, MaxSteps -> Infinity, 
     WorkingPrecision -> 25]; {R, #} & /@ 
   Union[Flatten[points], SameTest -> (Abs[#1 - #2] < .02 &)], {R, 0, 
   20, 1/100}];
ListPlot[Re@Flatten[tab, 1], AspectRatio -> .75/GoldenRatio, 
 ImageSize -> Large, PlotStyle -> PointSize[Tiny], 
 AxesLabel -> {R, x}]

and got

enter image description here

Improve this answer
$\endgroup$
4
  • $\begingroup$ thanks yes it looks better than mine, however I thought it would be possible to arrive at something similar to link, as I pointed out to ChrisK. $\endgroup$
    – AtoZ
    Commented Jul 12, 2018 at 14:12
  • 1
    $\begingroup$ Is the argument in theplot from the link is the same as R in your code? Are there any other parameters that need to be altered? $\endgroup$
    – Grzegorz Rut
    Commented Jul 12, 2018 at 14:20
  • $\begingroup$ No it is not the same. the R in my code is a different parameter than the link. The link is actually from another post I was trying to implement for my system, available at link. All parameters and conditions can be altered to any degree if it is possible by any means to arrive at a plot similar to the one in the link. I have tried several alterations but didn't work. $\endgroup$
    – AtoZ
    Commented Jul 12, 2018 at 14:29
  • $\begingroup$ The bifurcation occurs for R. So the x-axis will be R $\endgroup$
    – AtoZ
    Commented Jul 12, 2018 at 14:35
0
$\begingroup$

I think in the following plot, the 'bifurcation' diagram appears but it is very complicated. (Note: It was taking too long for $A=10$, so I set $A=1$ in the following code, also the initial conditions changed)

B = -2; A = 1;
s = ParametricNDSolveValue[{Sqrt[-1]*x'[t] == 
 B*x[t] - R*x[t]*Abs[x[t]]^2 - A*y[t], x[0] == 1, 
Sqrt[-1]*y'[t] == B*y[t] - R*y[t]*Abs[y[t]]^2 - A*x[t], 
y[0] == 0}, {x, y}, {t, 0, 100}, {R}];

and

coll = {};
Table[pp = 
ParametricPlot[Re@Through[s[a][t]], {t, 0, 100}, 
PlotRange -> {{-2, 2}, {-2, 2}}, PerformanceGoal -> "Quality", 
MeshFunctions -> (#2 &), Mesh -> {{0.}}, 
MeshStyle -> {Red, PointSize[0.01]}];
pts = pp[[1, 1]];
AppendTo[
coll, {a, #[[1]]} & /@ 
pts[[First@Cases[pp[[1]], Point[x__] :> x, -1]]]];, {a, 0.0, 5, 
0.01}];
lp = ListPlot[Join @@ coll, Frame -> True, PlotStyle -> Red];
Manipulate[
Column[{ParametricPlot[Re@Through[s[par][t]], {t, 0, 100}, 
PlotRange -> {{-2, 2}, {-2, 2}}, PerformanceGoal -> "Quality", 
MeshFunctions -> (#2 &), Mesh -> {{0.}}, 
MeshStyle -> {Red, PointSize[0.01]}, Frame -> True, 
FrameLabel -> {"x[t]", "y[t]"}], 
Show[lp, Graphics[{Gray, Line[{{par, 0}, {par, 4}}]}]]}], {par, 
0.0, 5, 0.01}]

It is a bifurcation diagram in red, but its hard to visualize a point where the stable solution starts to become unstable, i.e., the bifurcation. There are several points or windows in this range which exhibit modes where the solutions could be stable? Beyond these windows on either side, the system seems chaotic.

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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