Skip to main content
added 56 characters in body
Source Link
xzczd
  • 68.4k
  • 9
  • 174
  • 489

{ab, w, err} = NIntegrate`LobattoRuleData[num, 4]

(* {{0, 0.5000, 1.000}, {0.1667, 0.667, 0.1667}, {}} *)

{ab, w, err} = NIntegrate`LobattoRuleData[num, 4]

(* {{0, 0.5000, 1.000}, {0.1667, 0.667, 0.1667}, {}} *)

sys = Table[ (f[x] - x)* Sum[(Exp[2 - 2 f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]])^2 - Exp[1 - f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]]))* w[[Position[ab, y][[1, 1]]]], {y, ab}] + Sum[Exp[1 - f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]])* w[[Position[ab, y][[1, 1]]]], {y, ab}], {x, ab}];

sys = Table[
   (f[x] - x)*
     Sum[(Exp[2 - 2 f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]])^2 - 
         Exp[1 - f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]]))*
       w[[Position[ab, y][[1, 1]]]], {y, ab}]
    +
    Sum[Exp[1 - f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]])*
      w[[Position[ab, y][[1, 1]]]], {y, ab}], {x, ab}];

Now, create list of unknowns with some starting values:

vars = Table[{f[x], 2 + 1/2 x}, {x, ab}]

(* {{f[0], 2}, {f[0.5000], 2.2500}, {f[1.000], 2.5000}} *)

vars = Table[{f[x], 2 + 1/2 x}, {x, ab}]

(* {{f[0], 2}, {f[0.5000], 2.2500}, {f[1.000], 2.5000}} *)

FindRoot[sys, vars]

(* {f[0] -> 2.28088, f[0.5000] -> 2.51548, f[1.000] -> 2.78091} *).

FindRoot[sys, vars]

(* {f[0] -> 2.28088, f[0.5000] -> 2.51548, f[1.000] -> 2.78091} *)

f[x] = 2.28093 + 0.440941 x + 0.0538753 x^2 + 0.00521441 x^3 + 0.000168599 x^4.

f[x] = 2.28093 + 0.440941 x + 0.0538753 x^2 + 0.00521441 x^3 + 
 0.000168599 x^4

{ab, w, err} = NIntegrate`LobattoRuleData[num, 4]

(* {{0, 0.5000, 1.000}, {0.1667, 0.667, 0.1667}, {}} *)

sys = Table[ (f[x] - x)* Sum[(Exp[2 - 2 f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]])^2 - Exp[1 - f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]]))* w[[Position[ab, y][[1, 1]]]], {y, ab}] + Sum[Exp[1 - f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]])* w[[Position[ab, y][[1, 1]]]], {y, ab}], {x, ab}];

Now, create list of unknowns with some starting values:

vars = Table[{f[x], 2 + 1/2 x}, {x, ab}]

(* {{f[0], 2}, {f[0.5000], 2.2500}, {f[1.000], 2.5000}} *)

FindRoot[sys, vars]

(* {f[0] -> 2.28088, f[0.5000] -> 2.51548, f[1.000] -> 2.78091} *).

f[x] = 2.28093 + 0.440941 x + 0.0538753 x^2 + 0.00521441 x^3 + 0.000168599 x^4.

{ab, w, err} = NIntegrate`LobattoRuleData[num, 4]

(* {{0, 0.5000, 1.000}, {0.1667, 0.667, 0.1667}, {}} *)
sys = Table[
   (f[x] - x)*
     Sum[(Exp[2 - 2 f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]])^2 - 
         Exp[1 - f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]]))*
       w[[Position[ab, y][[1, 1]]]], {y, ab}]
    +
    Sum[Exp[1 - f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]])*
      w[[Position[ab, y][[1, 1]]]], {y, ab}], {x, ab}];

Now, create list of unknowns with some starting values:

vars = Table[{f[x], 2 + 1/2 x}, {x, ab}]

(* {{f[0], 2}, {f[0.5000], 2.2500}, {f[1.000], 2.5000}} *)
FindRoot[sys, vars]

(* {f[0] -> 2.28088, f[0.5000] -> 2.51548, f[1.000] -> 2.78091} *)
f[x] = 2.28093 + 0.440941 x + 0.0538753 x^2 + 0.00521441 x^3 + 
 0.000168599 x^4
added 1 character in body
Source Link
Mariusz Iwaniuk
  • 16.4k
  • 1
  • 27
  • 46

With some effort you can find numerical solution. Let us discretize function f at num points, e.g. num=3. Then, select some integration rule, e.g. Lobatto one:

