Algebraic solution from system of symbolic equations for single variable

Question

I have a mathematical system like
K_1 = c*h/d
K_2 = b*h/c
K_3 = a*h/b
C = a+b+c+d
h+d = W/h + b + 2a
Constants: K_1, K_2, K_3, C, W
Solve for: h, a,b,c,d

Is it possible to use Mathematica to generate a polynomial or other algebraic equation for one or each of the variables h,a,b,c,d in terms of constants K_1, K_2, K_3, C, W alone? (These will usually be fifth degree or above so we cannot solve for the variable directly in terms of the constants. A polynomial in that variable is the best we can do.)

bbgodfrey · Accepted Answer

Combining the approaches by Daniel Huber and Roma Lee provides the desired answer more or less instantly.
eq = {K1 == c*h/d, K2 == b*h/c, K3 == a*h/b, C == a + b + c + d, h + d == W/h + b + 2 a};
sh = Solve[Eliminate[eq, {a, b, c, d}], h] // Flatten
(* {h -> Root[-K1 K2 K3 W + (-2 C K1 K2 K3 - K1 K2 W) #1 + (-C K1 K2 + 
    K1 K2 K3 - K1 W) #1^2 + (K1 K2 - W) #1^3 + (C + K1) #1^4 + #1^5 &, 1], ... *)

where " . . . " represents the other four roots.  Then, solve for the other variables.
sabcd = Solve[Most@eq, {a, b, c, d}] // Flatten
(* {a -> (C K1 K2 K3)/(h^3 + h^2 K1 + h K1 K2 + K1 K2 K3), 
    b -> (C h K1 K2)/(h^3 + h^2 K1 + h K1 K2 + K1 K2 K3), 
    c -> (C h^2 K1)/(h^3 + h^2 K1 + h K1 K2 + K1 K2 K3), 
    d -> (C h^3)/(h^3 + h^2 K1 + h K1 K2 + K1 K2 K3)} *)

producing the desired result.  A sample numerical result is
SeedRandom[1066];
test = Thread[{K1, K2, K3, C , W} -> RandomReal[{-5, 5}, 5]]
(* {K1 -> -0.198869, K2 -> -1.87425, K3 -> -0.429646, C -> -2.69173, W -> 0.774499} *)
sh /. test
Replace[sabcd /. test, List /@ %, Infinity]
(* {h -> -0.868514, h -> 0.118971, h -> 2.95534, 
    h -> 0.342404 - 0.537515 I, h -> 0.342404 + 0.537515 I} *)
(* {{a -> -0.334413, b -> -0.676002, c -> -0.313254, d -> -1.36807}, 
    {a -> -3.68652, b -> 1.02082, c -> -0.0647982, d -> 0.0387649}, 
    {a -> 0.0172311, b -> -0.118525, c -> 0.186891, d -> -2.77733}, 
    {a -> -1.20902 + 0.762827 I, b -> 0.00917872 - 2.12049 I, 
     c -> 0.606457 + 0.390022 I, d -> -2.09835 + 0.967645 I}, 
    {a -> -1.20902 - 0.762827 I, b -> 0.00917872 + 2.12049 I, 
     c -> 0.606457 - 0.390022 I, d -> -2.09835 - 0.967645 I}} *)

This numerical result can be verified quite simply, of course, by
Sort /@ NSolve[eq /. test, {h, a, b, c, d}]

Daniel Huber · Answer

This is how you would write this in MMA:
eq = {K1 == c*h/d,
   K2 == b*h/c,
   K3 == a*h/b,
   C == a + b + c + d,
   h + d == W/h + b + 2 a
   };
sol=Solve[eq, {h, a, b, c, d}]

MMA take severyl hours, but finally we get an output that is too lengthy to display here. I only give the answer for h:
h /. sol

{Root[-K1 K2 K3 W + (-2 C K1 K2 K3 - K1 K2 W) #1 + (-C K1 K2 + 
       K1 K2 K3 - K1 W) #1^2 + (K1 K2 - W) #1^3 + (C + 
       K1) #1^4 + #1^5 &, 1], 
 Root[-K1 K2 K3 W + (-2 C K1 K2 K3 - K1 K2 W) #1 + (-C K1 K2 + 
       K1 K2 K3 - K1 W) #1^2 + (K1 K2 - W) #1^3 + (C + 
       K1) #1^4 + #1^5 &, 2], 
 Root[-K1 K2 K3 W + (-2 C K1 K2 K3 - K1 K2 W) #1 + (-C K1 K2 + 
       K1 K2 K3 - K1 W) #1^2 + (K1 K2 - W) #1^3 + (C + 
       K1) #1^4 + #1^5 &, 3], 
 Root[-K1 K2 K3 W + (-2 C K1 K2 K3 - K1 K2 W) #1 + (-C K1 K2 + 
       K1 K2 K3 - K1 W) #1^2 + (K1 K2 - W) #1^3 + (C + 
       K1) #1^4 + #1^5 &, 4], 
 Root[-K1 K2 K3 W + (-2 C K1 K2 K3 - K1 K2 W) #1 + (-C K1 K2 + 
       K1 K2 K3 - K1 W) #1^2 + (K1 K2 - W) #1^3 + (C + 
       K1) #1^4 + #1^5 &, 5]}

Roma Lee · Answer

Try
eqs = {K1 == c*h/d, K2 == b*h/c, K3 == a*h/b, C == a + b + c + d, h + d == W/h + b + 2 a};
Eliminate[eqs,{a,b,c,d}]

to get, e.g., the equation for h.

Algebraic solution from system of symbolic equations for single variable

3 Answers

Add your own answers!

Ask a Question