Message Boards Message Boards

Speed up FindRoot for system of equations

Hello, I'm solving a system of m by m equations in two variants. When m=7, the second system takes me approximately 15 seconds. Since I want to solve a more complex system for much larger m, I'm looking for any help on speeding up the solution. Thanks!

In[34]:= Clear[PPi, pi, m, n, TT, T, TT0, T0, NN, n0, N0, A, R, e];
m = 7;
v[i_, j_] := A[j] Sum[n[k, j], {k, m}]/Sum[n[i, l], {l, m}]
PPi = Table[pi[i, j], {i, m}, {j, m}];
pi[i_, j_] := T[i, j] v[i, j]^(e)/Sum[T[k, l] v[k, l]^e, {k, m}, {l, m}];

In[39]:= btab = Table[RandomReal[{1, 1.2}], {j, m}];
A[j_] := btab[[j]]
R = Table[RandomReal[], {i, m}, {j, m}];
n0[i_, j_] := R[[i, j]]/Total[Flatten[R]]

In[43]:= Clear[T, TT, TTm, n, NN, NNm];
N0 = Table[n0[i, j], {i, m}, {j, m}];
TT0 = Table[1, {i, m}, {j, m}];
T0[i_, j_] := TT0[[i, j]]
TT = Table[T[i, j], {i, m}, {j, m}];
NN = Table[n[i, j], {i, m}, {j, m}];
NNm = Drop[Flatten[NN], -1];
NNm0 = Drop[Flatten[N0], -1];
TTm = Drop[Flatten[TT], -1];
TTm0 = Drop[Flatten[TT0], -1];

In[53]:= newmat = Drop[Flatten[PPi - NN], -1];

In[54]:= (* baseline: solve for T given n for given e*)
Clear[T, n];
e = 5;
n[i_, j_] := N0[[i, j]]
T[m, m] = 1;
soln1 = FindRoot[{newmat},Transpose[{Flatten[{TTm}], Flatten[{TTm0}]}]] // AbsoluteTiming;
%[[1]]

Out[59]= 0.500039

In[60]:= TT = TT /. soln1[[2]];
T[i_, j_] := TT[[i, j]]

In[62]:= (* new eq : solve for n given T with new e value *)
e = 3;
Clear[NN, n];
n [m, m] = 1 - Total[NNm];
soln2 = FindRoot[{newmat},Transpose[{Flatten[{NNm}], Flatten[{NNm0}]}]] // AbsoluteTiming;
%[[1]]

Out[66]= 14.5182
POSTED BY: Rainald Borck
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract