Mathematica integral with many singularities - wolfram-mathematica

What's the best way of getting Mathematica 7 or 8 to do the integral
NIntegrate[Exp[-x]/Sin[Pi x], {x, 0, 50}]
There are poles at every integer - and we want the Cauchy principle value.
The idea is to get a good approximation for the integral from 0 to infinity.
With Integrate there is the option PrincipleValue -> True.
With NIntegrate I can give it the option Exclusions -> (Sin[Pi x] == 0), or manually give it the poles by
NIntegrate[Exp[-x]/Sin[Pi x], Evaluate[{x, 0, Sequence##Range[50], 50}]]
The original command and the above two NIntegrate tricks give the result 60980 +/- 10. But they all spit out errors. What is the best way of getting a quick reliable result for this integral without Mathematica wanting to give errors?

Simon, is there reason to believe your integral is convergent ?
In[52]:= f[k_Integer, eps_Real] :=
NIntegrate[Exp[-x]/Sin[Pi x], {x, k + eps, k + 1 - eps}]
In[53]:= Sum[f[k, 1.0*10^-4], {k, 0, 50}]
Out[53]= 2.72613
In[54]:= Sum[f[k, 1.0*10^-5], {k, 0, 50}]
Out[54]= 3.45906
In[55]:= Sum[f[k, 1.0*10^-6], {k, 0, 50}]
Out[55]= 4.19199
It looks like the problem is at x==0. Splitting integrand k+eps to k+1-eps for integer values of k:
In[65]:= int =
Sum[(-1)^k Exp[-k ], {k, 0, Infinity}] Integrate[
Exp[-x]/Sin[Pi x], {x, eps, 1 - eps}, Assumptions -> 0 < eps < 1/2]
Out[65]= (1/((1 +
E) (I + \[Pi])))E (2 E^(-1 + eps - I eps \[Pi])
Hypergeometric2F1[1, (I + \[Pi])/(2 \[Pi]), 3/2 + I/(2 \[Pi]),
E^(-2 I eps \[Pi])] +
2 E^(I eps (I + \[Pi]))
Hypergeometric2F1[1, (I + \[Pi])/(2 \[Pi]), 3/2 + I/(2 \[Pi]),
E^(2 I eps \[Pi])])
In[73]:= N[int /. eps -> 10^-6, 20]
Out[73]= 4.1919897038160855098 + 0.*10^-20 I
In[74]:= N[int /. eps -> 10^-4, 20]
Out[74]= 2.7261330651934049862 + 0.*10^-20 I
In[75]:= N[int /. eps -> 10^-5, 20]
Out[75]= 3.4590554287709991277 + 0.*10^-20 I
As you see there is a logarithmic singularity.
In[79]:= ser =
Assuming[0 < eps < 1/32, FullSimplify[Series[int, {eps, 0, 1}]]]
Out[79]= SeriesData[eps, 0, {(I*(-1 + E)*Pi -
2*(1 + E)*HarmonicNumber[-(-I + Pi)/(2*Pi)] +
Log[1/(4*eps^2*Pi^2)] - 2*E*Log[2*eps*Pi])/(2*(1 + E)*Pi),
(-1 + E)/((1 + E)*Pi)}, 0, 2, 1]
In[80]:= Normal[
ser] /. {{eps -> 1.*^-6}, {eps -> 0.00001}, {eps -> 0.0001}}
Out[80]= {4.191989703816426 - 7.603403526913691*^-17*I,
3.459055428805136 -
7.603403526913691*^-17*I,
2.726133068607085 - 7.603403526913691*^-17*I}
EDIT
Out[79] of the code above gives the series expansion for eps->0, and if these two logarithmic terms get combined, we get
In[7]:= ser = SeriesData[eps, 0,
{(I*(-1 + E)*Pi - 2*(1 + E)*HarmonicNumber[-(-I + Pi)/(2*Pi)] +
Log[1/(4*eps^2*Pi^2)] - 2*E*Log[2*eps*Pi])/(2*(1 + E)*
Pi),
(-1 + E)/((1 + E)*Pi)}, 0, 2, 1];
In[8]:= Collect[Normal[PowerExpand //# (ser + O[eps])],
Log[eps], FullSimplify]
Out[8]= -(Log[eps]/\[Pi]) + (
I (-1 + E) \[Pi] -
2 (1 + E) (HarmonicNumber[-((-I + \[Pi])/(2 \[Pi]))] +
Log[2 \[Pi]]))/(2 (1 + E) \[Pi])
Clearly the -Log[eps]/Pi came from the pole at x==0. So if one subtracts this, just like principle value method does this for other poles you end up with a finitely value:
In[9]:= % /. Log[eps] -> 0
Out[9]= (I (-1 + E) \[Pi] -
2 (1 + E) (HarmonicNumber[-((-I + \[Pi])/(2 \[Pi]))] +
Log[2 \[Pi]]))/(2 (1 + E) \[Pi])
In[10]:= N[%, 20]
Out[10]= -0.20562403655659928968 + 0.*10^-21 I
Of course, this result is difficult to verify numerically, but you might know more that I do about your problem.
EDIT 2
This edit is to justify In[65] input that computes the original regularized integral. We are computing
Sum[ Integrate[ Exp[-x]/Sin[Pi*x], {x, k+eps, k+1-eps}], {k, 0, Infinity}] ==
Sum[ Integrate[ Exp[-x-k]/Sin[Pi*(k+x)], {x, eps, 1-eps}], {k, 0, Infinity}] ==
Sum[ (-1)^k*Exp[-k]*Integrate[ Exp[-x]/Sin[Pi*x], {x, eps, 1-eps}],
{k, 0, Infinity}] ==
Sum[ (-1)^k*Exp[-k], {k, 0, Infinity}] *
Integrate[ Exp[-x]/Sin[Pi*x], {x, eps, 1-eps}]
In the third line Sin[Pi*(k+x)] == (-1)^k*Sin[Pi*x] for integer k was used.

Simon, I haven't spent much time with your integral, but you should try looking at stationary phase approximation. What you have is a smooth function (exp), and a highly oscillatory function (sine). The work involved is now in brow-beating the 1/sin(x) into the form exp(if(x))
Alternatively, you could use the series expansion of the cosecant (not valid at poles):
In[1]:=Series[Csc[x], {x, 0, 5}]
(formatted) Out[1]=1/x + x/6 + 7/360 x^3 + 31/15120 x^5 +O[x]^6
Note that for all m>-1, you have the following:
In[2]:=Integrate[x^m Exp[-x], {x, 0, Infinity}, Assumptions -> m > -1]
Out[2]=Gamma[1+m]
However, summing the series with the coefficients of cosecant (from wikipedia), not including 1/x Exp[-x] case, which doesn't converge on [0,Infinity].
c[m_] := (-1)^(m + 1) 2 (2^(2 m - 1) - 1) BernoulliB[2 m]/Factorial[2 m];
Sum[c[m] Gamma[1 + 2 m - 1], {m, 1, Infinity}]
does not converge either...
So, I'm not sure that you can work out an approximation for the integral to infinity, but I if you're satisfied with a solution upto some large N, I hope these help.

I have to agree with Sasha, the integral does not appear to be convergent. However, if you exclude x == 0 and break the integral into pieces
Integrate[Exp[-x]/Sin[Pi x], {x, n + 1/2, n + 3/2}, PrincipalValue -> True]
where n >= 0 && Element[n, Integers], then it seems you may get an alternating series
I Sum[ (-1/E)^n, {n, 1, Infinity}] == - I / (1 + E )
Now, I only took it out to n == 4, but it looks reasonable. However, for the integral above with Assumptions -> Element[n, Integers] && n >= 0 Mathematica gives
If[ 2 n >= 1, - I / E, Integrate[ ... ] ]
which just doesn't conform to the individual cases. As an additional note, if the pole lies at the boundary of the integration region, i.e. your limits are {x, n, n + 1}, you only get DirectedInfinitys. A quick look at the plot implies that you with the limits {x, n, n + 1} you only have a strictly positive or negative integrand, so the infinite value may be due to the lack of compensation which {x, n + 1/2, n + 3/2} gives you. Checking with {x, n, n + 2}, however it only spits out the unevaluated integral.

Related

Converting a ParametricPlot parametric expression to a ContourPlot cartesian expression

Using ParametricPlot I can plot a lemniscate expressed in parametric coordinates:
ParametricPlot[1/(1 + Sin[t]^2) {Cos[t], Cos[t] Sin[t]}, {t, 0, 2 [Pi]}]
I want to find using Mathematica the equivalent cartesian expression and plot it using ContourPlot that I know to be:
ContourPlot[(x^2 + y^2)^2 == (x^2 \[Minus] y^2), {x, -1, 1}, {y,-1,1}]
Looking up among the MMA functions I wondered if CoordinateTransformData or TransformedField could help me but none of them has the appropriate coordinate transformation :"Parametric" -> "Cartesian" which had me baffled.
How can this be done ?
It depends how much automatic solution you want.
eq = Thread[{x, y} == 1/(1 + Sin[t]^2) {Cos[t], Cos[t] Sin[t]}];
cont = Eliminate[eq, t] // Simplify
y != 0 && x^4 + y^2 + 2 x^2 y^2 + y^4 == x^2
ContourPlot[Evaluate#Last#cont, {x, -1, 1}, {y, -1, 1}]

Create a symbolic orthonormal matrix in mathematica

I need to create a 3 by 3 real orthonormal symbolic matrix in Mathematica.
How can I do so?
Not that I recommend this, but...
m = Array[a, {3, 3}];
{q, r} = QRDecomposition[m];
q2 = Simplify[q /. Conjugate -> Identity]
So q2 is a symbolic orthogonal matrix (assuming we work over reals).
You seem to want some SO(3) group parametrization in Mathematica I think. You will only have 3 independent symbols (variables), since you have 6 constraints from mutual orthogonality of vectors and the norms equal to 1. One way is to construct independent rotations around the 3 axes, and multiply those matrices. Here is the (perhaps too complex) code to do that:
makeOrthogonalMatrix[p_Symbol, q_Symbol, t_Symbol] :=
Module[{permute, matrixGeneratingFunctions},
permute = Function[perm, Permute[Transpose[Permute[#, perm]], perm] &];
matrixGeneratingFunctions =
Function /# FoldList[
permute[#2][#1] &,
{{Cos[#], 0, Sin[#]}, {0, 1, 0}, {-Sin[#], 0, Cos[#]}},
{{2, 1, 3}, {3, 2, 1}}];
#1.#2.#3 & ## MapThread[Compose, {matrixGeneratingFunctions, {p, q, t}}]];
Here is how this works:
In[62]:= makeOrthogonalMatrix[x,y,z]
Out[62]=
{{Cos[x] Cos[z]+Sin[x] Sin[y] Sin[z],Cos[z] Sin[x] Sin[y]-Cos[x] Sin[z],Cos[y] Sin[x]},
{Cos[y] Sin[z],Cos[y] Cos[z],-Sin[y]},
{-Cos[z] Sin[x]+Cos[x] Sin[y] Sin[z],Cos[x] Cos[z] Sin[y]+Sin[x] Sin[z],Cos[x] Cos[y]}}
You can check that the matrix is orthonormal, by using Simplify over the various column (or row) dot products.
I have found a "direct" way to impose special orthogonality.
See below.
(*DEFINITION OF ORTHOGONALITY AND SELF ADJUNCTNESS CONDITIONS:*)
MinorMatrix[m_List?MatrixQ] := Map[Reverse, Minors[m], {0, 1}]
CofactorMatrix[m_List?MatrixQ] := MapIndexed[#1 (-1)^(Plus ## #2) &, MinorMatrix[m], {2}]
UpperTriangle[ m_List?MatrixQ] := {m[[1, 1 ;; 3]], {0, m[[2, 2]], m[[2, 3]]}, {0, 0, m[[3, 3]]}};
FlatUpperTriangle[m_List?MatrixQ] := Flatten[{m[[1, 1 ;; 3]], m[[2, 2 ;; 3]], m[[3, 3]]}];
Orthogonalityconditions[m_List?MatrixQ] := Thread[FlatUpperTriangle[m.Transpose[m]] == FlatUpperTriangle[IdentityMatrix[3]]];
Selfadjunctconditions[m_List?MatrixQ] := Thread[FlatUpperTriangle[CofactorMatrix[m]] == FlatUpperTriangle[Transpose[m]]];
SO3conditions[m_List?MatrixQ] := Flatten[{Selfadjunctconditions[m], Orthogonalityconditions[m]}];
(*Building of an SO(3) matrix*)
mat = Table[Subscript[m, i, j], {i, 3}, {j, 3}];
$Assumptions = SO3conditions[mat]
Then
Simplify[Det[mat]]
gives 1;...and
MatrixForm[Simplify[mat.Transpose[mat]]
gives the identity matrix;
...finally
MatrixForm[Simplify[CofactorMatrix[mat] - Transpose[mat]]]
gives a Zero matrix.
========================================================================
This is what I was looking for when I asked my question!
However, let me know your thought on this method.
Marcellus
Marcellus, you have to use some parametrization of SO(3), since your general matrix has to reflect the RP3 topology of the group. No single parametrization will cover the whole group without either multivaluedness or singular points. Wikipedia has a nice page about the various charts on SO(3).
Maybe one of the conceptually simplest is the exponential map from the Lie algebra so(3).
Define an antisymmetric, real A (which spans so(3))
A = {{0, a, -c},
{-a, 0, b},
{c, -b, 0}};
Then MatrixExp[A] is an element of SO(3).
We can check that this is so, using
Transpose[MatrixExp[A]].MatrixExp[A] == IdentityMatrix[3] // Simplify
If we write t^2 = a^2 + b^2 + c^2, we can simplify the matrix exponential down to
{{ b^2 + (a^2 + c^2) Cos[t] , b c (1 - Cos[t]) + a t Sin[t], a b (1 - Cos[t]) - c t Sin[t]},
{b c (1 - Cos[t]) - a t Sin[t], c^2 + (a^2 + b^2) Cos[t] , a c (1 - Cos[t]) + b t Sin[t]},
{a b (1 - Cos[t]) + c t Sin[t], a c (1 - Cos[t]) - b t Sin[t], a^2 + (b^2 + c^2) Cos[t]}} / t^2
Note that this is basically the same parametrization as RotationMatrix gives.
Compare with the output from
RotationMatrix[s, {b, c, a}] // ComplexExpand // Simplify[#, Trig -> False] &;
% /. a^2 + b^2 + c^2 -> 1
Although I really like the idea of Marcellus' answer to his own question, it's not completely correct. Unfortunately, the conditions he arrives at also result in
Simplify[Transpose[mat] - mat]
evaluating to a zero matrix! This is clearly not right. Here's an approach that's both correct and more direct:
OrthogonalityConditions[m_List?MatrixQ] := Thread[Flatten[m.Transpose[m]] == Flatten[IdentityMatrix[3]]];
SO3Conditions[m_List?MatrixQ] := Flatten[{OrthogonalityConditions[m], Det[m] == 1}];
i.e. multiplying a rotation matrix by its transpose results in the identity matrix, and the determinant of a rotation matrix is 1.

How to make code for sum of 2 integrals in Mathematica

I am trying to quickly solve the following problem:
f[r_] := Sum[(((-1)^n (2 r - 2 n - 7)!!)/(2^n n! (r - 2 n - 1)!))
* x^(r - 2*n - 1),
{n, 0, r/2}];
Nw := Transpose[Table[f[j], {i, 1}, {j, 5, 200, 1}]];
X1 = Integrate[Nw . Transpose[Nw], {x, -1, 1}]
I can get the answer quickly with this code:
$starttime = AbsoluteTime[]; Quiet[LaunchKernels[]];
DIM = 50;
Print["$Version = ", $Version, " ||| ",
"Number of Kernels : ", Length[Kernels[]]];
Nw = Transpose[Table[f[j], {i, 1}, {j, 5, DIM, 1}]];
nw2 = Nw.Transpose[Nw];
Round[First[AbsoluteTiming[nw3 = ParallelMap[Expand, nw2]; ]]]
intrule = (pol_Plus)?(PolynomialQ[#1, x]&) :>
(Select[pol, !FreeQ[#1, x] & ] /.
x^(n_.) /; n > -1 :> ((-1)^n + 1)/(n + 1)) + 2*(pol /. x -> 0)]);
Round[First[AbsoluteTiming[X1 = ParallelTable[row /. intrule, {row, nw3}]; ]]]
X1
Print["overall time needed in seconds: ", Round[AbsoluteTime[] - $starttime]];
But how can I manage this code if I need to solve the following problem, where a and b are known constants?
X1 = a Integrate[Nw.Transpose[Nw], {x, -1, 0.235}]
+ b Integrate[Nw.Transpose[Nw], {x, 0.235,1}];
Here's a simple function to do definite integrals of polynomials
polyIntegrate[expr_List, {x_, x0_, x1_}] := polyIntegrate[#, {x, x0, x1}]&/#expr
polyIntegrate[expr_, {x_, x0_, x1_}] := Check[Total[#
Table[(x1^(1 + n) - x0^(1 + n))/(1 + n), {n, 0, Length[#] - 1}]
]&[CoefficientList[expr, x]], $Failed, {General::poly}]
On its range of applicability, this is about 100 times faster than using Integrate. This should be fast enough for your problem. If not, then it could be parallelized.
f[r_] := Sum[(((-1)^n*(2*r - 2*n - 7)!!)/(2^n*n!*(r - 2*n - 1)!))*
x^(r - 2*n - 1), {n, 0, r/2}];
Nw = Transpose[Table[f[j], {i, 1}, {j, 5, 50, 1}]];
a*polyIntegrate[Nw.Transpose[Nw], {x, -1, 0.235}] +
b*polyIntegrate[Nw.Transpose[Nw], {x, 0.235, 1}] // Timing // Short
(* Returns: {7.9405,{{0.0097638 a+0.00293462 b,<<44>>,
-0.0000123978 a+0.0000123978 b},<<44>>,{<<1>>}}} *)

Mathematica: NExpectation vs Expectation - inconsistent results

Following code returns different values for NExpectation and Expectation.
If I try the same for NormalDistribution[] I get convergence erors for NExpectation (but the final result is still 0 for all of them).
What is causing the problem?
U[x_] := If[x >= 0, Sqrt[x], -Sqrt[-x]]
N[Expectation[U[x], x \[Distributed] NormalDistribution[1, 1]]]
NExpectation[U[x], x \[Distributed] NormalDistribution[1, 1]]
Output:
-0.104154
0.796449
I think it might actually be an Integrate bug.
Let's define your
U[x_] := If[x >= 0, Sqrt[x], -Sqrt[-x]]
and the equivalent
V[x_] := Piecewise[{{Sqrt[x], x >= 0}, {-Sqrt[-x], x < 0}}]
which are equivalent over the reals
FullSimplify[U[x] - V[x], x \[Element] Reals] (* Returns 0 *)
For both U and V, the analytic Expectation command uses the Method option "Integrate" this can be seen by running
Table[Expectation[U[x], x \[Distributed] NormalDistribution[1, 1],
Method -> m], {m, {"Integrate", "Moment", "Sum", "Quantile"}}]
Thus, what it's really doing is the integral
Integrate[U[x] PDF[NormalDistribution[1, 1], x], {x, -Infinity, Infinity}]
which returns
(Sqrt[Pi] (BesselI[-(1/4), 1/4] - 3 BesselI[1/4, 1/4] +
BesselI[3/4, 1/4] - BesselI[5/4, 1/4]))/(4 Sqrt[2] E^(1/4))
The integral for V
Integrate[V[x] PDF[NormalDistribution[1, 1], x], {x, -Infinity, Infinity}]
gives the same answer but multiplied by a factor of 1 + I. This is clearly a bug.
The numerical integral using U or V returns the expected value of 0.796449:
NIntegrate[U[x] PDF[NormalDistribution[1, 1], x], {x, -Infinity, Infinity}]
This is presumably the correct solution.
Edit: The reason that kguler's answer returns the same value for all versions is because the u[x_?NumericQ] definition prevents the analytic integrals from being performed so Expectation is unevaluated and reverts to using NExpectation when asked for its numerical value..
Edit 2:
Breaking down the problem a little bit more, you find
In[1]:= N#Integrate[E^(-(1/2) (-1 + x)^2) Sqrt[x] , {x, 0, Infinity}]
NIntegrate[E^(-(1/2) (-1 + x)^2) Sqrt[x] , {x, 0, Infinity}]
Out[1]= 0. - 0.261075 I
Out[2]= 2.25748
In[3]:= N#Integrate[Sqrt[-x] E^(-(1/2) (-1 + x)^2) , {x, -Infinity, 0}]
NIntegrate[Sqrt[-x] E^(-(1/2) (-1 + x)^2) , {x, -Infinity, 0}]
Out[3]= 0.261075
Out[4]= 0.261075
Over both the ranges, the integrand is real, non-oscillatory with an exponential decay. There should not be any need for imaginary/complex results.
Finally note that the above results hold for Mathematica version 8.0.3.
In version 7, the integrals return 1F1 hypergeometric functions and the analytic result matches the numeric result. So this bug (which is also currently present in Wolfram|Alpha) is a regression.
If you change the argument of your function u to avoid evaluation for non-numeric values all three methods gives the same result:
u[x_?NumericQ] := If[x >= 0, Sqrt[x], -Sqrt[-x]] ;
Expectation[u[x], x \[Distributed] NormalDistribution[1, 1]] // N;
N[Expectation[u[x], x \[Distributed] NormalDistribution[1, 1]]] ;
NExpectation[u[x], x \[Distributed] NormalDistribution[1, 1]];
{% === %% === %%%, %}
with the result
{True, 0.796449}

Error in RecurrenceTable with symbolic input

I am finally working on my n-point Pade code, again, and I am running across an error that was not occurring previously. The heart of the matter revolves around this code:
zi = {0.1, 0.2, 0.3}
ai = {0.904837, 1.05171, -0.499584}
Quiet[ RecurrenceTable[ {A[0] == 0, A[1] == ai[[1]],
A[n+1]==A[n] + (z - zi[[n]]) ai[[n+1]] A[n-1]},
A, {n, Length#ai -1 } ],
{Part::pspec}]
(The use of Quiet is necessary as Part complains about zi[[n]] and ai[[n+1]] when n is purely symbolic.) The code itself is part of a function that I want a symbolic result from, hence z is a Symbol. But, when I run the above code I get the error:
RecurrenceTable::nlnum1:
The function value {0.904837,0.904837+0. z} is not a list of numbers with
dimensions {2} when the arguments are {0,0.,0.904837}.
Note the term {0.904837,0.904837+0. z} where 0. z is not reduced to zero. What do I need to do to force it to evaluate to zero, as it seems to be the source of the problem? Are there alternatives?
Additionally, as a general complaint about the help system for the Wolfram Research personnel who haunt stackoverflow: in v.7 RecurrenceTable::nlnum1 is not searchable! Nor, does the >> link at the end of the error take you to the error definition, but takes you to the definition of RecurrenceTable, instead, where the common errors are not cross-referenced.
Edit: After reviewing my code, the solution I came up with was to evaluate the RecurrenceTable completely symbolically, including the initial conditions. The working code is as follows:
Clear[NPointPade, NPointPadeFcn]
NPointPade[pts : {{_, _} ..}] := NPointPade ## Transpose[pts]
NPointPade[zi_List, fi_List] /; Length[zi] == Length[fi] :=
Module[{ap, fcn, rec},
ap = {fi[[1]]};
fcn = Module[{gp = #, zp, res},
zp = zi[[-Length#gp ;;]];
res = (gp[[1]] - #)/((#2 - zp[[1]]) #) &[Rest#gp, Rest#zp];
AppendTo[ap, res[[1]]];
res
] &;
NestWhile[fcn, fi, (Length[#] > 1 &)];
(*
The recurrence relation is used twice, with different initial conditions, so
pre-evaluate it to pass along to NPointPadeFcn
*)
rec[aif_, zif_, a_, b_][z_] :=
Evaluate[RecurrenceTable[
{A[n + 1] == A[n] + (z - zif[n])*aif[n + 1]*A[n - 1],
A[0] == a, A[1] == b},
A, {n, {Length#ap - 1}}][[1]]];
NPointPadeFcn[{zi, ap, rec }]
]
NPointPadeFcn[{zi_List, ai_List, rec_}][z_] /; Length[zi] == Length[ai] :=
Module[{aif, zif},
zif[n_Integer] /; 1 <= n <= Length[zi] := zi[[n]];
aif[n_Integer] /; 1 <= n <= Length[zi] := ai[[n]];
rec[aif, zif, 0, ai[[1]]][z]/rec[aif, zif, 1, 1][z]
]
Format[NPointPadeFcn[x_List]] := NPointPadeFcn[Shallow[x, 1]];
Like the built-in interpolation functions, NPointPade does some pre-processing, and returns a function that can be evaluated, NPointPadeFcn. The pre-processing done by NPointPade generates the list of ais from the zis and the function values at those points, in addition to pre-evaluating the recurrence relations. When NPointPadeFcn is supplied with a z value, it evaluates two linear recurrence relations by supplying it with the appropriate values.
Edit: for the curious, here's NPointPade in operation
In the first plot, it is difficult to tell the difference between the two functions, but the second plot shows the absolute (blue) and relative (red) errors. As written, it takes a very long time to create a Pade for 20 points, so I need to work on speeding it up. But, for now, it works.
You can hide part extraction behind a function:
In[122]:= zi = {0.1, 0.2, 0.3};
ai = {0.904837, 1.05171, -0.499584};
In[124]:= zif[n_Integer] /; 1 <= n <= Length[zi] := zi[[n]]
aif[n_Integer] /; 1 <= n <= Length[ai] := ai[[n]]
In[127]:= RecurrenceTable[{A[0] == 0, A[1] == aif[1],
A[n + 1] ==
A[n] + (z - zif[n]) aif[n + 1] A[n - 1]}, A, {n, (Length#ai) - 1}]
Out[127]= {0.904837, 0.904837,
0.904837 - 0.271451 aif[4] + 0.904837 z aif[4]}
EDIT
Here is the work-around for the problem:
In[4]:= zi = {0.1, 0.2, 0.3};
ai = {0.904837, 1.05171, -0.499584};
In[6]:= zif[n_Integer] /; 1 <= n <= Length[zi] := zi[[n]]
aif[n_Integer] /; 1 <= n <= Length[ai] := ai[[n]]
In[8]:= Block[{aif, zif},
RecurrenceTable[{A[0] == 0, A[1] == aif[1],
A[n + 1] == A[n] + (z - zif[n]) aif[n + 1] A[n - 1]},
A, {n, 0, (Length#ai) - 1}]]
Out[8]= {0, 0.904837, 0.904837}
Block serves to temporarily remove definitions of aif and zif while RecurrenceTable is executed. Then, when Block exits, the values are restored, and the output of RecurrenceTable evaluates.
It seems to me that Sasha's approach can be mimicked by just Blocking Part.
zi = {0.1, 0.2, 0.3};
ai = {0.904837, 1.05171, -0.499584};
Block[{Part},
RecurrenceTable[{A[0] == 0, A[1] == ai[[1]],
A[n + 1] == A[n] + (z - zi[[n]]) ai[[n + 1]] A[n - 1]},
A, {n, Length#ai - 1}]
]
{0, 0.904837, 0.904837}
Addressing Sasha's criticism, here are two other ways one might approach this:
With[{Part = $z},
RecurrenceTable[{A[0] == 0, A[1] == ai[[1]],
A[n + 1] == A[n] + (z - zi[[n]]) ai[[n + 1]] A[n - 1]},
A, {n, Length#ai - 1}]
] /. $z -> Part
-
With[{Part = Hold[Part]},
RecurrenceTable[{A[0] == 0, A[1] == ai[[1]],
A[n + 1] == A[n] + (z - zi[[n]]) ai[[n + 1]] A[n - 1]},
A, {n, Length#ai - 1}]
] // ReleaseHold

Resources