SEXP F21DaR(SEXP A, SEXP B, SEXP C, SEXP Z, SEXP Minit, SEXP Maxit) {
int n = LENGTH(Z);
double maxit = REAL(Maxit)[0];
double minit = REAL(Minit)[0];
double f, maxsum;
double a = REAL(A)[0];
Rcomplex b = COMPLEX(AS_COMPLEX(B))[0];
Rcomplex c = COMPLEX(AS_COMPLEX(C))[0];
Rcomplex *z = COMPLEX(Z);
double curra;
Rcomplex currc,currb,currsum,tres;
SEXP LRes, LNames, Res, Rel;
PROTECT (LRes = allocVector(VECSXP, 2));
PROTECT (LNames = allocVector(STRSXP, 2));
PROTECT (Res = allocVector(CPLXSXP, n));
PROTECT (Rel = allocVector(REALSXP, n));
Rcomplex *res = COMPLEX(Res);
double *rel = REAL(Rel);
for (int i=0; i<n; i++) {
curra = a; currb = b; currc = c; currsum.r = 1.; currsum.i = 0.;
tres = currsum; maxsum = 1.;
for (f = 1.; (f<minit)||((f<maxit)&&(StopCritD(currsum,tres)>DOUBLE_EPS)); f=f+1.) {
R_CheckUserInterrupt();
currsum = CMultR(currsum,curra);
currsum = CMult(currsum,currb);
currsum = CDiv(currsum,currc);
currsum = CMult(currsum,z[i]);
currsum = CDivR(currsum,f);
tres = CAdd(tres,currsum);
curra = curra+1.;
currb = CAdd1(currb);
currc = CAdd1(currc);
// Rprintf("%f: %g + %g i\n",f,currsum.r,currsum.i);
maxsum = fmax2(maxsum,Cabs2(currsum));
}
if (f>=maxit) {
// Rprintf("D:Appr: %f - Z: %f + %f i, Currsum; %f + %f i, Rel: %g\n",f,z[i].r,z[i].i,currsum.r,currsum.i,StopCritD(currsum,tres));
warning("approximation of hypergeometric function inexact");
}
res[i] = tres;
rel[i] = sqrt(Cabs2(res[i])/maxsum);
// Rprintf("Iterations: %f, Result: %g+%g i\n",f,res[i].r,res[i].i);
}
SET_VECTOR_ELT(LRes, 0, Res);
SET_STRING_ELT(LNames, 0, mkChar("value"));
SET_VECTOR_ELT(LRes, 1, Rel);
SET_STRING_ELT(LNames, 1, mkChar("rel"));
setAttrib(LRes, R_NamesSymbol, LNames);
UNPROTECT(4);
return(LRes);
}
double CLPCAnal::Response(float *coeff, int n, double f)
{
COMPLEX omega[MAXORDER+1];
int i;
COMPLEX rnum,rden;
/* initialise polynomial values of complex frequency */
omega[0] = CMake(1.0,0.0);
omega[1] = CExp(CMake(0.0,2*M_PI*f));
for (i=2;i<=n;i++)
omega[i] = CMult(omega[i-1],omega[1]);
/* compute response of numerator */
rnum=omega[0];
/* compute response of denominator */
rden=omega[0];
for (i=1;i<=n;i++)
rden = CAdd(rden,CScale(omega[i],coeff[i]));
/* compute ratio */
if (CMag(rden)==0)
return(1.0E10); /* i.e. infinity */
else
return(CMag(CDiv(rnum,rden)));
}
/* find single root */
void CLPCAnal::Laguerre(COMPLEX *ap,int m,COMPLEX *r)
{
COMPLEX rlast;
int j,iter;
double err,abx;
COMPLEX sq,h,gp,gm,g2,g,bp,d,dx,f;
iter = 0;
do {
rlast = *r;
bp = ap[m];
err = CMag(bp);
f = CMake(0.0,0.0);
d = f;
abx = CMag(*r);
/* compute value of polynomial & derivatives */
for (j=m-1;j>=0;j--) {
f = CAdd(CMult(*r,f),d);
d = CAdd(CMult(*r,d),bp);
bp = CAdd(CMult(*r,bp),ap[j]);
err = CMag(bp)+abx*err;
}
/* if polynomial = zero then already at root */
err = err * ROUND_ERROR;
if (CMag(bp) > err) {
/* no, iterate using Laguerre's formula */
g = CDiv(d,bp);
g2 = CMult(g,g);
h = CSub(g2,CScale(CDiv(f,bp),2.0));
sq = CSqrt(CScale(CSub(CScale(h,m*1.0),g2),m-1.0));
gp = CAdd(g,sq);
gm = CSub(g,sq);
if (CMag(gp) < CMag(gm)) gp = gm;
dx = CDiv(CMake(m*1.0,0.0),gp);
*r = CSub(*r,dx);
}
iter++;
} while (!((iter==100) || (CMag(bp)<=err) || ((r->re == rlast.re) && (r->im == rlast.im))));
/* terminating condition for iteration */
}
/* find all roots */
void CLPCAnal::AllRoots(COMPLEX *ap,int m,COMPLEX *roots)
{
int k,j,i;
COMPLEX x,bp,c;
COMPLEX ad[MAXPOLY];
for (j=0;j<=m;j++) ad[j] = ap[j];
for (j=m;j>=1;j--) {
/* find root */
x = CMake(0.0,0.0);
Laguerre(ad,j,&x);
if (fabs(x.im) <= (IM_RANGE*fabs(x.re)))
x.im = 0.0;
roots[j] = x;
/* deflation */
bp = ad[j];
for (k=j-1;k>=0;k--) {
c = ad[k];
ad[k] = bp;
bp = CAdd(CMult(x,bp),c);
}
}
/* sort into increasing root.real */
for (j=2;j<=m;j++) {
x = roots[j];
i = j;
while ((i > 1) && (x.re < roots[i-1].re)) {
roots[i] = roots[i-1];
i = i - 1;
}
roots[i] = x;
}
}
