Sindbad~EG File Manager
/* MATHPERT's EXACT ARITHMETIC "numerical" matrix manipulation package */
/* M. Beeson
Original date 7.10.90
6.14.98 modified
5.5.13 made make_matrix static
1.5.15 corrected matrix_negate
*/
#include <assert.h>
#include <stdlib.h>
#include <math.h> /* fabs */
#include "globals.h"
#include "matrix.h"
#include "matrix.h"
#include "pvalaux.h"
#include "deval.h"
#include "polynoms.h" /* set_types */
#define ENTRYPTR(i,j,t) (ARGPTR(ARG((i),(t))) + (j))
#define ROWS(a) ARITY(a)
#define COLUMNS(a) ARITY(ARG(0,a))
static int ratdet(term, term*);
static int backsub(term,int *,term);
static int column(term,int,term *);
static int doubledet(term t, term *ans);
static term make_matrix(unsigned short n, unsigned short m);
static term make_matrix(unsigned short n, unsigned short m)
/* create a new matrix with n rows and m columns */
{ term ans;
unsigned i;
ans = make_term(MATRIX,n);
for(i=0;i<n;i++)
ARGREP(ans,i,make_term(VECTOR,m));
return ans;
}
term make_identity( unsigned short n) /* make an n by n identity matrix */
{ term ans;
unsigned short i,j;
ans = make_matrix(n,n);
for(i=0;i<n;i++)
for(j=0;j<n;j++)
ENTRY(i,j,ans) = (i==j ? one: zero);
return ans;
}
/*_____________________________________________________________*/
static int set_type( term *t)
/* set the type info in *t if *t is a number; return 0
for success; return 1 for a non-number.
*/
{ int err;
term u;
if(OBJECT(*t))
return 0; /* nothing to do, type info is set already */
if(NEGATIVE(*t))
{ err = set_type(ARGPTR(*t));
if(err)
return err;
SETTYPE(*t, TYPE(ARG(0,*t)));
return 0;
}
if(!RATIONALP(*t))
return 1;
/* but the num and denom may not be in lowest terms, and
even if they are, one may be a bignum and the other not */
value(*t,&u);
if(!equals(*t,u))
return 1;
SETTYPE(*t,TYPE(u));
return 0;
}
/*_____________________________________________________________*/
int lu( term a, int *indx, int *d)
/* if a is a matrix, it will be replaced by its LU decomposition,
calculated "in place "; that is, old entries of a will be destroyed.
The entries must be numbers, that is, Mathpert objects or rational
numbers or negations thereof. If the type info is not correctly set in
the info field of the entries, it will be set here; so this function
can affect the (info fields of) the entries of a matrix on which it is called.
*d will be the sign of the determinant
indx will be an array of n integers to record the row permutation
Space must be allocated to *indx BEFORE it's passed to lu()
Uses Crout's method with implicit scaling, from
Numerical recipes in C, p. 43, but adapted to exact arithmetic
There are two errors and an inefficiency in the program in
Numerical Recipes (which cost several hours to identify as errors in
THEIR program and correct!), as noted in my copy of Numerical Recipes
Return 53 for a singular matrix. Return 1 for out of space.
Return 64 for non-numerical entries. Return 58 for a non-square matrix.
*/
{ unsigned n = ROWS(a);
unsigned m = COLUMNS(a);
term big,dum,sum,temp;
term prod, minprod,newsum;
short c;
term *vv;
unsigned i,j,imax,k;
int err;
if (n != m)
return 58; /* Matrix must be square */
/* check for numerical entries and set type info */
for(i=0;i<n;i++)
{ for(j=0;j<n;j++)
{ err = set_type(ENTRYPTR(i,j,a));
if(err)
return 64;
}
}
vv = (term *) callocate(n,sizeof(term));
if(vv == NULL)
return 1;
/* Begin LU decomposition routine, which works "in place" */
*d = 1;
for(i=0;i<n; i++)
{ big = zero;
for(j=0;j<n;j++)
{ temp = ENTRY(i,j,a);
if(NEGATIVE(temp))
temp = ARG(0,temp);
if(tcompare(temp,big,&c))
return 1;
if(c > 0)
big = temp;
}
if (ZERO(big))
return 53; /* matrix is singular */
if (FUNCTOR(big)== '/' && ZERO(ARG(0,big)))
return 53;
err = cdivide(one,big,vv + i);
if(err)
return 1;
}
for(j=0; j<n;j++) /* main loop over columns of Crout's method */
{ for(i=0; i<j;i++) /* equation 2.3.12 of Numerical Methods except i=j */
{ sum = ENTRY(i,j,a);
for(k=0;k<i;k++)
{ cmult(ENTRY(i,k,a),ENTRY(k,j,a),&prod);
cnegate(prod,&minprod);
if(cadd(sum,minprod,&newsum))
return 1;
if(k>0)
destroy_term(sum); /* created by cadd on last iteration */
if(NEGATIVE(prod))
destroy_term(prod); /* created by cmult */
else
destroy_term(minprod); /* created by cmult and cnegate */
sum = newsum;
}
if(i>0)
destroy_term(ENTRY(i,j,a));
/* all old entries should be destroyed,
but if i==0 sum and this entry still share space */
ENTRY(i,j,a) = sum;
}
big = zero; /* initialize search for largest pivot element */
imax = j;
for(i=j;i<n;i++) /* equation 2.3.13 (and i=j of 2.3.12) */
{ sum = ENTRY(i,j,a);
for(k=0;k<j;k++)
{ if(cmult(ENTRY(i,k,a),ENTRY(k,j,a),&prod))
return 1;
negate(prod,&minprod);
if(cadd(sum,minprod,&newsum))
return 1;
if(k>0)
destroy_term(sum); /* created by cadd on last iteration */
if(NEGATIVE(prod))
destroy_term(prod);
else
destroy_term(minprod);
sum = newsum;
}
if(j>0)
destroy_term(ENTRY(i,j,a));
/* but if j==0 sum and ENTRY(i,j,a) share space */
ENTRY(i,j,a) = sum;
if(cmult(vv[i], (NEGATIVE(sum) ? ARG(0,sum) : sum),&dum))
return 1;
if(tcompare(dum,big,&c))
return 1;
if(c > 0)
{ big = dum;
imax = i;
}
}
if (j !=imax) /* Do we need to interchange rows? */
{ for (k=0; k<n; k++)
{ dum = ENTRY(imax,k,a); /* yes, switch rows */
ENTRY(imax,k,a) = ENTRY(j,k,a);
ENTRY(j,k,a)=dum;
}
*d = - (*d); /* and change the sign of d */
temp = vv[imax]; /* Numerical Recipes forgot this */
vv[imax] = vv[j]; /* and interchange the scale factors */
vv[j] = temp; /* Numerical Recipes forgot this */
}
indx[j] = imax;
indx[imax] = j; /* Numerical Recipes forgot this */
if(ZERO(ENTRY(j,j,a)))
return 53; /* matrix is singular */
if(FUNCTOR(ENTRY(j,j,a))== '/' && ZERO(ARG(0,ENTRY(j,j,a))))
return 53;
if (j != n-1)
{ if(cdivide(one,ENTRY(j,j,a),&dum))
return 1;
for(i=j+1;i<n;i++)
{ if(cmult(ENTRY(i,j,a),dum,&prod))
return 1;
destroy_term(ENTRY(i,j,a));
ENTRY(i,j,a) = prod;
}
}
}
free2(vv);
return 0;
}
/*___________________________________________________________________*/
static term scalarmult3(term c, term v)
/* multiply a numerical vector v by a scalar c,
returning a vector */
{ unsigned short i,n = ARITY(v);
term ans = make_term(VECTOR,n);
assert(FUNCTOR(v)== VECTOR);
for(i=0;i<n;i++)
value(product(c,ARG(i,v)),ARGPTR(ans)+i);
return ans;
}
/*____________________________________________________________*/
static term matrix_cleardenoms(term t, term *c)
/* t is a VECTOR or MATRIX whose entries are (signed) rationals or
integers. Write t = c * ans where c is a rational number and
ans is an integer-entried matrix. Return ans.
*/
{ unsigned short f = FUNCTOR(t);
unsigned short n = ARITY(t);
unsigned short r,i;
term u,v,w,q;
int err;
if(f == VECTOR)
{ u = t;
SETFUNCTOR(u,'+',n);
err= naivecomdenom(u,&v);
if(err)
{ *c = one;
return t;
}
if(FRACTION(v))
{ *c = reciprocal(ARG(1,v));
u = ARG(0,v);
assert(FUNCTOR(u) == '+' && ARITY(u) == n);
SETFUNCTOR(u,f,n);
return u;
}
if(NEGATIVE(v) && FRACTION(ARG(0,v)))
{ *c = tnegate(reciprocal(ARG(1,ARG(0,v))));
u = ARG(0,ARG(0,v));
assert(FUNCTOR(u) == '+' && ARITY(u) == n);
SETFUNCTOR(u,f,n);
return u;
}
*c = one;
return u;
}
else
{ assert(f == MATRIX);
r = ROWS(t);
u = make_term('+',r);
v = make_term(MATRIX,r);
for(i=0;i<r;i++)
ARGREP(v,i,matrix_cleardenoms(ARG(i,t),ARGPTR(u) +i));
/* Now you have all the denominators in u */
naivecomdenom(u,&w);
if(NEGATIVE(w) && FRACTION(ARG(0,w)))
w = make_fraction(strongnegate(ARG(0,ARG(0,w))),ARG(1,ARG(0,w)));
if(FRACTION(w))
*c = reciprocal(ARG(1,w));
else
*c = one;
/* Now the entries in the i-th row have to be multiplied
by something. At present we have ARG(i,t) == ARG(i,u) * ARG(i,v);
we want to have ARG(i,t) == *c * ARG(i,v), so
ARG(i,v) has to be multiplied by ARG(i,u)/ *c
*/
for(i=0;i<r;i++)
{ value(make_fraction(ARG(i,u),*c),&q);
ARGREP(v,i,scalarmult3(q,ARG(i,v)));
}
RELEASE(u);
return v;
}
}
/*___________________________________________________________________*/
int determinant(term a, term *ans)
/* compute the determinant of matrix a, returning it as a term in *ans */
/* the entries must be (signed) doubles, bignums, ints, or rationals */
/* if any entry is a double, use the routine from Numerical Recipes. */
/* Otherwise factor out the denominators, if any, and make a recursive
call to get the determinant of the integer-coefficient matrix that results.
If all coefficients are integers (or bignums) then call ratdet */
/* Return 0 for success, 1 for illegal input, 2 for floating-point
arithmetic overflow or underflow */
{ int n,m; /* n rows and m columns */
int i,j,err;
unsigned flag = INTEGER;
term u,c;
if(FUNCTOR(a) != MATRIX)
return 1;
n = ROWS(a);
m = COLUMNS(a);
if(n != m)
return 1; /* only square matrices have determinants */
/* are the entries numerical? */
for(i=0;i<n;i++)
{ for(j=0;j<m;j++)
{ u = ENTRY(i,j,a);
if(NEGATIVE(u))
u = ARG(0,u);
if(OBJECT(u) && TYPE(u) == DOUBLE)
flag = DOUBLE;
else if(FRACTION(u) && INTEGERP(ARG(0,u)) && INTEGERP(ARG(1,u)))
flag = RATIONAL;
else if(!OBJECT(u))
return 63; /* index to arithmsg */
}
}
if(flag == INTEGER)
return ratdet(a,ans);
if(flag == DOUBLE)
return doubledet(a,ans);
if(flag == RATIONAL)
{ u = matrix_cleardenoms(a,&c);
err = ratdet(u,ans);
if(err)
return 1;
value(product(make_power(c,make_int(n)),*ans),ans);
return 0;
}
assert(0);
return 1;
}
/*____________________________________________________________________*/
static int ratdet( term input, term *ans)
/* compute the determinant of matrix 'input'
using exact rational arithmetic */
/* The matrix must contain integer, bignum, rational, or bigrat entries only */
/* But for efficiency of computation, you ought to clear the denominators
first and use this only for matrices with integer coefficients. Otherwise
the denominators kill you, as in gcd computations.
*/
{ unsigned short i,n,m;
term a,prod,temp;
int *indx;
int err;
int sign;
if(FUNCTOR(input) != MATRIX)
return 54; /* determinant only defined for matrices */
n= ROWS(input);
m= COLUMNS(input);
if(n != m)
return 52; /* matrix must be square */
indx = (int *) callocate(n,sizeof(int));
if(indx==NULL)
return 1;
set_types(&input); /* make sure type bits are set on negative numbers
so arithmetic will work */
copy(input,&a);
err = lu(a, indx, &sign);
if(err == 53)
{ /* matrix is singular */
*ans = zero;
return 0;
}
if(err)
{ free2(indx);
return 1;
}
prod = ENTRY(0,0,a);
for(i=1;i<n;i++)
{ if(i & 1)
cmult(prod,ENTRY(i,i,a),&temp);
else
cmult(temp,ENTRY(i,i,a),&prod);
}
if(n&1 && sign > 0)
{ *ans = prod;
destroy_term(temp);
}
else if(sign> 0)
{ *ans = temp;
destroy_term(prod);
}
else if(n&1 && sign < 0)
{ cnegate(prod,ans);
destroy_term(temp);
}
else if(sign < 0)
{ cnegate(temp,ans);
destroy_term(prod);
}
free2(indx);
return 0;
}
/*_________________________________________________________________*/
static int backsub(term a, int *indx, term b)
/* a must be the LU decomposition of a matrix A produced by lu();
*indx is also produced by lu(), and allocated before lu is called;
b is input as a VECTOR, the right-hand side of an equation Ax=b;
and it will be replaced by the solution vector x;
*/
{ int i,ii= -1,ip,j;
int n = ROWS(a);
int err;
term sum,prod,minprod,newsum;
for(i=0;i<n;i++)
{ ip = indx[i];
sum = ARG(ip,b);
ARGREP(b,ip,ARG(i,b));
if (ii >= 0)
{ for (j=ii;j<i; j++)
{ err = cmult(ENTRY(i,j,a),ARG(j,b),&prod);
if(err)
return err;
cnegate(prod,&minprod);
err = cadd(sum,minprod,&newsum);
if(err)
return err;
if(NEGATIVE(minprod))
destroy_term(minprod);
else destroy_term(prod);
if(j > ii)
destroy_term(sum);
sum = newsum;
}
}
else if( (TYPE(sum)==INTEGER && INTDATA(sum) != 0) /* if (sum) */
||(TYPE(sum)==BIGNUM
&& (BIGNUMDATA(sum).ln > 1 || BIGNUMDATA(sum).val[0] != 0)
)
)
ii=i;
ARGREP(b,i,sum);
}
for(i=n-1; i >= 0; i--)
{ sum = ARG(i,b);
for( j = i+1; j< n;j++)
{ err = cmult(ENTRY(i,j,a),ARG(j,b),&prod);
if(err)
return err;
cnegate(prod,&minprod);
err=cadd(sum, minprod,&newsum);
if(err)
return err;
if(NEGATIVE(minprod))
destroy_term(minprod);
else
destroy_term(prod);
if(j>i+1)
destroy_term(sum);
sum = newsum;
}
err = cdivide(sum,ENTRY(i,i,a),&newsum);
if(err)
return err;
destroy_term(sum);
ARGREP(b,i,newsum);
}
return 0;
}
/*_________________________________________________________________*/
int matrix_inverse(term input, int flag, term *ans)
/* inverse of matrix 'input' will be returned in fresh space in *ans, if
a is invertible. If not an error value of 53 will be returned. If flag
is nonzero, the input will be destroyed (and the routine may run a bit
faster, and in less space).
*/
{ unsigned short n = ROWS(input);
unsigned short m = COLUMNS(input);
int i,j, *indx,d;
int err;
term col,a;
if(n != m)
return 58; /* attempt to invert a non-square matrix */
*ans = make_matrix(n,n);
if(flag==0)
copy(input,&a); /* make space for the answer */
else a=input; /* which will be destroyed by lu */
indx = (int *) callocate(n,sizeof(int));
if(indx==NULL)
{ nospace();
return 49;
}
err = lu(a, indx, &d); /* calculate the LU decomposition */
if(err)
return err;
col = make_term(VECTOR,n);
for(j=0; j<n; j++)
{ for(i=0;i<n;i++)
ARGREP(col,i,zero);
ARGREP(col,j,one);
backsub(a,indx,col);
for(i=0;i<n;i++)
ENTRY(i,j,*ans)=ARG(i,col);
}
return 0;
}
/*_________________________________________________________________*/
int matrix_add(term a, term b, term *ans)
/* a and b must be matrices or vectors of the same dimension */
{ unsigned short n,m,i;
int err;
int noval = 0;
if(FUNCTOR(a) != FUNCTOR(b)) return 55; /* dimensions wrong */
if(FUNCTOR(a)==MATRIX)
{ n = ROWS(a);
m = COLUMNS(a);
*ans = make_term(MATRIX,n);
if(n != ROWS(b) || m != COLUMNS(b))
return 55;
for(i=0;i<n;i++)
{ err = matrix_add(ARG(i,a),ARG(i,b),ARGPTR(*ans) + i);
if(err!=0 && err !=2)
return err;
if(err==2)
noval=2;
}
if(!noval) SETAE(*ans);
return noval;
}
if(FUNCTOR(a)==VECTOR)
{ n = ARITY(a);
*ans = make_term(VECTOR,n);
for(i=0;i<n;i++)
{ err = cadd(ARG(i,a),ARG(i,b),ARGPTR(*ans)+i);
if(err!=0 && err !=2)
return err;
if(err==2)
noval=2;
}
if(!noval)
SETAE(*ans);
return noval;
}
return 0; /* can't get here, but keep Turbo C happy */
}
/*_________________________________________________________________*/
int matrix_mult(term a, term b, term *ans)
/* a and b must be matrices or vectors of the right dimensions */
/* On vectors, it performs dot product */
/* It multiplies a vector by a matrix either on right or left */
/* Uses complex arithmetic and on non-numerical entries uses polyval */
/* Instead of a one-by-one matrix it returns the entry; instead of
a one-column matrix it returns a vector */
{ unsigned short n,m,i,j,k,q;
int err, noval = 0;
term temp1,temp2,prod,u,v;
if(FUNCTOR(a)==MATRIX && FUNCTOR(b)==MATRIX)
{ n = ROWS(a);
m = COLUMNS(a);
q = COLUMNS(b);
if(n == 1) /* only one row, use the vector for that row instead of a */
return matrix_mult(ARG(0,a),b,ans);
*ans = make_matrix(n,q);
if(m != ROWS(b))
return 56;
for(i=0;i<n;i++)
for(j=0;j<q;j++)
{ temp1 = zero;
temp2 = zero; /* not necessary but it quiets a Turbo C warning */
for(k=0;k<m;k++) /* add up a[i,k]*b[k,j] as k varies */
{ u = ENTRY(i,k,a);
v = ENTRY(k,j,b);
if(ZERO(u) || ZERO(v))
prod = zero;
else
{ err = cmult(u,v,&prod);
if(err != 0 && err != 2)
polyval(product(u,v),&prod);
if(err==2)
noval = 2;
}
if(k&1)
{ err = cadd(temp2,prod,&temp1);
if(err != 0 && err != 2)
polyval(sum(temp2,prod),&temp1);
if(err==2)
noval = 2;
destroy_term(temp2);
destroy_term(prod);
}
else
{ err = cadd(temp1,prod,&temp2);
if(err != 0 && err != 2)
polyval(sum(temp1,prod),&temp2);
if(err==2)
noval = 2;
destroy_term(temp1);
destroy_term(prod);
}
}
if(m&1)
ENTRY(i,j,*ans) = temp2;
else
ENTRY(i,j,*ans) = temp1;
}
if(!noval)
SETAE(*ans);
return noval;
} /* close 'if both are matrices' */
if(FUNCTOR(a)==VECTOR && FUNCTOR(b)==VECTOR) /* compute the dot product */
{ n = ARITY(a);
m = ARITY(b);
if(n!=m)
return 57;
temp1 = zero;
for(k=0;k<n;k++) /* add up a[kl]*b[k] as k varies */
{ err= cmult(ARG(k,a),ARG(k,b),&prod);
if(err != 0 && err != 2)
polyval(product(ARG(k,a),ARG(k,b)),&prod);
if(err!=0)
noval = 2;
if(k&1)
{ err = cadd(temp2,prod,&temp1);
if(err != 0 && err != 2)
polyval(sum(temp2,prod),&temp1);
if(err!=0)
noval = 2;
destroy_term(temp2);
destroy_term(prod);
}
else
{ err = cadd(temp1,prod,&temp2);
if(err != 0 && err != 2)
polyval(sum(temp1,prod),&temp2);
if(err!=0)
noval = 2;
destroy_term(temp1);
destroy_term(prod);
}
}
if(n&1)
*ans = temp2;
else
*ans = temp1;
if(!noval)
SETAE(*ans);
return noval;
}
if(FUNCTOR(a)==MATRIX && FUNCTOR(b)==VECTOR)
{ n = COLUMNS(a);
if(n!=ARITY(b))
return 56;
m = ROWS(a);
if(m==1)
{ /* answer will be a scalar, dot product of the
one row of a with b */
return matrix_mult(ARG(0,a),b,ans);
}
*ans = make_term(VECTOR,m);
for(k=0;k<m;k++) /* dot product of k-th row with b */
{ err = matrix_mult(ARG(k,a),b,ARGPTR(*ans)+k) ;
if(err!=0 && err != 2)
return err;
if(err==2)
noval = 2;
}
if(!noval)
SETAE(*ans);
return noval;
}
if(FUNCTOR(a)==VECTOR && FUNCTOR(b)==MATRIX)
{ n = ARITY(a);
if(n != ROWS(b))
return 56;
m = COLUMNS(b);
*ans = make_term(VECTOR,m);
for(k=0;k<m;k++) /* dot product of a with k-th column of b */
{ err = column(b,k,&temp1);
if(err)
return err;
err= matrix_mult(a,temp1,ARGPTR(*ans)+k);
RELEASE(temp1); /* created by columns,
which makes new space only for the headers */
if(err!= 0 && err != 2)
return err;
if(err==2)
noval=2;
}
if(m==1) /* return a scalar, not a vector of dimension 1 */
{ term temp = ARG(0,*ans);
RELEASE(*ans);
*ans = temp;
}
if(!noval)
SETAE(*ans);
return noval;
}
return 0; /* can't get here, but keep Turbo C happy */
}
/*____________________________________________________________________*/
static int column(term a, int k, term *ans)
/* create a new VECTOR representing the k-th column of matrix a */
/* using new space only for the headers */
/* if a is not a matrix, or if k >= the number of columns of a,
results will be unpredictable */
{ unsigned short i,n = ROWS(a);
*ans = make_term(VECTOR,n);
for(i=0;i<n;i++)
ARGREP(*ans,i,ENTRY(i,k,a));
return 0;
}
/*_____________________________________________________________________*/
void matrix_negate(term a, term *ans)
/* negate a matrix or vector */
/* does not put answer in entirely new space; makes new space for the
heads of the entries only */
{ unsigned short i, n = ARITY(a);
if(FUNCTOR(a)==VECTOR)
{ *ans = make_term(VECTOR,n);
for(i=0;i<n;i++)
{ cnegate(ARG(i,a), ARGPTR(*ans) + i);
}
if(AE(a))
SETAE(*ans);
return;
}
if(FUNCTOR(a)==MATRIX)
{ *ans = make_term(MATRIX,n);
for(i=0;i<n;i++)
matrix_negate(ARG(i,a),ARGPTR(*ans) + i);
if(AE(a))
SETAE(*ans);
return ;
}
}
/*_______________________________________________________________________*/
int scalar_mult(term a, term b, term *ans)
/* one of a or b should be a vector or matrix */
/* answer is returned in fresh space */
/* *ans should have its 'ae' bit set if all the args had values */
{ int err;
unsigned short n,m,i,j;
int noval = 0;
if(FUNCTOR(b)==MATRIX)
{ n = ROWS(b);
m = COLUMNS(b);
*ans = make_matrix(n,m);
for(i=0;i<n;i++)
for(j=0;j<n;j++)
{ err = cmult(a,ENTRY(i,j,b), ENTRYPTR(i,j,*ans));
if(err != 0 && err != 2)
return err;
if(err==2)
noval=2;
}
if(!noval)
SETAE(*ans);
return noval;
}
if(FUNCTOR(a)==MATRIX)
{ n = ROWS(a);
m = COLUMNS(b);
*ans = make_matrix(n,m);
for(i=0;i<n;i++)
for(j=0;j<n;j++)
{ err = cmult(ENTRY(i,j,a),b,ENTRYPTR(i,j,*ans));
if(err != 0 && err != 2)
return err;
if(err==2)
noval = 2;
}
if(!noval)
SETAE(*ans);
return noval;
}
if(FUNCTOR(b)==VECTOR)
{ n= ARITY(b);
*ans = make_term(VECTOR,n);
for(i=0;i<n;i++)
{ err = cmult(a,ARG(i,b),ARGPTR(*ans)+i);
if(err!=0 && err !=2)
return err;
if(err==2)
noval=2;
}
if(!noval)
SETAE(*ans);
return noval;
}
if(FUNCTOR(a)==VECTOR)
{ n= ARITY(a);
*ans = make_term(VECTOR,n);
for(i=0;i<n;i++)
{ err = cmult(ARG(i,a),b,ARGPTR(*ans)+i);
if(err!=0 && err !=2)
return err;
if(err==2)
noval=2;
}
if(!noval)
SETAE(*ans);
return noval;
}
return 0; /* can't get here, but keep Turbo C happy */
}
/*__________________________________________________________*/
int matrix_exponentiate(term u, long m, term *ans)
/* compute u^m where u is a matrix; m >= 0 */
{ term temp,q;
int i,err;
unsigned short k,n = ARITY(u);
q = make_identity(n);
if(m==0)
{ *ans = q;
return 0;
}
if(m==1)
{ copy(u,ans);
return 0;
}
k = bitlength(m);
for(i=k-1; i>=0; i--)
{ err= matrix_mult(q,q,&temp);
if(err)
return err;
destroy_term(q);
if( (m>>i) & 1 ) /* Turbo's -w requires these parens */
{ err = matrix_mult(temp,u,&q);
if(err)
return err;
destroy_term(temp);
}
else
q = temp;
}
*ans = q;
return 0;
}
/*_______________________________________________________________*/
int ludcmp(double **a,int n,int *indx,double *d)
/* Adapted from Numerical Recipes */
/* Errors in the published version corrected as shown in comments */
/* Return value 0 is success,
Return value 1 is 'singular matrix' */
{
int i,imax,j,k;
double big,dum,sum,temp;
double *vv;
vv = (double *) callocate(n+1,sizeof(double));
if(vv == NULL)
{ nospace();
return 49;
}
*d=1.0;
for (i=1;i<=n;i++)
{
big=0.0;
for (j=1;j<=n;j++)
{if ((temp=fabs(a[i][j])) > big)
big=temp;
}
if (big == 0.0)
return 1; /* singular matrix */
vv[i]=1.0/big;
}
for (j=1;j<=n;j++)
{
for (i=1;i<j;i++)
{ sum=a[i][j];
for (k=1;k<i;k++)
sum -= a[i][k]*a[k][j];
a[i][j]=sum;
}
big=0.0;
imax = j; /* added by Beeson, to go with change 6 lines below */
for (i=j;i<=n;i++)
{ sum=a[i][j];
for (k=1;k<j;k++)
sum -= a[i][k]*a[k][j];
a[i][j]=sum;
if ( (dum=vv[i]*fabs(sum)) > big)
/* published version has >= instead of > , not an
error but a waste of time */
{ big=dum;
imax=i;
}
}
if (j != imax)
{
for (k=1;k<=n;k++)
{ dum=a[imax][k];
a[imax][k]=a[j][k];
a[j][k]=dum;
}
*d = -(*d);
temp = vv[imax]; /* erroneously omitted in Numerical Recipes */
vv[imax]=vv[j];
vv[j] = temp; /* erroneously omitted in Numerical Recipes */
}
indx[j]=imax;
indx[imax] = j; /* erroneously omitted in Numerical Recipes */
if (a[j][j] == 0.0)
return 1; /* do not substitute 1.0e-20 as in Numerical Recipes */
if (j != n)
{ dum=1.0/(a[j][j]);
for (i=j+1;i<=n;i++)
a[i][j] *= dum;
}
}
free2(vv);
return 0; /* success */
}
/*___________________________________________________________________*/
static int doubledet(term t, term *ans)
/* t is a MATRIX whose entries are all seminumerical.
Evaluate the entries using deval (or ceval if t contains i).
Use ordinary numerical analysis computations to compute the
determinant, put the resulting double into *ans and return 0 for
success. If overflow or underflow occurs, signal by returning 2.
Return 1 for illegal input, 0 for success, 49 for out of space
(after calling nospace).
This starts out just like decimalmatrixinverse, but
finishes immediately after the call to ludcmp.
*/
{ unsigned short i,j,n;
int err;
double d;
double **a,**y;
double *col;
int *indx;
if(FUNCTOR(t) != MATRIX)
return 1;
if(ROWS(t) != COLUMNS(t))
return 1;
n = ROWS(t);
col = (double *) callocate(n+1,sizeof(double));
if(col==NULL)
{ nospace();
return 49;
}
indx = (int *) callocate(n+1,sizeof(int));
if(indx == NULL)
{ nospace();
return 49;
}
a = (double **) callocate(n+1, sizeof(double *));
if(a==NULL)
{ nospace();
return 49;
}
for(i=1;i<=n;i++)
{ a[i] = (double *) callocate(n+1,sizeof(double));
if(a[i]==NULL)
{ nospace();
return 49;
}
}
y = (double **) callocate(n, sizeof(double *));
if(y==NULL)
{ nospace();
return 49;
}
for(i=0;i<n;i++)
{ y[i] = (double *) callocate(n,sizeof(double));
if(y[i]==NULL)
{ nospace();
return 49;
}
}
/* Numerical Recipes wants subscripts that start at 1. That's we we
allocated n+1 instead of n spaces above. */
for(i=1;i<=n;i++)
{ for(j=1;j<=n;j++)
{ err = deval(ENTRY(i-1,j-1,t), &(a[i][j]));
if(err)
{ for(i=0;i<n;i++)
free2(y[i]);
for(i=1;i<=n;i++)
free2(a[i]);
free2(y); free2(a); free2(indx); free2(col);
return err;
}
}
}
/* Now decompose the decimal matrix a */
err = ludcmp(a,n,indx,&d); /* from Numerical Recipes; see p. 45 of the book */
if(err)
return err;
for(j=1;j<=n;j++)
d *= a[j][j]; /* FINISH THIS: check for overflow or underflow first */
*ans = make_double(d);
return 0;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists