# Plot numerical solutions for a varying parameter

I would like to solve this equation

$\log{\frac{a}{1 - a}} + b (1 - 2 a) = 0$

letting varying the parameter $b$ in $\lbrace 0,1,\ldots,20\rbrace$ and then plot the result.

I am trying writing the code but I am stuck with this

eq = Log[a/(1 - a)] + b (1 - 2 a) == 0
x = Range[1, 20, 1]
y = x
For[i = 1, i <= Length[x], i++, y[[i]] = NSolve[eq[a, b ./ b -> x[[i]]], a]]


but the syntax is wrong. How can I do my plot? Thanks.

• What should the correct code do? Independently of b, a=1/2 is a solution. If b is an integer greater or equal to 2, there are additional real solutions. Which solutions do you need? – Coolwater Sep 7 '16 at 16:58
• I should have been more precise. I am interested in the case $b>2$ and $a\neq \frac{1}{2}$. In the case $b > 2$ the solutions $a = \frac{1}{2}$ are always local maximums, I want to find the two global minimums. – Nisba Sep 7 '16 at 17:04

I post for insights. By inspection a=1/2 is always a real solution. For insight into the other solutions that vary with b:

f[a_, b_] := Log[a/(1 - a)] + b (1 - 2 a)
cp = ContourPlot[f[y, x], {x, 0, 20}, {y, 0.001, 0.999},
Contours -> {{0.}}, ContourShading -> None, PlotPoints -> 50];
pp = Plot3D[f[y, x], {x, 0, 20}, {y, 0.001, 0.999},
MeshFunctions -> {#3 &}, Mesh -> {{0.}}, MeshStyle -> {Red, Thick},
PlotPoints -> 50];
sol[b_] :=
Chop[(a /.
Quiet[FindRoot[f[a, b] == 0, {a, #},
AccuracyGoal -> Infinity]]) & /@ {0.0001, 0.5, 0.9999}];
rt = ListPlot[Transpose[Table[sol[j], {j, 0, 20, 0.5}]],
Joined -> True, Frame -> True];
Column[{cp, pp, rt}, Frame -> True] Let

eq = Log[a/(1 - a)] + b (1 - 2 a) == 0


First, at all cost don't use For. This is a topic way too broad and extensively covered on this site, so I'll just state it: don't use For, use Do, While, Table, ...

In this case I'll use Table.

Next, NSolve tries to find all solutions, which is usually hard. That's why I plotted the function Log[a/(1 - a)] + b (1 - 2 a) for a few b to see what to expect. This allowed me to set a starting point for FindRoot: the solutions will be near 0 and 1 (in fact, the greater b will be, the closer the solutions will be to 0 or 1).

To find solutions near a=1:

a1 = SetAccuracy[Chop@Table[{i, a /. FindRoot[eq /. b -> i, {a, 0.9999}]}, {i, 3,
20}], 15]


{{3.00000000000000, 0.92927981832006}, {4.000000000000000, 0.97875201203864},...}

up to b=20.

Similarly, to find the other solution:

a0 = SetAccuracy[Chop@Table[{i, a /. FindRoot[eq /. b -> i, {a, 0.0000001}]}, {i, 3,
20}], 15]


{{3.00000000000000, 0.07072018167994}, {4.000000000000000, 0.02124798796136},...}

also up to b=20.

To plot the solutions in dependence on b:

GraphicsRow[{ListPlot[a1, Frame -> True], ListPlot[a0, Frame -> True]}, ImageSize -> 1000] 