How can I construct this matrix in Mathematica?

Question

I would be very grateful if you could help me to construct this matrix in Mathematica.

This is the code I have so far:

m = 10;
a = 0;
b = 1;
h = (b - a)/(m);

x[1] = 0;
x[m] = 1;

For[
  n = 2, n <= m, n++, 
  x[n] = x[1] + n h;
]

xvalues = Table[x[i], {i, 1, m}]; 
subs = Subsets[xvalues, {Length@xvalues - 1}]; 
complements = Flatten[Complement[xvalues, #] & /@ subs]; 

d = Table[ Times @@ (1/(subs[[i]] - complements[[i]])), {i, 1, Length@subs}]; 
For[
  n = 1, n <= m, n++,
  w[n] = d[[n]];
]

aa = Table[Delete[Table[w[i]/w[n]/(x[n] - x[i]), {n, 1, m}], i], {i, 1, m}] 

Answer 1

I'd write it like this. I use the trick that if I have the product over all values except $k$, I just replace the $k$th term with $1$; if I have the sum over all values except $k$, I just replace the $k$th term with $0$.

I left x as is, but check out Range and Subdivide; you might find something like Clear[x]; Evaluate@Array[x, {m}] = Subdivide[a, b, m - 1] useful, which sets all x's at once.

Note: I assume there was a typo in the definition of w, and that it should have been $\prod_{k\neq j}$. If not, the code might need modification.

I also can't help but wonder: is there a typo in $L''$? The sum over $k$ includes a (relatively) constant term, $\frac{1}{x_i-x_j}$, which does not depend on $k$ and thus can come out of the sum with a factor of $n-1$ attached (m in the code). In any case, I translated the expressions "verbatim", matching the code to the expression as closely as possible, with the exception of using Total or Times and Array instead of Sum or Product for some speed.

I also use a trick for memoization, to remember explicit values: f[x_] := (f[x] = ...) will e.g. calculate f[1] only when it is first called, but then remember that explicit calculated value for later. See here.

m = 10;
a = 0;
b = 1;
h = (b - a)/(m);

x[1] = 0;
Do[x[i] = x[1] + i h, {i, 2, m}];

Do[w[j] = 1/(Times @@ Array[If[j == #, 1, x[j] - x[#]] &, {m}]), {j, 
  1, m}]

Lpp[j_][i_] := (Lpp[j][i] = If[j == i,
    -Total @ Array[If[i == #, 0, Lpp[#][i]] &, {m}],
    -2 (w[j]/w[i])/(x[i] - x[j])
     (Total @ Array[
         If[i == #, 
          0, (w[#]/w[i])/(x[i] - x[#]) + 1/(x[i] - x[j])] &, {m}])
    ])

D2 = Array[Lpp[#2][#1] &, {m, m}]

Hope this helps! Let me know if there's any unfamiliar syntax.