# 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, y == 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! – Ulrich Neumann Jul 10 '18 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. – Alex Trounev Jul 10 '18 at 10:48
• Yes it keeps giving empty output when even restricting to only real solutions. – AtoZ Jul 10 '18 at 11:40
• It has something to plot if i give it a nonzero initial condition say $x=1, y=0$ but then it gives errors NDSolveValue:Encountered non-numerical value for a derivative at t == 0.. – AtoZ Jul 10 '18 at 12:10

## 1 Answer

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 == 1, y == 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? – Chris K Jul 10 '18 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. – Alex Trounev Jul 10 '18 at 14:01
• @Alex, yes it works. I have tried to modify the code with $A=10$ and $x=1, y=-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 Jul 11 '18 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 == 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}]` – AtoZ Jul 11 '18 at 6:46