/* Computes up to L2 fixed shift k-polynomials,
* testing for convergence in the linear or quadratic
* case. Initiates one of the variable shift
* iterations and returns with the number of zeros
* found.
*/
void fxshfr(int l2,int *nz)
{
double svu,svv,ui,vi,s;
double betas,betav,oss,ovv,ss,vv,ts,tv;
double ots,otv,tvv,tss;
int type, i,j,iflag,vpass,spass,vtry,stry;
*nz = 0;
betav = 0.25;
betas = 0.25;
oss = sr;
ovv = v;
/* Evaluate polynomial by synthetic division. */
quadsd(n,&u,&v,p,qp,&a,&b);
calcsc(&type);
for (j=0;j<l2;j++) {
/* Calculate next k polynomial and estimate v. */
nextk(&type);
calcsc(&type);
newest(type,&ui,&vi);
vv = vi;
/* Estimate s. */
ss = 0.0;
if (k[n-1] != 0.0) ss = -p[n]/k[n-1];
tv = 1.0;
ts = 1.0;
if (j == 0 || type == 3) goto _70;
/* Compute relative measures of convergence of s and v sequences. */
if (vv != 0.0) tv = fabs((vv-ovv)/vv);
if (ss != 0.0) ts = fabs((ss-oss)/ss);
/* If decreasing, multiply two most recent convergence measures. */
tvv = 1.0;
if (tv < otv) tvv = tv*otv;
tss = 1.0;
if (ts < ots) tss = ts*ots;
/* Compare with convergence criteria. */
vpass = (tvv < betav);
spass = (tss < betas);
if (!(spass || vpass)) goto _70;
/* At least one sequence has passed the convergence test.
* Store variables before iterating.
*/
svu = u;
svv = v;
for (i=0;i<n;i++) {
svk[i] = k[i];
}
s = ss;
/* Choose iteration according to the fastest converging
* sequence.
*/
vtry = 0;
stry = 0;
if ((spass && (!vpass)) || (tss < tvv)) goto _40;
_20:
quadit(&ui,&vi,nz);
if (*nz > 0) return;
/* Quadratic iteration has failed. Flag that it has
* been tried and decrease the convergence criterion.
*/
vtry = 1;
betav *= 0.25;
/* Try linear iteration if it has not been tried and
* the S sequence is converging.
*/
if (stry || !spass) goto _50;
for (i=0;i<n;i++) {
k[i] = svk[i];
}
_40:
realit(s,nz,&iflag);
if (*nz > 0) return;
/* Linear iteration has failed. Flag that it has been
* tried and decrease the convergence criterion.
*/
stry = 1;
betas *=0.25;
if (iflag == 0) goto _50;
/* If linear iteration signals an almost double real
* zero attempt quadratic iteration.
*/
ui = -(s+s);
vi = s*s;
goto _20;
/* Restore variables. */
_50:
u = svu;
v = svv;
for (i=0;i<n;i++) {
k[i] = svk[i];
}
/* Try quadratic iteration if it has not been tried
* and the V sequence is convergin.
*/
if (vpass && !vtry) goto _20;
/* Recompute QP and scalar values to continue the
* second stage.
*/
quadsd(n,&u,&v,p,qp,&a,&b);
calcsc(&type);
_70:
ovv = vv;
oss = ss;
otv = tv;
ots = ts;
}
}
/* Variable-shift k-polynomial iteration for a
* quadratic factor converges only if the zeros are
* equimodular or nearly so.
* uu, vv - coefficients of starting quadratic.
* nz - number of zeros found.
*/
void quadit(double *uu,double *vv,int *nz)
{
double ui,vi;
double mp,omp,ee,relstp,t,zm;
int type,i,j,tried;
*nz = 0;
tried = 0;
u = *uu;
v = *vv;
j = 0;
/* Main loop. */
_10:
itercnt++;
quad(1.0,u,v,&szr,&szi,&lzr,&lzi);
/* Return if roots of the quadratic are real and not
* close to multiple or nearly equal and of opposite
* sign.
*/
if (fabs(fabs(szr)-fabs(lzr)) > 0.01 * fabs(lzr)) return;
/* Evaluate polynomial by quadratic synthetic division. */
quadsd(n,&u,&v,p,qp,&a,&b);
mp = fabs(a-szr*b) + fabs(szi*b);
/* Compute a rigorous bound on the rounding error in
* evaluating p.
*/
zm = sqrt(fabs(v));
ee = 2.0*fabs(qp[0]);
t = -szr*b;
for (i=1;i<n;i++) {
ee = ee*zm + fabs(qp[i]);
}
ee = ee*zm + fabs(a+t);
ee *= (5.0 *mre + 4.0*are);
ee = ee - (5.0*mre+2.0*are)*(fabs(a+t)+fabs(b)*zm);
ee = ee + 2.0*are*fabs(t);
/* Iteration has converged sufficiently if the
* polynomial value is less than 20 times this bound.
*/
if (mp <= 20.0*ee) {
*nz = 2;
return;
}
j++;
/* Stop iteration after 20 steps. */
if (j > 20) return;
if (j < 2) goto _50;
if (relstp > 0.01 || mp < omp || tried) goto _50;
/* A cluster appears to be stalling the convergence.
* Five fixed shift steps are taken with a u,v close
* to the cluster.
*/
if (relstp < eta) relstp = eta;
relstp = sqrt(relstp);
u = u - u*relstp;
v = v + v*relstp;
quadsd(n,&u,&v,p,qp,&a,&b);
for (i=0;i<5;i++) {
calcsc(&type);
nextk(&type);
}
tried = 1;
j = 0;
_50:
omp = mp;
/* Calculate next k polynomial and new u and v. */
calcsc(&type);
nextk(&type);
calcsc(&type);
newest(type,&ui,&vi);
/* If vi is zero the iteration is not converging. */
if (vi == 0.0) return;
relstp = fabs((vi-v)/vi);
u = ui;
v = vi;
goto _10;
}
types::Function::ReturnValue sci_newest(types::typed_list &in, int _iRetCount, types::typed_list &out)
{
int iRet = 0;
int iNbrString = 0;
wchar_t** pwcsStringInput = NULL;
if (in.size() == 0)
{
out.push_back(types::Double::Empty());
return types::Function::OK;
}
if (in.size() == 1)
{
if (in[0]->isString() == FALSE)
{
if (in[0]->getAs<types::GenericType>()->getSize() == 0)
{
out.push_back(types::Double::Empty());
return types::Function::OK;
}
else
{
Scierror(999, _("%s: Wrong type for input argument #%d: A String(s) expected.\n"), "newest", 1);
return types::Function::Error;
}
}
if (in[0]->getAs<types::String>()->isScalar())
{
out.push_back(new types::Double(1));
return types::Function::OK;
}
else
{
int size = in[0]->getAs<types::String>()->getSize();
pwcsStringInput = (wchar_t**)MALLOC(size * sizeof(wchar_t*));
for (iNbrString = 0; iNbrString < size; iNbrString++)
{
pwcsStringInput[iNbrString] = in[0]->getAs<types::String>()->get(iNbrString);
}
iRet = newest(pwcsStringInput, iNbrString);
FREE(pwcsStringInput);
out.push_back(new types::Double(iRet));
}
}
else
{
int size = (int)in.size();
pwcsStringInput = (wchar_t**)MALLOC(size * sizeof(wchar_t*));
for (iNbrString = 0; iNbrString < size; iNbrString++)
{
if (in[iNbrString]->isString() == FALSE)
{
FREE(pwcsStringInput);
Scierror(999, _("%s: Wrong type for input argument #%d: A string expected.\n"), "newest", iNbrString + 1);
return types::Function::Error;
}
pwcsStringInput[iNbrString] = in[iNbrString]->getAs<types::String>()->get(0);
}
if (in[1]->getAs<types::String>()->isScalar() == false)
{
FREE(pwcsStringInput);
Scierror(999, _("%s: Wrong size for input argument #%d: A string expected.\n"), "newest", 2);
return types::Function::Error;
}
iRet = newest(pwcsStringInput, iNbrString);
FREE(pwcsStringInput);
out.push_back(new types::Double((double)iRet));
}
return types::Function::OK;
}
