Sindbad~EG File Manager

/* M. Beeson, for Mathpert
Original date 3.1.92
Last modified 6.14.98
*/

#include <time.h>  /* randomize */
#include <string.h>  /* memset */
#include <assert.h>
#include <math.h>
#include <string.h>
#define POLYVAL_DLL
#include "globals.h"
#include "dcomplex.h"
#include "polynoms.h"
#include "algaux.h"
#include "ceval.h"
#include "order.h"
#include "newton.h"
#include "drandom.h"
#include "deval.h"
#include "symbols.h"
#include "errbuf.h"
#include "proot.h"
#define MAXFAILURES 100
/*___________________________________________________________*/

/*  Find all complex roots of a complex polynomial using
    Newton's method, but choosing a new starting value at
    random if the iteration gets more than ten times larger
    than a bound on the roots
*/

#define ROUND(x)   (int)((x)+0.5)

static int zroots(dcomplex *a,int m,dcomplex *roots);

MEXPORT_POLYVAL int polyroot2(term t, dcomplex *roots, int *nroots)
/* this is almost a static copy of the routine polyroot in newton.c;
   but it has an extra parameter to store the roots, and it calls
   the static version of zroots in this file which does
   not draw the roots, as the one in newton.c does. */
/* t is a polynomial, i.e. a term with functor POLY whose args are terms
   representing the coefficients.  The array roots has already been
   allocated before this function is called. */
/* returns the roots in array roots, indexed as usual from 0, not from
   1 as in zroots */
/* Nonzero return is an error.  1 is the only error return value.
     The coefficients of t can contain variables; ceval is used to evaluate
   the coefficients, so depending on the current values of those variables,
   the degree of t with its coefficients numerically evaluated may be
   less than the degree of t.  Hence the number of roots may be
   less than the degree of t.  This number will be placed in *nroots.
   If the polynomial turns out to be identically zero, -1 will be placed
   in nroots.
*/

{ int i,err;
  dcomplex *a;  /* coefficients of the polynomial */
  int m = ARITY(t) -1;  /* degree of the poly */
  assert(m >=0);
  if(m==0)
     return 1;  /* can't use this on a constant poly */
  a = (dcomplex *) callocate(ARITY(t), sizeof(dcomplex));
  if(a==NULL)
     { nospace();
       return 1;
     }
  if(!contains(t,'i'))  /* real coefficients, so use deval */
     { for(i=0;i<=m;i++)
         { deval(ARG(i,t),&a[i].r);
           if(a[i].r == BADVAL)
              return 1;
           if(fabs(a[i].r) < VERYSMALL)
              a[i].r = 0.0;
           a[i].i = 0.0;
         }
     }
  else /*   complex coefficients, so use ceval  */
     { for(i=0;i<=m;i++)
          { err = ceval(ARG(i,t),&a[i]);
            if(err)
               return 1;
            if(fabs(a[i].r) < VERYSMALL)
               a[i].r = 0.0;
            if(fabs(a[i].i) < VERYSMALL)
               a[i].i = 0.0;
          }
     }
  /* The polynomial t can contain variables in the coefficients.  When
  ceval is used on them, they can possibly have value zero.  So the
  degree of the polynomial with numerically evaluated coefficients might
  be less than m.  The polynomial might even be identically zero!  Let's
  check for this. */
  for(i=m;i>=0;i--)
     { if(fabs(a[i].r) != 0.0 || fabs(a[i].i) != 0.0)
          break;
     }
  if(i < 0)
     { /* polynomial was identically zero */
       *nroots = 1;
       return 0;
     }
  if(i==0)
     { /* polynomial is constant but not zero */
       *nroots = 0;
       return 0;
     }
  m = i;
  *nroots = m;
  err = zroots(a,m,roots-1); /* calculate the roots */
   /* pass roots-1 because zroots expects legal indices 1...degree */
  free2(a);  /* allocated above */
  return err;
}

/*zroots_____________________________________________________________*/
/* I removed parameter 'polish' from zroots and made it return an error value */
/* Made it polish the roots for degree 3 or more /
/* even for x^3 they are off in the fourth decimal place without polishing */
/* and adjusted the choice of starting value to avoid values that crash laguer */
/* and made it restart randomly with a square containing the roots when newton
   does fail */
/* and put in dynamic allocation of 'ad' to remove artificial limit on degree */
/* Return value is 0 for success, 1 if newton fails after MAXFAILURES
random restarts */

#define EPS 2.0e-14  /* keep much more accuracy than in Num Recipes code */

