Tell me please , is in Mathematica a standard function which can find a width of interval?
I have to find it for each iteration.
(*Newton's method*)
step[f_, iter_, inter_] :=
Module[{x = Mean#First#(List ## inter)//N},
Print["Iteration ", iter, ".\n", "Interval is: ", inter,
"; \nx0_=", x, "; \nf(x0_)=", f[x], "; \nf'(interval)=", f'[inter],
";","\nIntervalsWidth=",(*??????????*),"\nX1=",IntervalIntersection[inter, x - (f[x])/(f'[inter])]]; IntervalIntersection[inter, x - (f[x])/(f'[inter])]]
newton[f_, inter0_, eps_] :=
Module[{iter = 0},
N#Mean#First#(List ##
NestWhile[(++iter; step[f, iter, #]) &, inter0,
Abs[Subtract ## First#(List ## #)] > eps &])];
f[x_] := x*x - 8*x + 7 ;
inter := Interval[{5, 17}] ;
newton[f, inter, 0.00001];
//////tried to do
(*Newton's method*)
step[f_, iter_, {a_, b_}] :=
Module[{inter = Interval[{a, b}],x =(a+b)/2},
Print["Iteration ", iter, ".\n", "Interval is: ", inter,";\nIntervalsWidth=",b-a,
"; \nx0_=", x, "; \nf(x0_)=", f[x], "; \nf'(interval)=", f'[inter],
";","\nX1=",IntervalIntersection[inter, x - (f[x])/(f'[inter])]]; IntervalIntersection[inter, x - (f[x])/(f'[inter])]]
newton[f_, {a_, b_}, eps_] :=
Module[{iter = 0},
N#Mean#First#(List ##
NestWhile[(++iter; step[f, iter, #]) &, {a,b},
Abs[b-a] > eps &])];
f[x_] := x*x - 8*x + 7 ;
newton[f, {5, 17}, 0.00001];
Related
I am trying to get the roots of the function with the modified newton raphson method, but on the second iteration the value for xi+1 blows up to -393, isnt't it supposed to get closer to the expected value of the root? (which is 0.34997). Also I am trying to get the root with an "error" below the "eS" criteria. Pls help
n = 50;
eS = 10^-4;
f[x_] := (x^2 - 10 x + 25) (x - Exp[-3 x])
Plot[f[x], {x, -1, 2}]
xi = 0.5;
Do[
f[xi]; f'[xi]; f''[xi];
xi1 = xi - (f[xi]*f'[xi]/(f'[xi])^2 - f[xi]*f''[xi]);
If[Abs[f[xi]] < 10^-7,
Print["The root is approx= ", xi1 // N, " iterations needed: ", i];
Break[]];
eA = Abs[(xi1 - xi)/xi1];
If[eA < eS,
Print["The root is approx= ", xi1 // N, " iterations needed: ", i];
Break[]];
xi = xi1;
If[i == n, Print["Did not converge in ", n, " iteration(s)"]];
, {i, 1, n}
]
There are many different "Modified Newton Raphson" methods. The one I am familiar with is
u[x_] := f[x]/f'[x]
Do[
xi1 = xi - u[xi]/u'[xi];
If[Abs[f[xi]] < 10^-7,
Print["The root is approx= ", xi1 // N, " iterations needed: ", i];
Break[]];
eA = Abs[(xi1 - xi)/xi1];
If[eA < eS,
Print["The root is approx= ", xi1 // N, " iterations needed: ", i];
Break[]];
xi = xi1;
If[i == n, Print["Did not converge in ", n, " iteration(s)"]];, {i, 1, n}]
Here is a more functional way (no Do loop)
FixedPointList[# - u[#]/u'[#] &, .5]
(* {0.5, 0.372215, 0.350544, 0.34997, 0.34997, 0.34997, 0.34997} *)
I am solving a project in Mathematica 10 and I think that the best way to do it is using a loop like For or Do. After build it I obtain the results I looking for but with a to much big multiplicity. Here is the isolated part of the code:
(*Initializing variables*)
epot[0] = 1; p[0] = 1; \[Psi][0] = HermiteH[0, x] E^(-(x^2/2));
e[n_] := e[n] = epot[n];
(*Defining function*)
\[Psi][n_] := \[Psi][n] = (Sum[p[k]*x^k,{k,0,4*n}]) [Psi][0];
(*Differential equation*)
S = - D[D[\[Psi][n], x], x] + x^2 \[Psi][n] + x^4 \[Psi][n - 1] - Sum[e[n-k]*\[Psi][k],{k,0,n}];
(*Construction of the loop*)
S1 = Collect[E^(x^2/2) S, x, Simplify];
c = Coefficient[S1, x, 0];
sol = Solve[c == 0, epot[n]]; e[n] = epot[n] /. sol;
For[j = 1, j <= 4 n, j++,
c = Coefficient[S1, x, j];
sol = Solve[c == 0, p[j]];
p[j] = p[j] /. sol;];
(*Results*)
Print[Subscript[e, n], "= ", e[n] // InputForm];
Subscript[e, 1]= {{{3/4}}}
Print[ArrayDepth[e[n]]];
3 (*Multiplicity, it should be 1*)
Print[Subscript[\[Psi], n], "= ", \[Psi][n]];
Subscript[\[Psi], 1]= {{E^(-(x^2/2)) (1-(3 x^2)/8-x^4/8)}}
Print[ArrayDepth[\[Psi][n]]];
2 (*Multiplicity, it should be 1*)
After this calculation, the question remaining is how do i substitute this results in the original functions. Thank you very much.
I have to write the procedure with iterations of the first step Newton's method in Moore's form in Mathematica8, exactly on this example:
GIVEN:
f[x_]:=x*x-8*x+7; inter={5, 9}; eps = 10^(-6);
TO CALCULATE:
x0 := Mean[{5, 9}];
f[x0] ;
f'[x_] ;
f'[inter];
n0 = x0 - f[x0]/f'[inter];
x1 = IntervalIntersection[inter,n0];
I tried to do it, but it doesn't calculate iterations correctly :
f[x_]:=x*x-8*x+7
inter := Interval[{5, 9}]
x0 := Mean[{5, 9}]
newton[f_,x0,eps_]:=Module[{old,new,iter,step},
old ;
step[old] := IntervalIntersection[inter, x0 - (f[x0])/(f'[inter])];
new = step[old];
iter=0;
While[Abs[old-new]>eps,
old = new;
new = step[old];
iter++];
Print["Iterations = ", iter];
Print["X1 = ", new];
]
newton[f,x0,0.00001]
HELP PLEASE !!!
I fixed this up sticking with your basic loop structure as much as possible.
step[f_, inter_] := Module[{x = Mean#First#(List ## inter)},
IntervalIntersection[inter, x - (f[x])/(f'[inter])]]
newton[f_, inter0_, eps_] := Module[{iter,inter},
inter = inter0;
iter = 0;
While[Abs[Subtract ## First#(List ## inter)] > eps,
inter = step[f, inter];
iter++;
Print["loop count",iter,inter,
x = N#Mean#First#(List ## inter),f[x],f'[inter]]];
Print["Iterations = ", iter];
Print["X1 = ", N#Mean#First#(List ## inter)];]
f[x_] = x^2 - 8 x + 7 ;
inter = Interval[{5, 10}] ;
newton[f, inter, 0.00001];
result 7. in 4 iterations
of course in mathematical there are usually cleaner approaches than a do loop:
newton[f_, inter0_, eps_] := Module[{iter = 0},
Print["X1 = ", N#Mean#First#(List ##
NestWhile[(++iter; step[f, #]) &, inter0,
Abs[Subtract ## First#(List ## #)] > eps & ])];
Print["iter=", iter]]
Note this only works properly if the sign of the derivative does not change in the initial Interval. Otherwise you end up with multiple intervals. I'm not that familiar with interval arithmetic to readily see how to deal with that.
I have implemented a code in Mathematica 9 to simulate a scattering problem, and I got really disappointed about its performance when compared to Matlab. Since I am a newbie in Mathematica, would someone give me clues here?
ClearAll["Global`*"];
integrand[k_, P0_, P1_, rho_, l_] = Module[{x, h},
x = P1*l + P0*(1. - l) - rho;
h = HankelH2[0, Norm[x, 2]*k];
h
];
innerInt[k_, P0_, P1_, rho_] := Module[{d, r, v, x},
d = Norm[P0 - P1, 2];(* distancia entre os pontos *)
v = integrand[k, P0, P1, rho, x];
r = NIntegrate[v, {x, 0, 1}]*d;
r
];
solveSystemCylinder[segsStart_, segsEnd_, Ei_, k_, eta_] :=
Module[{colocPts, r, x, t, eiVals},
colocPts = (segsStart + segsEnd)/2;
t[x_] := MapThread[innerInt[k, #1, #2, x] &, {segsStart, segsEnd}];
r = Map[t, colocPts];
eiVals = Map[Ei[#, k] &, colocPts];
N[LinearSolve[r, eiVals]]
];
Ei[p_, k_] := Exp[I*k*First[p]];
k := 2*Pi/Lambda;
Lambda := 1;
raio := Lambda;
eta := 1;
ND := 30;(* num de divisões *)
pts := N[raio*{Cos[#], Sin[#]} & /# (Range[0, ND]*(2*Pi/ND))];
pts2 := ({0, 2*Lambda} + #) & /# pts;
allPts := Join[pts, pts2];
startPts := Take[pts, Length[pts] - 1];
endPts := Take[pts, -(Length[pts] - 1)];
startPts2 := Take[pts2, Length[pts2] - 1];
endPts2 := Take[pts2, -(Length[pts2] - 1)];
(*resolve*)
Js = solveSystemCylinder[Join[startPts, startPts2],
Join[endPts, endPts2], Ei, k, eta];
I'm trying to calculate the fourier transform of a gaussian beam. Later I want to ad some modifications to the following example code. With the required stepsize of 1e-6 the calculation with 8 kernel takes 1244s on my workstation. The most consuming part is obviously the generation of uaperture. Has anyone ideas to improve the performance? Why does mathematica not create a packed list from my expression, when I'm having both real and complex values in it?
uin[gx_, gy_, z_] := Module[{w0 = L1[[1]], z0 = L1[[3]], w, R, \[Zeta], k},
w = w0 Sqrt[1 + (z/z0)^2];
R = z (1 + (z0/z)^2);
\[Zeta] = ArcTan[z/z0];
k = 2*Pi/193*^-9;
Developer`ToPackedArray[
ParallelTable[
w0/w Exp[-(x^2 + y^2)/w^2] Exp[-I k/2/R (x^2 + y^2)/2] Exp[-I k z*0 +
I \[Zeta]*0], {x, gx}, {y, gy}]
]
]
AbsoluteTiming[
dx = 1*^-6;
gx = Range[-8*^-3, 8*^-3, dx];
gy = gx;
d = 15*^-3;
uaperture = uin[gx, gy, d];
ufft = dx*dx* Fourier[uaperture];
uout = RotateRight[
Abs[ufft]*dx^2, {Floor[Length[gx]/2], Floor[Length[gx]/2]}];
]
Thanks in advance,
Johannes
You can speed it up by first vectorizing it (uin2), then compiling it (uin3):
In[1]:= L1 = {0.1, 0.2, 0.3};
In[2]:= uin[gx_, gy_, z_] :=
Module[{w0 = L1[[1]], z0 = L1[[3]], w, R, \[Zeta], k},
w = w0 Sqrt[1 + (z/z0)^2];
R = z (1 + (z0/z)^2);
\[Zeta] = ArcTan[z/z0];
k = 2*Pi/193*^-9;
ParallelTable[
w0/w Exp[-(x^2 + y^2)/
w^2] Exp[-I k/2/R (x^2 + y^2)/2] Exp[-I k z*0 +
I \[Zeta]*0], {x, gx}, {y, gy}]
]
In[3]:= uin2[gx_, gy_, z_] :=
Module[{w0 = L1[[1]], z0 = L1[[3]], w, R, \[Zeta], k, x, y},
w = w0 Sqrt[1 + (z/z0)^2];
R = z (1 + (z0/z)^2);
\[Zeta] = ArcTan[z/z0];
k = 2*Pi/193*^-9;
{x, y} = Transpose[Outer[List, gx, gy], {3, 2, 1}];
w0/w Exp[-(x^2 + y^2)/
w^2] Exp[-I k/2/R (x^2 + y^2)/2] Exp[-I k z*0 + I \[Zeta]*0]
]
In[4]:= uin3 =
Compile[{{gx, _Real, 1}, {gy, _Real, 1}, z},
Module[{w0 = L1[[1]], z0 = L1[[3]], w, R, \[Zeta], k, x, y},
w = w0 Sqrt[1 + (z/z0)^2];
R = z (1 + (z0/z)^2);
\[Zeta] = ArcTan[z/z0];
k = 2*Pi/193*^-9;
{x, y} = Transpose[Outer[List, gx, gy], {3, 2, 1}];
w0/w Exp[-(x^2 + y^2)/
w^2] Exp[-I k/2/R (x^2 + y^2)/2] Exp[-I k z*0 + I \[Zeta]*0]
],
CompilationOptions -> {"InlineExternalDefinitions" -> True}
];
In[5]:= dx = 1*^-5;
gx = Range[-8*^-3, 8*^-3, dx];
gy = gx;
d = 15*^-3;
In[9]:= r1 = uin[gx, gy, d]; // AbsoluteTiming
Out[9]= {67.9448862, Null}
In[10]:= r2 = uin2[gx, gy, d]; // AbsoluteTiming
Out[10]= {28.3326206, Null}
In[11]:= r3 = uin3[gx, gy, d]; // AbsoluteTiming
Out[11]= {0.4190239, Null}
We got a ~160x speedup even though this is not running in parallel.
Results are the same:
In[12]:= r1 == r2
Out[12]= True
There's a tiny difference here due to numerical errors:
In[13]:= r2 == r3
Out[13]= False
In[14]:= Max#Abs[r2 - r3]
Out[14]= 5.63627*10^-14