Sindbad~EG File Manager

/* Solve equations by Brent's method */
/* program idea based on p. 268 of Numerical Recipes in C */
/* The function is given as a C term and evaluated using deval.c */
/* M. Beeson, for Mathpert  */
/*
Original date 8.28.90
Last modified 1.1.96 before release of Mathpert 1.06
9.16.97 export.h for Microsoft compilation
1.13.98 changed make_term to deval_make_term
1.29.98 DEVAL_DLL etc.
*/

#include <math.h>

#ifdef XCODE
#include <stdlib.h>
#else
#include <malloc.h>   /* for alloca */
#endif

#include "terms.h"
#include "deval.h"

#define ITMAX 100
#define EPS 3.0e-16  /* double precision */

/*________________________________________________________________*/
static term deval_make_term( unsigned short f, unsigned short n)
/*   This version uses calloc instead of functions in heap.dll,
     so that deval.dll will be independent of my heap management.
     All memory allocation is purely temporary. */

{  term ans;
   SETFUNCTOR(ans,f,n);
   ZEROINFO(ans);  /* set all info fields to zero */
   if(n==0)
      return ans;  /* don't allocate space for any args */
   ans.args = (void *) calloc(n, sizeof(term));
   if(!ans.args)
      { SETFUNCTOR(ans,ILLEGAL,0);
        return ans;
      }
   SETARGS(ans);
   SETTYPE(ans,NOTYPE);
   return ans;
}


/*__________________________________________________________*/
#define SAMESIGN(a,b)   ((a > 0.0 && b > 0.0) || (a < 0.0 && b < 0.0))
/* don't use a*b > 0.0 as in Numerical Recipes because you cut the
   maximum size of a and b by half that way and risk overflow. */

int solve(term f,term x,double x1,double x2,double *ans)
/*  solve equation f=0, or equation f if f is an equation,
    for independent variable x,
    looking for a solution between x1 and x2.
    We must have x1 < x2 to begin with.
    Term x must be an atom.
    Answer is returned in *ans.
*/
/* return value 0 is success;
   1 is root not bracketed;
   2 is too many iterations;
   3 is 'x not an atom '
   4 is failure of deval
*/
{
int iter,err;
double a=x1,b=x2,c=0,d=0,e=0,min1,min2,tol;
double fa,fb,fc,p,q,r,s,tol1,xm;
if(FUNCTOR(f)== '=')
  { term g,h,arg0,arg1;
    arg0 = ARG(0,f);
    arg1 = ARG(1,f);
    if(OBJECT(arg1) && TYPE(arg1)==INTEGER && INTDATA(arg1)==0)
       return solve(arg0,x,x1,x2,ans);
    if(OBJECT(arg1) && TYPE(arg1)==DOUBLE && DOUBLEDATA(arg1)==0.0)
       return solve(arg0,x,x1,x2,ans);
    g = deval_make_term('+',2);
    h = deval_make_term('-',1);
    ARGREP(h,0,arg1);
    ARGREP(g,0,arg0);
    ARGREP(g,1,h);
    err = solve(g,x,x1,x2,ans);
    free(g.args); /* allocated by deval_make_term */
    free(h.args);
    return err;
  }
/* Now the input term is not an equation */
tol = EPS;          /*  in Numerical Recipes, tol is passed as a parameter */
if(!ISATOM(x))
   return 3;   /* x has to be an atom */
SETVALUE(x,a);
err = deval(f,&fa);    /* compute f(a) */
if(err)
   return 4;
SETVALUE(x,b);
err = deval(f,&fb);
if(err)
   return 4;
if(SAMESIGN(fa,fb))
   return (1);   /* error 1 means root isn't bracketed */
fc=fb;
for(iter=1;iter<=ITMAX;iter++)
   { if(SAMESIGN(fb,fc))
        { c=a;
          fc=fa;
          e=d=b-a;
        }
     if (fabs(fc) < fabs(fb) )
        { a=b;
          b=c;
          c=a;
          fa=fb;
          fb=fc;
          fc=fa;
        }
     tol1=2.0 * EPS * fabs(b) + 0.5 * tol;
     xm = 0.5*(c-b);
     if (fabs(xm) <= tol1 || fb == 0.0)
        { *ans = b;
          return(0);
        }
     if (fabs(e) >= tol1 && fabs(fa) > fabs(fb))
        { s = fb/fa;
          if( a == c)
             { p = 2.0*xm *s;
               q = 1.0 -s;
             }
          else
             { q = fa/fc;
               r=fb/fc;
               p=s*(2.0*xm*q*(q-r) - (b-a)*(r-1.0));
               q = (q-1.0)*(r-1.0)*(s-1.0);
             }
          if (p > 0.0)
             q = -q;
          p=fabs(p);
          min1 = 3.0 * xm*q -fabs(tol1*q);
          min2 = fabs(e*q);
          if(2.0*p < (min1 < min2 ? min1 : min2))
             { e=d;
               d= p/q;
             }
          else
             { d =xm;
               e=d;
             }
        }
     else
        { d=xm;
          e=d;
        }
     a= b;
     fa=fb;
     if (fabs(d) > tol1)
        b +=d;
     else
        b += (xm > 0.0 ? fabs(tol1) : -fabs(tol1));
     SETVALUE(x,b);
     err = deval(f,&fb);
     if(err)
        return 4;
   }
return 2; /* error 2 means more than ITMAX iterations without convergence */
}