static int zroots(dcomplex *a,int m,dcomplex *roots)
/*  Code much modified but originating from Numerical Recipes zroots
on p. 281 of Numerical Recipes.
a is the array of coefficients of the polynomial (a[i] x^i);
m is the degree;
roots is the output array (indexed 1...m), sorted by real part.
There is another version of this in file newton.c, which DRAWS the
roots.  This one only calculates them.
*/
{ int jj,j,i;
  int err;
  double bound;
  int timesfailed;
  int polish = 1;  // (m > 2 ? 1 : 0);
  dcomplex x,b,c,*ad;
        /* space to record where the roots are written by putimage */
  ad = (dcomplex *) callocate(m+1,sizeof(dcomplex));
  for(j=0;j<=m;j++)
      ad[j]=a[j];
  /* By Exercise 20, p. 438 vol. 2 of Knuth, a bound
     for the roots is the sqrt of the sum of squares
     of the absolute values of the coefficients,
     divided by the leading coef, ad[m]
  */
  bound=0.0;
  for(j=0;j<=m;j++)
      { bound += ad[j].r * ad[j].r + ad[j].i * ad[j].i;
      }
  bound /=  (ad[m].r *ad[m].r + ad[m].i* ad[m].i);
  bound = sqrt(bound);
  for (j=m;j>=1;j--)
     { /* choose starting value; avoid  zeros of a' */
       timesfailed = 0;
       err = 1;  /* to get the loop started */
       while(err)
          { /* choose starting value at random */
            x.r = 2 * bound * (drandom() - 0.5);
            x.i = 2 * bound * (drandom() - 0.5);
            err = newton(ad,j,&x,EPS,0,10.0 * bound);
            if(err)
               ++timesfailed;
            if(timesfailed > MAXFAILURES)
               return 1;
          }
       if(polish)  /* polish using undeflated coefficients */
          newton(a,m,&x,EPS,1,10.0 *bound);
       if (fabs(x.i) <= (2.0*EPS*fabs(x.r)))
          x.i=0.0;
       roots[j]=x;
       b=ad[j];
       for(jj=j-1;jj>=0;jj--)
                    /* deflate AFTER polishing */
          { c=ad[jj];
            ad[jj]=b;
            b=Cplus(Cmul(x,b),c);
          }
     }
  for(j=2;j<=m;j++)  /* sort the roots according to real part */
     { x=roots[j];
       for (i=j-1;i>=1;i--)
          { if (roots[i].r <= x.r)
               break;
            roots[i+1]=roots[i];
          }
       roots[i+1]=x;
     }
  free2(ad);
  return 0;
}

#undef EPS

/*__________________________________________________________________________*/
#define MAXDEG 16
MEXPORT_POLYVAL int polyrange_aux(POLYnomial q, double *minroot, double *maxroot)
/* return the number of real roots of polynomial q, and
if it's nonzero, return in *minroot and *maxroot the least and
greatest real roots.  A constant polynomial produces return
value zero, even if the constant is zero.  If the degree of the
polynomial exceeds MAXDEG, return -1.  If polyroot fails,
return -2.  If return value is zero, put *minroot = *maxroot = 0.
*/
{ unsigned short n;
  dcomplex roots[MAXDEG];
  int err,i,nroots,ncomplexroots,flag;
  double min,max;
  if(ARITY(q) == 1)
     return 0;  /* a constant */
  n = (unsigned short)(ARITY(q) - 1);  /* degree of the polynomial */
  if(n > MAXDEG)
     return -1;
  err = polyroot2(q,roots,&ncomplexroots);
  if(err)
     return -2;
  nroots = 0;  /* count the real roots */
  flag = 0;
  for(i=0;i<ncomplexroots;i++)
     { if(fabs(roots[i].i) < VERYSMALL)
          { roots[i].i = 0;
            if(!flag)
               flag = i+1;
            ++nroots;
          }
       /* double roots have much less accuracy, don't miss them */
       else if(i> 0 && fabs(roots[i].i) < 1.0e-7 &&
               fabs(roots[i-1].i) < 1.0e-7 &&
               fabs(roots[i-1].r - roots[i].r) < 1.0e-7
              )
          { roots[i].i = 0;
            if(!flag)
               flag = i+1;
            ++nroots;
          }
     }
  if(nroots == 0)
     { *minroot = *maxroot = 0.0;
       return 0;  /* no real roots */
     }
  min = max = roots[flag-1].r;
  for(i=flag;i<n;i++)
     { if(roots[i].r < min)
          min = roots[i].r;
       else if(roots[i].r > max)
          max = roots[i].r;
     }
  *minroot = min;
  *maxroot = max;
  return nroots;
}