# A problem in bifurcation diagram

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 == 1, y == -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}] The output is very strange, is there a way to make it look like a proper bifurcation diagram?

• 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. – Chris K Jul 12 '18 at 13:48
• @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$. – AtoZ Jul 12 '18 at 14:04
• 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. – Chris K Jul 12 '18 at 15:50
• @ChrisK, I have posted an answer to my post, probably you can have a look at the code there. – AtoZ Jul 13 '18 at 11:02

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 == 1, y == -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 • 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. – AtoZ Jul 12 '18 at 14:12
• 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? – Gregory Rut Jul 12 '18 at 14:20
• 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. – AtoZ Jul 12 '18 at 14:29
• The bifurcation occurs for R. So the x-axis will be R – AtoZ Jul 12 '18 at 14:35

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 == 1,
Sqrt[-1]*y'[t] == B*y[t] - R*y[t]*Abs[y[t]]^2 - A*x[t],
y == 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, #[]} & /@
pts[[First@Cases[pp[], 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.