# Dsolve too slow — is there anyway around?

I am trying to solve:

DSolve[{Cn'[t] == CP[t]*kr - P*Cn[t]*kf,
CP'[t] == Cn[t]*P*kf + 2*CPP[t]*kr - P*CP[t]*kf - CP[t]*kr,
CPP'[t] == CP[t]*P*kf + 3*CPPP[t]*kr - P*CPP[t]*kf - 2*CPP[t]*kr,
CPPP'[t] == CPP[t]*P*kf + 4*CPPPP[t]*kr - P*CPPP[t]*kf - 3*CPPP[t]*kr,
CPPPP'[t] == CPPP[t]*P*kf - 4*CPPPP[t]*kr, CP[0] == 0, CPP[0] == 0,
CPPP[0] == 0, CPPPP[0] == Chp, Cn[0] == Chn},
{Cn[t], CP[t], CPP[t], CPPP[t], CPPPP[t]}, t]


Mathematica 9 did not give a result overnight and ate up all the memory (~6g). However it can solve

DSolve[{Cn'[t] == CP[t]*kr - P*Cn[t]*kf,
CP'[t] == Cn[t]*P*kf + CPP[t]*kr - P*CP[t]*kf - CP[t]*kr,
CPP'[t] == CP[t]*P*kf + CPPP[t]*kr - P*CPP[t]*kf - CPP[t]*kr,
CPPP'[t] == CPP[t]*P*kf + CPPPP[t]*kr - P*CPPP[t]*kf - CPPP[t]*kr,
CPPPP'[t] == CPPP[t]*P*kf - CPPPP[t]*kr, CP[0] == 0, CPP[0] == 0,
CPPP[0] == 0, CPPPP[0] == chp, Cn[0] == chn},
{Cn[t], CP[t], CPP[t], CPPP[t], CPPPP[t]}, t]


in hours. I am not very familiar with Mathematica. I wonder if there is a way to solve this system (the former one).

-
Do you need a closed form solution or a numerical one would do the trick ? –  Sektor Sep 6 '13 at 22:38
Can you specify what kr,kf and P are? If those are constants, i.e. independent of t, the system should be easily solvable in a matter of seconds, because it would be linear. –  Wizard Sep 7 '13 at 0:10
Thanks a lot for the reply! Yes kr, kf and P are constants with respect to t. I added SetAttributes[{kr, kf, P, chn, chp}, Constant] before the DSolve expression. It has been working for several hours now and still no result yet. It is best if I can have an explicit solution to this. If not, is there a way to do numerical fittings with my experimental data to derive kr, kf and P (parameters). –  Weiwei Sep 7 '13 at 4:55
@Weiwei Something like: How to fit...? –  Kuba Sep 7 '13 at 7:59

You can use a property of your system of equations :

eqs = Simplify[{Cn'[t] == CP[t]*kr - P*Cn[t]*kf,
CP'[t] == Cn[t]*P*kf + 2*CPP[t]*kr - P*CP[t]*kf - CP[t]*kr,
CPP'[t] == CP[t]*P*kf + 3*CPPP[t]*kr - P*CPP[t]*kf - 2*CPP[t]*kr,
CPPP'[t] == CPP[t]*P*kf + 4*CPPPP[t]*kr - P*CPPP[t]*kf - 3*CPPP[t]*kr,
CPPPP'[t] == CPPP[t]*P*kf - 4*CPPPP[t]*kr}];


If you sum all the right-hand sides then you get :

FullSimplify[
(CP[t]*kr - P*Cn[t]*kf) +
(Cn[t]*P*kf + 2*CPP[t]*kr - P*CP[t]*kf - CP[t]*kr) +
(CP[t]*P*kf + 3*CPPP[t]*kr - P*CPP[t]*kf - 2*CPP[t]*kr) +
(CPP[t]*P*kf + 4*CPPPP[t]*kr - P*CPPP[t]*kf - 3*CPPP[t]*kr) +
(CPPP[t]*P*kf - 4*CPPPP[t]*kr)]
(* 0 *)


This means that the sum of all your functions Cn[t] + CP[t] + CPP[t] + CPPP[t] + CPPPP[t] is a constant, which equals (for instance) the value at t=0. We can use this information to get rid of Cn[t] :

subs = {Cn[t] -> (Chn + Chp) - (CP[t] + CPP[t] + CPPP[t] + CPPPP[t]),
Cn'[t] -> D[(Chn + Chp) - (CP[t] + CPP[t] + CPPP[t] + CPPPP[t]), t]};

eqs2 = FullSimplify[eqs[[2 ;;]] /. subs];

sol = DSolve[Join[eqs2, {CP[0] == 0, CPP[0] == 0, CPPP[0] == 0, CPPPP[0] == Chp}],
{CP[t], CPP[t], CPPP[t], CPPPP[t]}, t];


This runs quickly, however the result has a lot of RootSum objects.

Checks :

(* CP[0] *)
FullSimplify[sol[[1, 1, 2]] /. t -> 0]
(* 0 *)

(* CPPPP[0] *)
FullSimplify[sol[[1, 4, 2]] /. t -> 0]
(* Chp *)

(* Cn[0] *)
FullSimplify[(Chn + Chp) - Total[sol[[1, All, 2]] /. t -> 0]]
(* Chn *)

-