Mercurial > hg > jgplsrc
diff vgauss.c @ 0:e0bbaa717f41 draft default tip
lol J
author | Jordi Gutiérrez Hermoso <jordigh@octave.org> |
---|---|
date | Mon, 25 Nov 2013 11:56:30 -0500 |
parents | |
children |
line wrap: on
line diff
new file mode 100644 --- /dev/null +++ b/vgauss.c @@ -0,0 +1,113 @@ +/* Copyright 1990-2011, Jsoftware Inc. All rights reserved. */ +/* License in license.txt. */ +/* */ +/* Verbs: Gaussian Elimination */ + +#include "j.h" + + +F1(jtgausselm){A t;C*tv;I c,e,i,j,m,old,r,r1,*s;Q p,*u,*v,*x; + F1RANK(2,jtgausselm,0); + ASSERT(RAT&AT(w),EVNONCE); + ASSERT(2==AR(w),EVRANK); + s=AS(w); r=s[0]; c=s[1]; r1=MIN(r,c); v=QAV(w); m=c*bp(AT(w)); + GA(t,LIT,m,1,0); tv=CAV(t); + old=jt->tbase+jt->ttop; + for(j=0;j<r1;++j){ + e=-1; u=v+c*j+j; DO(r-j, if(XDIG(u->n)){e=i+j; break;} u+=c;); /* find pivot row */ + ASSERT(0<=e,EVDOMAIN); + x=v+c*j; + if(j!=e){u=v+c*e; MC(tv,x,m); MC(x,u,m); MC(u,tv,m);} /* interchange rows e and j */ + p=x[j]; DO(c, x[i]=qdiv(x[i],p);); + for(i=0;i<r;++i){ + if(i==j)continue; + u=v+c*i; p=u[j]; /* pivot */ + DO(c, u[i]=qminus(u[i],qtymes(p,x[i]));); + } + gc(w,old); + } + R w; +} /* Gaussian elimination in place */ + +static F1(jtdetr){A t,z;C*tv;I c,e,g=1,i,j,k,m,old,r,*s;Q d,p,*u,*v,*x; + RZ(w); + s=AS(w); r=s[0]; c=s[1]; + v=QAV(w); + m=c*sizeof(Q); GA(t,LIT,m,1,0); tv=CAV(t); + old=jt->tbase+jt->ttop; + for(j=0;j<r;++j){ + e=-1; u=v+c*j+j; DO(r-j, if(XDIG(u->n)){e=i+j; break;} u+=c;); /* find pivot row */ + if(0>e)R cvt(RAT,zero); + x=v+c*j; + if(j!=e){u=v+c*e; MC(tv,x,m); MC(x,u,m); MC(u,tv,m); g=-g;} /* interchange rows e and j */ + i=XDIG(x[j].n); if(i==XPINF||i==XNINF)R mark; + for(i=j+1;i<r;++i){ + u=v+c*i; + if(XDIG(u[j].n)){p=qdiv(u[j],x[j]); for(k=j+1;k<r;++k)u[k]=qminus(u[k],qtymes(p,x[k]));} + } + gc(w,old); + } + d=0<g?*v:qminus(zeroQ,*v); u=v+1+c; DO(r-1, d=qtymes(d,*u); u+=1+c;); + RE(0); + GA(z,RAT,1,0,0); *QAV(z)=d; R z; +} /* determinant on rational matrix; works in place */ + +static F1(jtdetd){D g,h,p,q,*u,*v,*x,*y,z=1.0;I c,d,e,i,j,k,r,*s; + RZ(w); + s=AS(w); r=s[0]; c=s[1]; v=DAV(w); + NAN0; + for(j=0;j<r;++j){ + x=v+c*j; u=x+j; h=0.0; + DO(r-j, k=i; DO(c-j, g=ABS(*u); if(h<g){h=g; d=j+k; e=j+i;} ++u;); u+=j;); /* find pivot, maximum abs element */ + if(h==inf)R mark; + if(0==h)R scf(0.0); + if(j!=d){u=v+c*d+j; y=x+j; DO(c-j, q=*u; *u=*y; *y=q; ++u; ++y; ); z=-z;} /* interchange rows j and d */ + if(j!=e){u=x+e; y=x+j; DO(r-j, q=*u; *u=*y; *y=q; u+=c; y+=c;); z=-z;} /* interchange cols j and e */ + q=x[j]; z*=q; JBREAK0; + for(i=j+1;i<r;++i){ + u=v+c*i; + if(u[j]){p=u[j]/q; for(k=j+1;k<r;++k)u[k]-=p*x[k];} + }} + NAN1; + R scf(z); +} /* determinant on real matrix; works in place */ + +#define ZABT(v) ((v).re*(v).re+(v).im*(v).im) + +static F1(jtdetz){A t;D g,h;I c,d,e,i,j,k,r,*s;Z p,q,*u,*v,*x,*y,z; + RZ(w); + z.re=1.0; z.im=0.0; + s=AS(w); r=s[0]; c=s[1]; v=ZAV(w); + NAN0; + for(j=0;j<r;++j){ + x=v+c*j; u=x+j; h=0.0; + DO(r-j, k=i; DO(c-j, g=ZABT(*u); if(h<g){h=g; d=j+k; e=j+i;} ++u;); u+=j;); /* find pivot, maximum abs element */ + if(h==inf)R mark; + if(0==h)R scf(0.0); + if(j!=d){u=v+c*d; DO(c-j, q=u[j+i]; u[j+i]=x[j+i]; x[j+i]=q;); z=zminus(zeroZ,z);} /* interchange rows j and d */ + if(j!=e){u=v+c*j+e; y=v+c*j+j; DO(r-j, q=*u; *u=*y; *y=q; u+=c; y+=c;); z=zminus(zeroZ,z);} /* interchange cols j and e */ + q=x[j]; z=ztymes(z,q); + for(i=j+1;i<r;++i){ + u=v+c*i; + if(ZNZ(u[j])){p=zdiv(u[j],q); for(k=j+1;k<r;++k)u[k]=zminus(u[k],ztymes(p,x[k]));} + }} + NAN1; RE(0); + GA(t,CMPX,1,0,0); *ZAV(t)=z; R t; +} /* determinant on complex matrix; works in place */ + +F1(jtgaussdet){A z;I*s; + RZ(w); + ASSERT(2==AR(w),EVRANK); + s=AS(w); + ASSERT(s[0]==s[1],EVLENGTH); + switch(AT(w)){ + default: ASSERT(0,EVDOMAIN); + case B01: + case INT: R detd(cvt(FL,w)); + case FL: z=detd(ca(w)); break; + case CMPX: z=detz(ca(w)); break; + case XNUM: z=detr(cvt(RAT,w)); break; + case RAT: z=detr(ca(w)); + } + R z==mark?detxm(w,eval("-/ .*")):z; +} /* determinant on square matrix */