#include #include #include #include #include "header.h" #include "funcs.h" #include "helpf.h" #include "matheh.h" #define wrong_arg() { error=26; output("Wrong argument\n"); return; } void minmax (double *x, LONG n, double *min, double *max, int *imin, int *imax) /***** minmax compute the total minimum and maximum of n double numbers. *****/ { LONG i; if (n==0) { *min=0; *max=0; *imin=0; *imax=0; return; } *min=*x; *max=*x; *imin=0; *imax=0; x++; for (i=1; i*max) { *max=*x; *imax=(int)i; } x++; } } void transpose (header *hd) /***** transpose transpose a matrix *****/ { header *hd1,*st=hd; double *m,*m1,*mh; int c,r,i,j; hd=getvalue(hd); if (error) return; if (hd->type==s_matrix) { getmatrix(hd,&r,&c,&m); hd1=new_matrix(c,r,""); if (error) return; m1=matrixof(hd1); for (i=0; itype==s_cmatrix) { getmatrix(hd,&r,&c,&m); hd1=new_cmatrix(c,r,""); if (error) return; m1=matrixof(hd1); for (i=0; itype==s_real || hd->type==s_complex) { hd1=hd; } else { error=24; output("\' not defined for this value!\n"); return; } moveresult(st,hd1); } void vectorize (header *init, header *step, header *end) { double vinit,vstep,vend,*m; int count; header *result,*st=init; init=getvalue(init); step=getvalue(step); end=getvalue(end); if (error) return; if (init->type!=s_real || step->type!=s_real || end->type!=s_real) { output("The : allows only real arguments!\n"); error=15; return; } vinit=*realof(init); vstep=*realof(step); vend=*realof(end); if (vstep==0) { output("A step size of 0 is not allowed in : "); error=401; return; } if (fabs(vend-vinit)/fabs(vstep)+1+epsilon>INT_MAX) { output1("A vector can only have %d elements",INT_MAX); error=402; return; } count=(int)(floor(fabs(vend-vinit)/fabs(vstep)+1+epsilon)); if ((vend>vinit && vstep<0) || (vend0)) count=0; result=new_matrix(1,count,""); if (error) return; m=matrixof(result); while (count>=0) { *m++=vinit; vinit+=vstep; count--; } moveresult(st,result); } void mfft (header *hd) { header *st=hd,*result; double *m,*mr; int r,c; hd=getvalue(hd); if (error) return; if (hd->type==s_real || hd->type==s_matrix) { make_complex(st); hd=st; } getmatrix(hd,&r,&c,&m); if (r!=1) wrong_arg(); result=new_cmatrix(1,c,""); mr=matrixof(result); memmove((char *)mr,(char *)m,(LONG)2*c*sizeof(double)); fft(mr,c,-1); moveresult(st,result); } void mifft (header *hd) { header *st=hd,*result; double *m,*mr; int r,c; hd=getvalue(hd); if (error) return; if (hd->type==s_real || hd->type==s_matrix) { make_complex(st); hd=st; } getmatrix(hd,&r,&c,&m); if (r!=1) wrong_arg(); result=new_cmatrix(1,c,""); mr=matrixof(result); memmove((char *)mr,(char *)m,(LONG)2*c*sizeof(double)); fft(mr,c,1); moveresult(st,result); } void mtridiag (header *hd) { header *result,*st=hd,*result1; double *m,*mr; int r,c,*rows,i; hd=getvalue(hd); if (error) return; if (hd->type==s_matrix) { getmatrix(hd,&c,&r,&m); if (c!=r || c==0) wrong_arg(); result=new_matrix(c,c,""); if (error) return; result1=new_matrix(1,c,""); if (error) return; mr=matrixof(result); memmove(mr,m,(LONG)c*c*sizeof(double)); tridiag(mr,c,&rows); mr=matrixof(result1); for (i=0; itype==s_cmatrix) { getmatrix(hd,&c,&r,&m); if (c!=r || c==0) wrong_arg(); result=new_cmatrix(c,c,""); if (error) return; result1=new_matrix(1,c,""); if (error) return; mr=matrixof(result); memmove(mr,m,(LONG)c*c*(LONG)2*sizeof(double)); ctridiag(mr,c,&rows); mr=matrixof(result1); for (i=0; itype==s_matrix) { getmatrix(hd,&c,&r,&m); if (c!=r || c==0) wrong_arg(); result=new_matrix(c,c,""); if (error) return; result1=new_matrix(1,c+1,""); if (error) return; mr=matrixof(result); memmove(mr,m,(LONG)c*c*sizeof(double)); charpoly(mr,c,matrixof(result1)); } else if (hd->type==s_cmatrix) { getmatrix(hd,&c,&r,&m); if (c!=r || c==0) wrong_arg(); result=new_cmatrix(c,c,""); if (error) return; result1=new_cmatrix(1,c+1,""); if (error) return; mr=matrixof(result); memmove(mr,m,(LONG)c*c*(LONG)2*sizeof(double)); ccharpoly(mr,c,matrixof(result1)); } else wrong_arg(); moveresult(st,result1); } void mscompare (header *hd) { header *st=hd,*hd1,*result; hd=getvalue(hd); hd1=getvalue(nextof(st)); if (error) return; if (hd->type==s_string && hd1->type==s_string) { result=new_real(strcmp(stringof(hd),stringof(hd1)),""); if (error) return; } else wrong_arg(); moveresult(st,result); } void mfind (header *hd) { header *st=hd,*hd1,*result; double *m,*m1,*mr; int i,j,k,c,r,c1,r1; hd=getvalue(hd); hd1=getvalue(nextof(st)); if (error) return; if ((hd->type!=s_matrix && hd->type!=s_real) || (hd1->type!=s_matrix && hd1->type!=s_real)) wrong_arg(); getmatrix(hd,&c,&r,&m); getmatrix(hd1,&c1,&r1,&m1); if (c!=1 && r!=1) wrong_arg(); if (r!=1) c=r; result=new_matrix(c1,r1,""); if (error) return; mr=matrixof(result); for (i=0; itype!=s_real) wrong_arg(); n=(int)*realof(hd1); if (hd->type==s_matrix || hd->type==s_real) { getmatrix(hd,&r,&c,&m); result=new_matrix(1,r,""); if (error) return; mr=matrixof(result); l=0; for (i=0; i=c) break; if (i+n>=0) { l++; *mr++=*mat(m,c,i,i+n); } } dimsof(result)->c=l; result->size=matrixsize(1,c); } else if (hd->type==s_cmatrix || hd->type==s_complex) { getmatrix(hd,&r,&c,&m); result=new_cmatrix(1,r,""); if (error) return; mr=matrixof(result); l=0; for (i=0; i=c) break; if (i+n>=0) { l++; mh=cmat(m,c,i,i+n); *mr++=*mh++; *mr++=*mh; } } dimsof(result)->c=l; result->size=cmatrixsize(1,c); } else wrong_arg(); moveresult(st,result); } void mband (header *hd) { header *st=hd,*hd1,*hd2,*result; int i,j,c,r,n1,n2; double *m,*mr; hd1=next_param(hd); hd2=next_param(hd1); hd=getvalue(hd); hd1=getvalue(hd1); hd2=getvalue(hd2); if (error) return; if (hd1->type!=s_real || hd2->type!=s_real) wrong_arg(); n1=(int)*realof(hd1); n2=(int)*realof(hd2); if (hd->type==s_matrix || hd->type==s_real) { getmatrix(hd,&r,&c,&m); result=new_matrix(r,c,""); if (error) return; mr=matrixof(result); for (i=0; i=n1 && j-i<=n2) *mr++=*m++; else { *mr++=0.0; m++; } } } else if (hd->type==s_cmatrix || hd->type==s_complex) { getmatrix(hd,&r,&c,&m); result=new_cmatrix(r,c,""); if (error) return; mr=matrixof(result); for (i=0; i=n1 && j-i<=n2) { *mr++=*m++; *mr++=*m++; } else { *mr++=0.0; *mr++=0.0; m+=2; } } } else wrong_arg(); moveresult(st,result); } void mdup (header *hd) { header *result,*st=hd,*hd1; double x,*m,*m1,*m2; int c,i,n,j,r; hd=getvalue(hd); hd1=next_param(st); if (!hd1) wrong_arg(); hd1=getvalue(hd1); if (error) return; if (hd1->type!=s_real) wrong_arg(); x=*realof(hd1); n=(int)x; if (n<1 || x>=INT_MAX) wrong_arg(); if (hd->type==s_matrix && dimsof(hd)->r==1) { c=dimsof(hd)->c; result=new_matrix(n,c,""); if (error) return; m1=matrixof(hd); m2=matrixof(result); for (i=0; itype==s_matrix && dimsof(hd)->c==1) { r=dimsof(hd)->r; result=new_matrix(r,n,""); if (error) return; m1=matrixof(hd); m2=matrixof(result); for (i=0; itype==s_real) { result=new_matrix(n,1,""); if (error) return; m1=matrixof(result); for (i=0; itype==s_cmatrix && dimsof(hd)->r==1) { c=dimsof(hd)->c; result=new_cmatrix(n,c,""); if (error) return; m1=matrixof(hd); m2=matrixof(result); for (i=0; itype==s_cmatrix && dimsof(hd)->c==1) { r=dimsof(hd)->r; result=new_cmatrix(r,n,""); if (error) return; m1=matrixof(hd); m2=matrixof(result); for (i=0; itype==s_complex) { result=new_cmatrix(n,1,""); if (error) return; m1=matrixof(result); for (i=0; itype==s_real) { size=sizeof(header)+2*sizeof(double); nextarg=nextof(old); if (newram+(size-old->size)>ramend) { output("Memory overflow!\n"); error=180; return; } if (newram>(char *)nextarg) memmove((char *)old+size,(char *)nextarg, newram-(char *)nextarg); newram+=size-old->size; *(old->name)=0; old->size=size; old->type=s_complex; *realof(old)=*realof(hd); *imagof(old)=0.0; } else if (hd->type==s_matrix) { getmatrix(hd,&r,&c,&m); size=cmatrixsize(r,c); nextarg=nextof(old); if (newram+(size-old->size)>ramend) { output("Memory overflow!\n"); error=180; return; } if (newram>(char *)nextarg) memmove((char *)old+size,(char *)nextarg, newram-(char *)nextarg); newram+=size-old->size; *(old->name)=0; old->size=size; old->type=s_cmatrix; dimsof(old)->r=r; dimsof(old)->c=c; m1=matrixof(old); for (i=r-1; i>=0; i--) for (j=c-1; j>=0; j--) { *cmat(m1,c,i,j)=*mat(m,c,i,j); *(cmat(m1,c,i,j)+1)=0.0; } } } void mvconcat (header *hd) { header *st=hd,*hd1,*result; double *m,*m1; int r,c,r1,c1; size_t size=0; hd=getvalue(hd); hd1=next_param(st); if (!hd1) wrong_arg(); hd1=getvalue(hd1); if (error) return; if (hd->type==s_real || hd->type==s_matrix) { if (hd1->type==s_real || hd1->type==s_matrix) { getmatrix(hd,&r,&c,&m); getmatrix(hd1,&r1,&c1,&m1); if (r!=0 && (c!=c1 || (LONG)r+r1>INT_MAX)) wrong_arg(); result=new_matrix(r+r1,c1,""); if (r!=0) { size=(LONG)r*c*sizeof(double); memmove((char *)matrixof(result),(char *)m, size); } memmove((char *)matrixof(result)+size, (char *)m1,(LONG)r1*c1*sizeof(double)); } else if (hd1->type==s_complex || hd1->type==s_cmatrix) { make_complex(st); mvconcat(st); return; } else wrong_arg(); } else if (hd->type==s_complex || hd->type==s_cmatrix) { if (hd1->type==s_complex || hd1->type==s_cmatrix) { getmatrix(hd,&r,&c,&m); getmatrix(hd1,&r1,&c1,&m1); if (r!=0 && (c!=c1 || (LONG)r+r1>INT_MAX)) wrong_arg(); result=new_cmatrix(r+r1,c1,""); if (r!=0) { size=(LONG)r*(LONG)2*c*sizeof(double); memmove((char *)matrixof(result),(char *)m, size); } memmove((char *)matrixof(result)+size, (char *)m1,(LONG)r1*(LONG)2*c1*sizeof(double)); } else if (hd1->type==s_real || hd1->type==s_matrix) { make_complex(next_param(st)); mvconcat(st); return; } else wrong_arg(); } else wrong_arg(); moveresult(st,result); } void mhconcat (header *hd) { header *st=hd,*hd1,*result; double *m,*m1,*mr; int r,c,r1,c1,i; hd=getvalue(hd); hd1=next_param(st); if (!hd1) wrong_arg(); hd1=getvalue(hd1); if (error) return; if (hd->type==s_string && hd1->type==s_string) { result=new_string(stringof(hd), strlen(stringof(hd))+strlen(stringof(hd1))+1,""); strcat(stringof(result),stringof(hd1)); } else if (hd->type==s_real || hd->type==s_matrix) { if (hd1->type==s_real || hd1->type==s_matrix) { getmatrix(hd,&r,&c,&m); getmatrix(hd1,&r1,&c1,&m1); if (c!=0 && (r!=r1 || (LONG)c+c1>INT_MAX)) wrong_arg(); result=new_matrix(r1,c+c1,""); mr=matrixof(result); for (i=0; itype==s_complex || hd1->type==s_cmatrix) { make_complex(st); mhconcat(st); return; } else wrong_arg(); } else if (hd->type==s_complex || hd->type==s_cmatrix) { if (hd1->type==s_complex || hd1->type==s_cmatrix) { getmatrix(hd,&r,&c,&m); getmatrix(hd1,&r1,&c1,&m1); if (c!=0 && (r!=r1 || (LONG)c+c1>INT_MAX)) wrong_arg(); result=new_cmatrix(r1,c+c1,""); mr=matrixof(result); for (i=0; itype==s_real || hd1->type==s_matrix) { make_complex(next_param(st)); if (error) return; mhconcat(st); return; } else wrong_arg(); } else wrong_arg(); moveresult(st,result); } void cscalp (double *s, double *si, double *x, double *xi, double *y, double *yi); void ccopy (double *y, double *x, double *xi); void wmultiply (header *hd) /***** multiply matrix multiplication for weakly nonzero matrices. *****/ { header *result,*st=hd,*hd1; dims *d,*d1; double *m,*m1,*m2,*mm1,*mm2,x,y,null=0.0; int i,j,c,r,k; hd=getvalue(hd); hd1=getvalue(nextof(st)); if (error) return; if (hd->type==s_matrix && hd1->type==s_matrix) { d=dimsof(hd); d1=dimsof(hd1); if (d->c != d1->r) { error=8; output("Cannot multiply these!\n"); return; } r=d->r; c=d1->c; result=new_matrix(r,c,""); if (error) return; m=matrixof(result); m1=matrixof(hd); m2=matrixof(hd1); for (i=0; ic,i,0); mm2=m2+j; x=0.0; for (k=0; kc; k++) { if ((*mm1!=0.0)&&(*mm2!=0.0)) x+=(*mm1)*(*mm2); mm1++; mm2+=d1->c; } *mat(m,c,i,j)=x; } moveresult(st,result); return; } if (hd->type==s_matrix && hd1->type==s_cmatrix) { d=dimsof(hd); d1=dimsof(hd1); if (d->c != d1->r) { error=8; output("Cannot multiply these!\n"); return; } r=d->r; c=d1->c; result=new_cmatrix(r,c,""); if (error) return; m=matrixof(result); m1=matrixof(hd); m2=matrixof(hd1); for (i=0; ic,i,0); mm2=m2+(LONG)2*j; x=0.0; y=0.0; for (k=0; kc; k++) { if ((*mm2!=0.0 || *(mm2+1)!=0.0) && (*mm1!=0.0)) cscalp(&x,&y,mm1,&null,mm2,mm2+1); mm1++; mm2+=2*d1->c; } ccopy(cmat(m,c,i,j),&x,&y); } moveresult(st,result); return; } if (hd->type==s_cmatrix && hd1->type==s_matrix) { d=dimsof(hd); d1=dimsof(hd1); if (d->c != d1->r) { error=8; output("Cannot multiply these!\n"); return; } r=d->r; c=d1->c; result=new_cmatrix(r,c,""); if (error) return; m=matrixof(result); m1=matrixof(hd); m2=matrixof(hd1); for (i=0; ic,i,0); mm2=m2+j; x=0.0; y=0.0; for (k=0; kc; k++) { if ((*mm2!=0.0) && (*mm1!=0.0 || *(mm1+1)!=0.0)) cscalp(&x,&y,mm1,mm1+1,mm2,&null); mm1+=2; mm2+=d1->c; } ccopy(cmat(m,c,i,j),&x,&y); } moveresult(st,result); return; } if (hd->type==s_cmatrix && hd1->type==s_cmatrix) { d=dimsof(hd); d1=dimsof(hd1); if (d->c != d1->r) { error=8; output("Cannot multiply these!\n"); return; } r=d->r; c=d1->c; result=new_cmatrix(r,c,""); if (error) return; m=matrixof(result); m1=matrixof(hd); m2=matrixof(hd1); for (i=0; ic,i,0); mm2=m2+(LONG)2*j; x=0.0; y=0.0; for (k=0; kc; k++) { if ((*mm2!=0.0 || *(mm2+1)!=0.0) && (*mm1!=0.0 || *(mm1+1)!=0.0)) cscalp(&x,&y,mm1,mm1+1,mm2,mm2+1); mm1+=2; mm2+=2*d1->c; } ccopy(cmat(m,c,i,j),&x,&y); } moveresult(st,result); return; } else wrong_arg(); } void smultiply (header *hd) /***** multiply matrix multiplication for weakly nonzero symmetric matrices. *****/ { header *result,*st=hd,*hd1; dims *d,*d1; double *m,*m1,*m2,*mm1,*mm2,x,y,null=0.0; int i,j,c,r,k; hd=getvalue(hd); hd1=getvalue(nextof(st)); if (error) return; if (hd->type==s_matrix && hd1->type==s_matrix) { d=dimsof(hd); d1=dimsof(hd1); if (d->c != d1->r) { error=8; output("Cannot multiply these!\n"); return; } r=d->r; c=d1->c; result=new_matrix(r,c,""); if (error) return; m=matrixof(result); m1=matrixof(hd); m2=matrixof(hd1); for (i=0; ic,i,0); mm2=m2+j; x=0.0; for (k=0; kc; k++) { if ((*mm1!=0.0)&&(*mm2!=0.0)) x+=(*mm1)*(*mm2); mm1++; mm2+=d1->c; } *mat(m,c,i,j)=x; *mat(m,c,j,i)=x; } moveresult(st,result); return; } if (hd->type==s_matrix && hd1->type==s_cmatrix) { d=dimsof(hd); d1=dimsof(hd1); if (d->c != d1->r) { error=8; output("Cannot multiply these!\n"); return; } r=d->r; c=d1->c; result=new_cmatrix(r,c,""); if (error) return; m=matrixof(result); m1=matrixof(hd); m2=matrixof(hd1); for (i=0; ic,i,0); mm2=m2+(LONG)2*j; x=0.0; y=0.0; for (k=0; kc; k++) { if ((*mm2!=0.0 || *(mm2+1)!=0.0) && (*mm1!=0.0)) cscalp(&x,&y,mm1,&null,mm2,mm2+1); mm1++; mm2+=2*d1->c; } ccopy(cmat(m,c,i,j),&x,&y); y=-y; ccopy(cmat(m,c,j,i),&x,&y); } moveresult(st,result); return; } if (hd->type==s_cmatrix && hd1->type==s_matrix) { d=dimsof(hd); d1=dimsof(hd1); if (d->c != d1->r) { error=8; output("Cannot multiply these!\n"); return; } r=d->r; c=d1->c; result=new_cmatrix(r,c,""); if (error) return; m=matrixof(result); m1=matrixof(hd); m2=matrixof(hd1); for (i=0; ic,i,0); mm2=m2+j; x=0.0; y=0.0; for (k=0; kc; k++) { if ((*mm2!=0.0) && (*mm1!=0.0 || *(mm1+1)!=0.0)) cscalp(&x,&y,mm1,mm1+1,mm2,&null); mm1+=2; mm2+=d1->c; } ccopy(cmat(m,c,i,j),&x,&y); y=-y; ccopy(cmat(m,c,j,i),&x,&y); } moveresult(st,result); return; } if (hd->type==s_cmatrix && hd1->type==s_cmatrix) { d=dimsof(hd); d1=dimsof(hd1); if (d->c != d1->r) { error=8; output("Cannot multiply these!\n"); return; } r=d->r; c=d1->c; result=new_cmatrix(r,c,""); if (error) return; m=matrixof(result); m1=matrixof(hd); m2=matrixof(hd1); for (i=0; ic,i,0); mm2=m2+(LONG)2*j; x=0.0; y=0.0; for (k=0; kc; k++) { if ((*mm2!=0.0 || *(mm2+1)!=0.0) && (*mm1!=0.0 || *(mm1+1)!=0.0)) cscalp(&x,&y,mm1,mm1+1,mm2,mm2+1); mm1+=2; mm2+=2*d1->c; } ccopy(cmat(m,c,i,j),&x,&y); y=-y; ccopy(cmat(m,c,j,i),&x,&y); } moveresult(st,result); return; } else wrong_arg(); }