Algebraic solution from system of symbolic equations for single variable
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}]
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]}
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
.