{ab, w, err} = NIntegrate``LobattoRuleData[numNIntegrate`LobattoRuleData[num, 4]

(* {{0, 0.5000, 1.000}, {0.1667, 0.667, 0.1667}, {}} *)

Next, replace Integrate with Sum at points ab with weights w and create Table of num equations evaluating at x given by ab:

sys = Table[ (f[x] - x)* Sum[(Exp[2 - 2 f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]])^2 - Exp[1 - f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]]))* w[[Position[ab, y][[1, 1]]]], {y, ab}] + Sum[Exp[1 - f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]])* w[[Position[ab, y][[1, 1]]]], {y, ab}], {x, ab}];

Now, create list of unknowns with some starting values:

vars = Table[{f[x], 2 + 1/2 x}, {x, ab}]

(* {{f[0], 2}, {f[0.5000], 2.2500}, {f[1.000], 2.5000}} *)

and use FindRoot to solve system sys:

FindRoot[sys, vars]

(* {f[0] -> 2.28088, f[0.5000] -> 2.51548, f[1.000] -> 2.78091} *).

To get more acurate solution you have to increase num and precision of Lobatto rule abscissas and weights. Using num=64 and 32-digit precision I was able to solve original equation down to $MachineEpsilon. Result appear to be roughly linear with rapidly converging polynomial series, starting with:

f[x] = 2.28093 + 0.440941 x + 0.0538753 x^2 + 0.00521441 x^3 + 0.000168599 x^4.

With some effort you can find numerical solution. Let us discretize function f at num points, e.g. num=3. Then, select some integration rule, e.g. Lobatto one:

{ab, w, err} = NIntegrate``LobattoRuleData[num, 4]

(* {{0, 0.5000, 1.000}, {0.1667, 0.667, 0.1667}, {}} *)

Next, replace Integrate with Sum at points ab with weights w and create Table of num equations evaluating at x given by ab:

sys = Table[ (f[x] - x)* Sum[(Exp[2 - 2 f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]])^2 - Exp[1 - f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]]))* w[[Position[ab, y][[1, 1]]]], {y, ab}] + Sum[Exp[1 - f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]])* w[[Position[ab, y][[1, 1]]]], {y, ab}], {x, ab}];

Now, create list of unknowns with some starting values:

vars = Table[{f[x], 2 + 1/2 x}, {x, ab}]

(* {{f[0], 2}, {f[0.5000], 2.2500}, {f[1.000], 2.5000}} *)

and use FindRoot to solve system sys:

FindRoot[sys, vars]

(* {f[0] -> 2.28088, f[0.5000] -> 2.51548, f[1.000] -> 2.78091} *).

To get more acurate solution you have to increase num and precision of Lobatto rule abscissas and weights. Using num=64 and 32-digit precision I was able to solve original equation down to $MachineEpsilon. Result appear to be roughly linear with rapidly converging polynomial series, starting with:

f[x] = 2.28093 + 0.440941 x + 0.0538753 x^2 + 0.00521441 x^3 + 0.000168599 x^4.

With some effort you can find numerical solution. Let us discretize function f at num points, e.g. num=3. Then, select some integration rule, e.g. Lobatto one:

{ab, w, err} = NIntegrate`LobattoRuleData[num, 4]

(* {{0, 0.5000, 1.000}, {0.1667, 0.667, 0.1667}, {}} *)

Next, replace Integrate with Sum at points ab with weights w and create Table of num equations evaluating at x given by ab:

sys = Table[ (f[x] - x)* Sum[(Exp[2 - 2 f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]])^2 - Exp[1 - f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]]))* w[[Position[ab, y][[1, 1]]]], {y, ab}] + Sum[Exp[1 - f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]])* w[[Position[ab, y][[1, 1]]]], {y, ab}], {x, ab}];

Now, create list of unknowns with some starting values:

vars = Table[{f[x], 2 + 1/2 x}, {x, ab}]

(* {{f[0], 2}, {f[0.5000], 2.2500}, {f[1.000], 2.5000}} *)

and use FindRoot to solve system sys:

FindRoot[sys, vars]

(* {f[0] -> 2.28088, f[0.5000] -> 2.51548, f[1.000] -> 2.78091} *).

To get more acurate solution you have to increase num and precision of Lobatto rule abscissas and weights. Using num=64 and 32-digit precision I was able to solve original equation down to $MachineEpsilon. Result appear to be roughly linear with rapidly converging polynomial series, starting with:

f[x] = 2.28093 + 0.440941 x + 0.0538753 x^2 + 0.00521441 x^3 + 0.000168599 x^4.

Source Link

With some effort you can find numerical solution. Let us discretize function f at num points, e.g. num=3. Then, select some integration rule, e.g. Lobatto one:

{ab, w, err} = NIntegrate``LobattoRuleData[num, 4]

(* {{0, 0.5000, 1.000}, {0.1667, 0.667, 0.1667}, {}} *)

Next, replace Integrate with Sum at points ab with weights w and create Table of num equations evaluating at x given by ab:

sys = Table[ (f[x] - x)* Sum[(Exp[2 - 2 f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]])^2 - Exp[1 - f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]]))* w[[Position[ab, y][[1, 1]]]], {y, ab}] + Sum[Exp[1 - f[x]]/(Exp[1 - f[x]] + Exp[1 - f[y]])* w[[Position[ab, y][[1, 1]]]], {y, ab}], {x, ab}];

Now, create list of unknowns with some starting values:

vars = Table[{f[x], 2 + 1/2 x}, {x, ab}]

(* {{f[0], 2}, {f[0.5000], 2.2500}, {f[1.000], 2.5000}} *)

and use FindRoot to solve system sys:

FindRoot[sys, vars]

(* {f[0] -> 2.28088, f[0.5000] -> 2.51548, f[1.000] -> 2.78091} *).

To get more acurate solution you have to increase num and precision of Lobatto rule abscissas and weights. Using num=64 and 32-digit precision I was able to solve original equation down to $MachineEpsilon. Result appear to be roughly linear with rapidly converging polynomial series, starting with:

f[x] = 2.28093 + 0.440941 x + 0.0538753 x^2 + 0.00521441 x^3 + 0.000168599 x^4.