1
$\begingroup$

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]][[1]][[2]]; 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.

Improve this question
$\endgroup$
1
  • 1
    $\begingroup$ 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. $\endgroup$ Commented Jul 21, 2021 at 14:47

3 Answers 3

Reset to default
1
$\begingroup$

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]; TraditionalForm[ red2 /. Or -> Composition[(Column[#, Right, Background -> {{White, LightGray}}, Frame -> All] &), List]]

enter image description here

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]

enter image description here

Improve this answer
$\endgroup$
0
1
$\begingroup$

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]

enter image description here

Improve this answer
$\endgroup$
1
  • $\begingroup$ That's wonderful but how can I get the value of k explicitly? $\endgroup$ Commented Jul 21, 2021 at 16:21
1
$\begingroup$

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}}]

enter image description here

And we get the b-d curve again by

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

enter image description here

Improve this answer
$\endgroup$

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.