Getting error Solve::ivar when solving a large system of equations

Question

I'm trying to solve the first part of a Quantal Response Equilibrium (QRE).

I'm the situation of needing analytical solutions to a large system of equations (Logit-type). Solution will be up to a single parameter: I have, say, $n$ variables and $n-1$ equations.

Variables are in the form a[h]a[q], for example a1a3, plus the parameter d.

Each equation of the system of equations to be solved is in the following form:

a1a3 == Exp[d*pay[1, 3]]/Sum[Exp[d*pay[1, s]], {s, 0, qmax[1]}]

where pay[h, q] and qmax[h] are functions that I have previously defined.

My code appears to work up to the last line, where I receive an error message:

Solve::ivar: {a1a0,a1a1,a1a2....} is not a valid variable. >>

Here the code.

qmax[h_] := Floor[8 Sqrt[2] Sqrt[h]]
pay[h_, q_] := 
  (32 - q^2/(4h))*(1/10)*
     Sum[Sum[Symbol["a" <> ToString[t] <> "a" <> ToString[s]], {s, 0, (q-1)}]+ 
     0.5*Symbol["a"<>ToString[t]<>"a" <>ToString[q]], {t, 1, 10}]
equations = 
  Table[
    Table[
       Symbol["a" <> ToString[h] <> "a" <> ToString[q]] == 
         Exp[d*pay[h, q]]/Sum[Exp[d*pay[h, s]], {s, 0, qmax[h]}], 
       {q, 0, qmax[h]}],
    {h, 1, 10}]
vars = 
  Table[Symbol["a" <> ToString[h] <> "a" <> ToString[q]], {h, 1, 10}, {q, 0,qmax[h]}]

Solve[{equations}, vars]

Edit

Setting a value for d and using FindRoot is perfectly fine for me, but I'm still not able to solve the problem.

Answer 1

You appear to have 103 more variables than show up in your vars list.

See if this will help you make any progress

qmax[h_] := Floor[8 Sqrt[2] Sqrt[h]];
varpay[h_, q_] := Table[{
  Table[Symbol["a" <> ToString[t] <> "a" <> ToString[s]], {s, 0, (q - 1)}], 
  Symbol["a" <> ToString[t] <> "a" <> ToString[q]]}, {t, 1, 10}];
vars = Union[Flatten[Table[
  Table[{Symbol["a" <> ToString[h] <> "a" <> ToString[q]], 
    Table[{d, varpay[h, s]}, {s, 0, qmax[h]}], {d, varpay[h, q]}},
    {q, 0, qmax[h]}], {h, 1, 10}]]];
pay[h_, q_] := (32 - q^2/(4 h))*(1/10)*
  Sum[Sum[Symbol["a" <> ToString[t] <> "a" <> ToString[s]], {s, 0, (q - 1)}] + 
  0.5*Symbol["a" <> ToString[t] <> "a" <> ToString[q]], {t, 1, 10}];
equations = Total[Flatten[Table[Table[
  Norm[Symbol["a" <> ToString[h] <> "a" <> ToString[q]]*
    Sum[Exp[d*pay[h, s]], {s, 0, qmax[h]}] - 
    Exp[d*pay[h, q]]], {q, 0, qmax[h]}], {h, 1, 10}]]];
NMinimize[equations, vars]

I used a modified version of your equations to generate the vars list.

I multiplied both sides of your equations by your denominator and you should verify that does not give you an incorrect result.

I used Norm[lhs-rhs] and added all the equations together so that NMinimize could look for a solution.

Answer 2

I solved my problem. There were three problems with my code: 1) What I was asking was too challenging for Solve; I used FindRoot and a numeric value for "d". 2) Add Flatten 3) There was an error in the way the function "pay" was defined. As a result, the function created additional (and non-defined) variables.

The code works, but it requires 11 minutes to run. I will ask, in a separate question, if there is a way to make my code more efficient. Reasons because more efficiency is required: 1) The code need to run for 100 (at least) values of the parameter "d" 2) I have a different "pay" function which will generate much more equations to be solved (around 10.000).

Marco, thank you very much. Flatten was the key!

Bill, I do not entirely understand your solution strategy. Maybe it's more efficient?

Here the code. I also changed some notation.

 ClearAll["Global`*"];
qmax[h_] := Floor[8 Sqrt[2] Sqrt[h]];
qmax2[h_, q_] := Min[qmax[h], (q - 1)];
pay[h_, q_] := (32 - q^2/(4 h))*(1/10)*Sum[
Sum[
  Symbol["t" <> ToString[t] <> "q" <> ToString[s]], {s, 0, 
   qmax2[t, q]}] + 
  If[q <= qmax[t], 
  0.5*Symbol["t" <> ToString[t] <> "q" <> ToString[q]], 0], {t, 1,
  10}];
equations = Flatten@Table[
   Table[
   Symbol[
   "t" <> ToString[h] <> "q" <> ToString[q]] == 
  Exp[d*pay[h, q]]/Sum[Exp[d*pay[h, s]], {s, 0, qmax[h]}],
  {q, 0, qmax[h]}],
  {h, 1, 10}];
vars = Flatten[
 Table[{Symbol["t" <> ToString[h] <> "q" <> ToString[q]], 0.01}, {h,
  1, 10}, {q, 0, qmax[h]}], 1];
d = 1;
FindRoot[equations, vars]

And here the link for the follow-up question: FindRoot, large system of equations. Improving Efficiency, loop around many parameter and exporting results