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; } }