Artifact e46ab342345b8e317cd7d59b66f9dd916aae2b5ac0a7ded71530508d93312ca5:
- Executable file
r37/packages/atensor/tensorio.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 4108) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/atensor/tensorio.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 4108) [annotate] [blame] [check-ins using]
%====================================================== % Name: tio.red - tensor user interface % Author: A.Kryukov (kryukov@npi.msu.su) % Copyright: (C), 1993i-1995, A.Kryukov % Version: 1.35 % Release: Apr., 17, 1995 %------------------------------------------------------ % Modified: Apr., 17, 1995 tsym2 % Apr., 24, 1996 tclear0 %====================================================== module tensorio$ %===================================================== % blist::=((th . pv_list) ...) % pv_list::= (pv1 pv2 ...) %===================================================== smacro procedure tname th$ car th$ smacro procedure ilist th$ cadr th$ smacro procedure dlist th$ cddr th$ smacro procedure mkth(tn,il,dl)$ list tn . il . id$ smacro procedure mkth0(tn,il,dl)$ tn . il . dl$ smacro procedure thead ten$ car ten$ smacro procedure pvect ten$ cdr ten$ smacro procedure mkten0(th,pv)$ th . pv$ smacro procedure mkten(th,pv)$ '!:tensor . list(th . pv)$ symbolic procedure bassoc(th,bl)$ if null bl then nil else if th_match(th,caar bl) then bl else bassoc(th,cdr bl)$ global '(!*basis,tensors!*)$ remprop('tensor,'stat)$ remprop('tsym,'stat)$ remprop('tclear,'stat)$ symbolic procedure tensor u$ for each x in u do if null(x memq tensors!*) then << put(x,'!:tensor,99)$ % undefine rank put(x,'simpfn,'t_simp)$ flag(list x,'full)$ tensors!* := x . tensors!*$ >> else write "+++ ",x," is already declared as tensor."$ symbolic procedure tclear u$ tclear0(if car u eq 'all then tensors!* else u)$ symbolic procedure tclear0 u$ for each x in u do if x memq tensors!* then begin scalar bs,bs1$ tensors!* := delete(x,tensors!*)$ remprop(x,'!:tensor)$ remflag(x,'full)$ bs:=!*basis$ while bs do << if null(x memq caaar bs) then bs1:=car bs . bs1$ bs:=cdr bs$ >>$ !*basis:=reversip bs1$ end else << write "+++ ",x," is not a tensor."$ terpri() >>$ symbolic procedure tsym u$ % u is a list of symmetry identities. % return nil. % Out side eff.: add identities to basis list in !*basis. begin scalar b$ b:=!*basis$ !*basis:=nil$ !*basis:=tsym1(u,b)$ end$ symbolic procedure tsym1(u,b)$ % u is a list of symmetry identities. % b is a basis list (returned value). % return new basis list. if null u then b else tsym1(cdr u,tsym2(cdr numr simp!* car u,b,nil))$ symbolic procedure tsym2(tt,b,b1)$ % tt is a tensor identity % b is old basis % b1 is new basis (returned value) if cdr tt then rederr list('tsym2,"*** Invalid identity:",tt) else if null b then (caar tt . tsym4(gperm length cadaar tt,car tt,nil)) . reversip b1 else if th_match0(caar tt,caar b) then (caar b . tsym4(gperm length cadaar tt,car tt,cdar b)) . append(cdr b,b1) else tsym2(tt,cdr b,car b . b1)$ symbolic procedure tsym4(ps,x,b0)$ if null ps then b0 else tsym4(cdr ps,x ,insert_pv(pv_renorm sieve_pv(pv_applp(cdr x,car ps),b0),b0) )$ put('tensor,'stat,'rlis)$ put('tsym,'stat,'rlis)$ put('tclear,'stat,'rlis)$ symbolic procedure kbasis x$ for each z in x do basis1 z$ global '(!*dummypri)$ switch dummypri$ symbolic procedure basis1 x$ begin scalar b$ if idp x then x:=list x; if atom x or null get(car x,'!:tensor) then rederr list('basis1,"*** Invalid as tensor:",x); b:=!*basis$ while b do << if tnequal(x,caaar b) then << for each z in cdar b do t_pri1('!:tensor . list(caar b . z),t)$ write length cdar b$ terpri()$ >>$ b:=cdr b$ >>$ end$ symbolic procedure tnequal(tn1,tn2)$ if atom tn1 then tn1 eq tn2 else (lambda x$ if x neq tn2 then tnequal(cdr tn1,x) else nil) delete(car tn1,tn2)$ put('kbasis,'stat,'rlis)$ endmodule; end;