# Given f[b,d,k]=0 and g[b,d,k]=0, I need to find a branch (provided it exists) of k[b,d] such that this system has a solution in b,d

I have two polynomials in k given by f[b,d,k] and g[b,d,k]. I know that there exists a function k[u,v] such that, when we evaluate this function in the system, we get a new equation h[b,d]=0, which defines a curve. I would like to find that solution in k. The problem is that, for instance, we could have that g is a fourth-degree polynomial in k and, if we extract all the roots with

Solve[g[b,d,k]==0,k],


then it could happen that some functions k=k[b,d] don't provide a solvable equation

f[b,d,k[b,d]]==0

Up until now, what I've done is the following thing:

sols = Solve[g[b,d,k] == 0, k];
For[l = 1, l <= Length[sols], l++,
ktemp = sols[[l]][][];
tempcurve = f[b,d,k] /. k -> ktemp;
tempplot = ContourPlot[tempcurve == 0, {b,0,4}, {d,0,6}];
If[ Length[Cases[Normal@tempplot, Line[x_] :> x, Infinity]] > 0,
k = ktemp;
Break;
]
];


However, as this code is plotting each implicit function for each k, it may take a long time. I was wondering if there is an optimal way to do this.

I'm currently just testing my code so I am not dealing with difficult functions for now but take, for example,

f[b,d,k]=d + k^2 + 0.002025 d k^2 + 0.002025 k^4 + b^2 (1 + (0.002025 - 2/(b^2 + d)) k^2) g[b,d,k]=1 + 0.002025 d + b^2 (0.002025 - 2/(b^2 + d)) + 0.00405 k^2

Of course, in that case, g can be easily solved for k^2, but I am trying to work out the general case as I stated before.

• This sounds like a problem that can be solved with a Gröbner basis. Please give a concrete example of your $f(u,v,k)$ and $g(u,v,k)$ so that people can experiment. Jul 21, 2021 at 14:47

Don't kwow if i got your question right.

If you solve with Reduce you see, you get two solution functions k[b,d] depending on variables b and d. (I rationalized for better layout)

ff=f[b_, d_, k_] =
d + k^2 + 0.002025 d k^2 + 0.002025 k^4 +
b^2 (1 + (0.002025 - 2/(b^2 + d)) k^2) // Rationalize[#,0]&;
gg=g[b_, d_, k_] =
1 + 0.002025 d + b^2 (0.002025 - 2/(b^2 + d)) +  0.00405 k^2 //
Rationalize[#,0]&;

red2 = Reduce[Rationalize[{f[b, d, k] == 0, g[b, d, k] == 0}, 0], k,
Reals];

red2 /. Or ->
Composition[(Column[#, Right, Background -> {{White, LightGray}},
Frame -> All] &), List]] Edit

You can extract k[b,d] for instance with

ksol2[b_, d_] = k /. Rule @@ red2[[1, 2, 1, 2, 2]]


but then you get a surface, you can plot with pl = Plot3D[ksol2[b, d], {b, 0, 6}, {d, 0, 8}, PlotPoints -> 200]

Since you need a 3 dimensional curve (in parameter form, both d and k depending on the one parameter b), you better (than red2) solve for d and k directly with sol3 and plot the curve pp

sol3 = Solve[{f[b, d, k] == 0, g[b, d, k] == 0}, {d, k}, Reals] //
Simplify

pp = ParametricPlot3D[Evaluate[{b, d, k} /. sol3], {b, 0, 5},
AxesLabel -> {b, d, k}, PlotStyle -> {{Thick, Red}}]


Together with the contour plot for both equations, see the curve as red intersection line (i consider only positive b,d,k)

cpff = ContourPlot3D[ff == 0, {b, 0, 2}, {d, 0, 2}, {k, 0, 12},
PlotPoints -> 20, AxesLabel -> {b, d, k},
ContourStyle -> {Opacity[.5], Green}]

cpgg = ContourPlot3D[gg == 0, {b, 0, 2}, {d, 0, 2}, {k, 0, 12},
PlotPoints -> 20, AxesLabel -> {b, d, k},
ContourStyle -> {Opacity[.5], Blue}]

Show[cpff, cpgg, pp] Her we provide a way to draw such plot.

f[b_, d_, k_] =
d + k^2 + 0.002025 d k^2 + 0.002025 k^4 +
b^2 (1 + (0.002025 - 2/(b^2 + d)) k^2) // Rationalize;
g[b_, d_, k_] =
1 + 0.002025 d + b^2 (0.002025 - 2/(b^2 + d)) + 0.00405 k^2 //
Rationalize;
eq = Exists[k, f[b, d, k] == 0 && g[b, d, k] == 0];
sol = Resolve[eq, Reals, Backsubstitution -> True]
ContourPlot[sol // Last // Evaluate, {b, -5, 5}, {d, -5, 5},
RegionFunction -> Function[{b, d, k}, sol // Most // Evaluate],
PlotPoints -> 50, MaxRecursion -> 4]


b^2 + d != 0 && -40000 b^4 + 81 b^6 + 243 b^4 d + 40000 d^2 + 243 b^2 d^2 + 81 d^3 <= 0 && 1600000000 b^4 - 19440000 b^6 + 6561 b^8 - 3200000000 b^2 d - 45360000 b^4 d + 26244 b^6 d + 1600000000 d^2 - 32400000 b^2 d^2 + 39366 b^4 d^2 - 6480000 d^3 + 26244 b^2 d^3 + 6561 d^4 == 0

The same as

Eliminate[{f[b, d, k] == 0 , g[b, d, k] == 0}, k] • That's wonderful but how can I get the value of k explicitly? Jul 21, 2021 at 16:21

We can plot the space curve by

f[b_, d_, k_] =
d + k^2 + 0.002025 d k^2 + 0.002025 k^4 +
b^2 (1 + (0.002025 - 2/(b^2 + d)) k^2) // Rationalize;
g[b_, d_, k_] =
1 + 0.002025 d + b^2 (0.002025 - 2/(b^2 + d)) + 0.00405 k^2 //
Rationalize;
reg = ImplicitRegion[
f[b, d, k] == 0 &&
g[b, d, k] == 0, {{b, -5, 5}, {d, -5, 5}, {k, -25, 25}}];
DiscretizeRegion[reg, MaxCellMeasure -> 10^-5,
PlotRange -> {{-5, 5}, {-5, 5}, {-25, 25}}] And we get the b-d curve again by

RegionPlot[curves, FrameLabel -> {"b", Rotate["d", π/2]},
LabelStyle -> {FontSize -> 15, Brown}] 