I've been trying to fit a function to a data set. IT works with functions without integrals (like NIntegrate) and differentiations ( ' ). I'm trying to get it to work using both integrals and differentiations:
deltaData = {{1.00, 0}, {0.96, 0.3416}, {0.92, 0.4749}, {0.88, 0.5715}, {0.84, 0.648}, {0.80, 0.711}, {0.76, 0.764}, {0.72, 0.8089}, {0.66, 0.864}, {0.62, 0.8939}, {0.58, 0.919}, {0.54, 0.9399}, {0.50, 0.9569}, {0.46, 0.9704}, {0.42, 0.9809}, {0.38, 0.9885}, {0.34, 0.9938}, {0.30, 0.9971}, {0.26, 0.9989}, {0.22, 0.9997}, {0.16, 1}, {0.14, 1}};
deltaFit =
NonlinearModelFit[
deltaData, (1 + a*T + c*T^2 + e*T^3 + g*T^4 + i*T^5 + k*T^6)/(1 +
b*T + d*T^2 + f*T^3 + h*T^4 + j*T^5 + l*T^6), {a, b, c, d, e, f,
g, h, i, j, k, l}, T];
Plot[deltaFit[T], {T, 0, 1}]
data = {{0.203, 0.031}, {0.203, 0.030}, {0.246, 0.055}, {0.267, 0.072}, {0.300, 0.105}, {0.300, 0.105}, {0.330, 0.147}, {0.373, 0.214}, {0.397, 0.255}, {0.415, 0.293}, {0.445, 0.351}, {0.477, 0.430}, {0.493, 0.463}, {0.520, 0.538}, {0.541, 0.590}, {0.582, 0.717}, {0.589, 0.733}, {0.625, 0.847}, {0.645, 0.911}, {0.685, 1.029}, {0.688, 1.043}, {0.730, 1.181}, {0.751, 1.247}, {0.782, 1.338}, {0.793, 1.375}, {0.830, 1.472}, {0.856, 1.531}, {0.878, 1.585}};
AlphaBCS = 1.746;
delta[T_, p_, alpha_] := p*deltaFit[T] + (1 - p)*deltaFit[T]/alpha;
fx[T_, x_, p_, alpha_] := (Exp[AlphaBCS/T*(x^2 + delta[T, p, alpha]^2)^(1/2)] + 1)^(-1);
Ses[T_, p_, alpha_] := -6*AlphaBCS/Pi^2* NIntegrate[fx[T, x, p, alpha]*Log[fx[T, x, p, alpha]] + (1 - fx[T, x, p, alpha])*Log[1 - fx[T, x, p, alpha]], {x, 0,100}];
Ces[T_, p_, alpha_] := T*Ses'[T, p, alpha];
cesFit = NonlinearModelFit[data, Ces[T, p, alpha], {{p, 0.5}, {alpha, 1.764}}, T];
I don't know why I'm getting an Error as the code is working in the first fit I'm performing. This is the error message:
The function value ... a bunch of numbers ... Ses' ... more numbers ... is not a list of real numbers with dimensions {28} at {p,alpha} = {0.5`,1.764`}.
Does anybody know what I'm doing wrong? Is there anything I can replace the fit or integral with to make this work?
#Bill: Thank you for pointing that out! Here is my corrected code:
dSes[T_, p_, alpha_] = D[Ses[T, p, alpha], T];
Ces[T_, p_, alpha_] := T*dSes[T, p, alpha];
now the differentiation works. But when I run the fit, I get the following error:
a long list of numbers, brackets, Compile'$... is not a list of real numbers with dimensions {28} at {p,alpha} = {0.5,1.764}.
Related
I am working on finding the initial points of convergence using newton's iteration method in mathematica. newton function works now I would like to show which initial points from a grid produce Newton iterations that converge to -1, same for points that converge to (1 + (3)^1/2)/2i, given that:
f(x) = x^3+1
newton[x0_] := (
x = x0;
a1 = {};
b1 = {};
c1 = {};
counter = 0;
error = Abs[f[x]];
While[counter < 20 && error > 0.0001,
If[f'[x] != 0, x = x - N[f[x]/f'[x]]];
counter = counter + 1;
error = Abs[f[x]]];
x)
I created a grid to show which initial points of a+bi converge to the roots.
grid = Table[a + b I, {a, -2, 2, 0.01}, {b, -2, 2, 0.01}];
Then I created a fractal, but whenever I plot it gives me a blank graph on the axis.
There's got to be a way for me to be able to identify the converge points from the grid but so far I have not been successful. I tried using the Which[] method but when comparing the value its returns false.
Any help will appreciate it
Your code is not optimal, to put it mildly, but to give you a head start, why don't you start with something like this:
f[x_] := x^3 + 1;
newton[x0_] := (x = x0;
a1 = {};
b1 = {};
c1 = {};
counter = 0;
error = Abs[f[x]];
While[counter < 20 && error > 0.0001,
If[f'[x] != 0, x = x - N[f[x]/f'[x]]];
counter = counter + 1;
error = Abs[f[x]]];
{x, counter})
Table[Re#newton[a + b I], {a, -2, 2, 0.01}, {b, -2, 2, 0.01}] // Image
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 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];
Clear[x, y, h, k, FirstSlope, SecondSlope];
h = [Pi]; y[[Pi]] = 0;
dy[x_, y_] = (Cos[x] - 3 x^2 y)/x^3;
Do[{x[k] = [Pi] + h*(k - [Pi]),
FirstSlope = dy[x[k], y[k]],
SecondSlope = dy[x[k] + h, y[k] + h*FirstSlope],
y[k + [Pi]] = y[k] + (h*(FirstSlope + SecondSlope))/2}, {k, [Pi],
5[Pi]}] Table[{x[k], y[k]}, {k, [Pi], 5[Pi]}];
MatrixForm[%]
Above image is my error. I'm trying to use Heun's method and my problem is:
1) I want it to stop at y[5 Pi] but it keeps going. I can manipulate it so that it goes to y[5 Pi], but I want to know why exactly it's doing this.
2) y[k] is not evaluating at k=pi,2pi,3pi, etc.
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