# Problem plotting a bifurcation diagram

I have been trying to plot bifurcation diagram for $R$ vs $X$ (or $Y$) for the following problem

    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] /. {A -> 1, B -> -2},
x[0] == 0, y[0] == 0,
WhenEvent[x'[t] > 0, If[t > 4, Sow[y[t]]]]}, {x, y}, {t, 0.1,
20}]; {R, #} & /@
Union[Flatten[points], SameTest -> (Abs[#1 - #2] < .02 &)], {R, 0,
100, 2}];
ListPlot[Re@Flatten[tab, 1], ImageSize -> Large, AxesLabel -> {R, x}]


I get no error messages but an empty plot. Parameters are flexible so I tried several variations with parameters but didn't succeed in plotting.

• Nothing to plot, Flatten[tab, 1]={} is empty! Commented Jul 10, 2018 at 9:24
• You are looking for complex solutions, so the condition $x'[t]>0$ can not be fulfilled. Can be replaced by $Re[x'[t]]>0$, but in this case tab is empty too. Commented Jul 10, 2018 at 10:48
• Yes it keeps giving empty output when even restricting to only real solutions.
– AtoZ
Commented Jul 10, 2018 at 11:40
• It has something to plot if i give it a nonzero initial condition say $x[0]=1, y[0]=0$ but then it gives errors NDSolveValue:Encountered non-numerical value for a derivative at t == 0..
– AtoZ
Commented Jul 10, 2018 at 12:10

I will show the working code and the result, perhaps this is what is required.

A = 1; 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] == 0,
WhenEvent[Re[x'[t]] > 0, If[t > 4, Sow[y[t]]]]}, {x, y}, {t,
0.1, 20}]; {R, #} & /@
Union[Flatten[points], SameTest -> (Abs[#1 - #2] < .02 &)], {R, 0,
100, 2}];
ListPlot[Re@Flatten[tab, 1], ImageSize -> Large, AxesLabel -> {R, x}]


• Could you say what was the problem with OP's code? Commented Jul 10, 2018 at 12:59
• there are two errors: 1) two equations, and a replacement /. {A -> 1, B -> -2} is made one; 2) the condition x '[t]> 0 is used for the complex function. Commented Jul 10, 2018 at 14:01
• @Alex, yes it works. I have tried to modify the code with $A=10$ and $x[0]=1, y[0]=-1$ to actually see a better/clearer bifurcation behavior, It shows a plot but it is not a very clear bifurcation still. Is there a way to improve this?
– AtoZ
Commented Jul 11, 2018 at 6:36
• 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}]`
– AtoZ
Commented Jul 11, 2018 at 6:46