#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#		"End of shell archive."
# Contents:  hybridconjug hybridfirst
# Wrapped by karin@borodin on Wed Jul 24 21:50:18 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'hybridconjug' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'hybridconjug'\"
else
echo shar: Extracting \"'hybridconjug'\" \(64742 characters\)
sed "s/^X//" >'hybridconjug' <<'END_OF_FILE'
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X%%                     SYMCON                          %%
X%% hybrid algorithm of mixed symbolic numerical type   %%
X%% Authors: Dr. K. Gatermann (symbolic part)           %%
X%%          A. Hohmann (numerical part)                %%
X%% 24. 7. 1991                                         %%  
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%  
Xoff echo$
Xload gentran;
Xgentranlang!*:='c;
Xin "generror";
Xoperator u,z,y,Y!v!a!r;
Xoperator !s!i!n,!c!o!s,!a!p!p!e!n!d!_!o!p;
Xswitch numericmode;  % switch for more numeric or more analytic comp.
Xon numericmode; %case of numerical pointwize evaluation of g,dg,ddg
Xswitch secondoutputfile; % switch for another output file
X                         % in case G=D6 and off numericmode
Xoff  secondoutputfile; % no second outputfile
Xswitch linknumeric; % writes to example.c and 
X                    % starts numerical part immediately
Xoff linknumeric; % numerical part later, write to file 
X                 % which was given with gentranout;
X
Xlisp setq(!*uncached,t); % lowers cpu time enormous
Xin "hybridinfo";  % load information for groups and subgroups
Xin "hybridfirst"; % load functions for symmetric normal forms
Xin "hybridsym"; % load functions nicis and conjugate groups
Xin "hybridnum"; % numeric mode
X
Xlisp copyd ('mysubsublis,'subsublis);
Xsymbolic procedure subsublis(u,v);
X  if eqcar(v,'!o!r!g!_!d!f!f) then u else
X   mysubsublis(u,v);
X
Xsymbolic procedure myalconsym(arg);
X%% main routine
Xbegin
X  scalar f,vars,v,group,ma,m,z,s,g,ma1,ma2,test,initdat;
X  %print list("in alconsym");
X  f:=reval car arg;
X  %print list("f",f);
X  f:=for each g in cdr f collect list(simp car g);
X  vars:=cdr reval cadr arg;
X  vars:=for each v in vars collect reval v;
X  initdat:=reval caddr arg;
X  initdat:=for each v in initdat collect reval v;
X  initdat:=for each v in cdr initdat collect 
X        list(car v , reval cadr v, reval caddr v);
X%  print list(initdat);
X  group:=reval cadddr arg;
X  if length(cddddr arg) <1 then rederr" Matrices missing ";
X  ma1:=reval cadddr cdr arg;    % rotation r for D3,D4,D6 s for Z2 id for Id
X  ma1:=cdr ma1; % mat entfernen
X  ma1:=for each z in ma1 collect
X      for each s in z collect simp s;
X % print list("f",f);
X % print list("vars",vars);
X % print list("group",group);
X % print list("grouplist",grouplist);
X  if !*numericmode and !*secondoutputfile then rederr" only one switch at a time";
X  if member(group,list('D3,'D4,'D6)) then 
X     << if length(cdddr cddr arg) < 1 then rederr"reflection missing";
X        ma2:=reval cadddr cddr arg;   %reflection s
X        ma2:=cdr ma2; % mat entfernen
X        ma2:=for each z in ma2 collect
X            for each s in z collect simp s;
X     >> else
X       ma2:=ma1;
X  test:= equicheckd6(f,ma1,ma2,vars); 
X  if test and !*linknumeric then eval list ('mkopen);
X  if test then   prepare(f,vars,group,mkgrouplist(group,ma1,ma2),initdat);
X  if test and !*linknumeric then eval list ('drawpicture);
X  writepri("total time spent:   ",'first);
X  writepri(timc(),'last);
Xend; 
Xput('symcon,psopfn,'myalconsym);
X
Xprocedure mkopen();
Xbegin
X  system"rm example.c";
X  gentranout"example.c";
Xend;
X
Xprocedure drawpicture();
Xbegin
X  gentranshut"example.c";
X  system"make -f *.example";
X  write"call numerical routines";
X  system "symcon";
Xend;
X
Xsymbolic procedure mkgrouplist(group,ma1,ma2);
Xbegin
X  scalar r2,r3,r4,r5,r6,sr,sr2,sr3,sr4,sr5;
X  if group= 'id then return list(ma1);
X  if group= 'Z2 then return list(matmult(ma1,ma1),ma1);
X  r2:=matmult(ma1,ma1);
X  r3:=matmult(ma1,r2);
X  r4:=matmult(r2,r2);
X  r5:=matmult(r2,r3);
X  r6:=matmult(r3,r3);
X  sr:=matmult(ma2,ma1);
X  sr2:=matmult(ma2,r2);
X  sr3:=matmult(ma2,r3);
X  sr4:=matmult(ma2,r4);
X  sr5:=matmult(ma2,r5);
X  if group= 'D3 then return list(r3,ma1,r2,ma2,sr,sr2);
X  if group= 'D4 then return list(r4,ma1,r2,r3,ma2,sr,sr2,sr3);
X  if group= 'D6 then return list(r6,ma1,r2,r3,r4,r5,ma2,sr,sr2,sr3,sr4,sr5);
Xend;
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X%%%
X%%%    make  C -- routines
X%%%
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X
Xsymbolic procedure 
Xmkccode(f,g,m,nicis,initdat,vars,newvars,group,grouplist,paras);
X% makes the C-routines for Alcon
X% stores information for group and subgroups
X% grouplist is a list of matrices corresponding to group
Xbegin
X  scalar subgroups,gjac,gjacjac,i,gl,cmat,subnicis,n,s,z;
X  scalar storename,noncgs,nrelem,glen,erzlist; 
X  n:=length(m);
X  if not(!*numericmode) then
X   <<
X     gjac:=mkjac(g,newvars);
X     gjacjac:=mksecdev(gjac,newvars);
X     % print list("symbolic differentiation ready",timc()); 
X   >> else
X   <<
X      gjac :='numericcase;
X      gjacjac :='numericcase;
X   >>;
X % print list("everything ready for c-routines");
X  subgroups:=findsubgs(group,nicis);  %determine Isotropie subgroups 
X % print list("isotropy groups",subgroups);
X  writepri("isotropy groups :",'first);
X  writepri(" ",'last);
X  writepri(" ",'first);
X  for each i in subgroups do 
X    <<writepri(" ",'nil);
X      writepri(list('aeval,mkquote i),'nil);
X    >>;
X  writepri(" ",'last);
X  storename:=mkid(mkid('!*,group),mkid(group,'!*));
X  put(storename,'nici,nicis);
X  put(storename,'cmat,mkeinhmat(n));
X  for each subg in subgroups do
X    <<
X       subnicis:=detnicis(subg,group,nicis);
X       cmat:=mkconnectmatgsubg(n,group,subg,nicis,subnicis);
X       storename:=mkid(mkid('!*,group),mkid(subg,'!*));
X       put(storename,'nici,subnicis);
X       put(storename,'cmat,cmat);
X  %     print list("nicis and cmat ready",timc());
X       for each z in cmat do
X           for each s in z do suchen(s,nil);
X      % print list("subgroup,cmat",subg);
X      % printmat(cmat);
X       put(storename,'supergroups,findsupgsbreakis(
X             append(subgroups,list(group)),group,subg));
X   %    print list("i breaks found ",timc());
X    >>; 
X  for each subg in subgroups do
X   <<  storename:=mkid(mkid('!*,group),mkid(subg,'!*));
X       put(storename,'superg,fillsupgsbreakis(
X             append(subgroups,list(group)),group,subg));
X  >>;
X  subgroups:=append(subgroups,list (group));
X  MKBEGIBNC(initdat,vars,subgroups,n,paras);
X % print list("MKBEGIBNC fertig",timc());
X  mkinversetable(grouplist,group);
X % print list("inverse bekannt",timc());
X  subgrouptree(group);
X % print list("subgroups known",timc());
X  mkgrouptable(grouplist,group);
X % print list("grouptable generated",timc());
X  noncgs:=findcgs(group,n,subgroups);
X % print list("non-conjugate groups",noncgs);
X  writepri("The non-conjugate groups are: ",'first);
X  writepri(" ",'last);
X  writepri(" ",'first);
X  for each i in noncgs do
X    <<
X       writepri(" ",'nil);
X       writepri(list('aeval,mkquote i),'nil);
X       writepri(" ",'nil);
X    >>;
X  writepri(" ",'last);
X  noteconjugates(group,subgroups,noncgs);
X  erzlist:=mkops(group,subgroups,grouplist,n);
X % print list("all operations",erzlist);
X  genoperations(erzLIST,GROUPLIST,GROUP,N);
X  GLEN:=LENGTH(GROUPLIST);
X  FOR EACH NRELEM IN ERZLIST DO
X         GENTRANSGROUP(SUBGROUPS,GROUP,NRELEM);
X  GENBREAK('!t!r!i!v,NIL);
X  FOR EACH NRELEM IN ERZLIST DO
X    FOR EACH SUBG IN SUBGROUPS DO
X        FDBREAKS(NRELEM,GROUP,SUBG,SUBGROUPS,M,NTH(GROUPLIST,NRELEM));
X % print list("hallo");
X  if !*numericmode then 
X      genorgf(f,vars,group,n) else
X      decorgf();
X  FOR EACH SUBG IN SUBGROUPS DO
X    <<
X  %     SUBG:='C6;
X       STORENAME:=MKID(MKID('!*,GROUP),MKID(SUBG,'!*));
X       MK1CODE(GET(STORENAME,'SUPERG),G,GJAC,GJACJAC,SUBG,GROUP,
X      NICIS,GET(STORENAME,'NICI),M,GET(STORENAME,'CMAT),SUBGROUPS,NONCGS,PARAS);
X    >>; 
X%  MYALLCLEAR(GROUP,SUBGROUPS,NONCGS);
XEND;
X
X
XSYMBOLIC PROCEDURE MKSECDEV(GJAC,NEWVARS);
XBEGIN
X  SCALAR Z,S,VARX,RES;
X % PRINT LIST(" IN MKSECDEV VARS ",NEWVARS);
X  RES:=FOR EACH Z IN GJAC COLLECT
X     FOR EACH S IN Z COLLECT 
X       FOR EACH VARX IN NEWVARS COLLECT 
X         SIMP REVAL LIST('DF ,PREPSQ S, VARX);
X  RETURN RES;
XEND;
X
XSYMBOLIC PROCEDURE MYALLCLEAR(GROUP,SUBGROUPS,NONCGS);
XBEGIN
X  SCALAR STORENAME,SUBG;
X  FOR EACH SUBG IN SUBGROUPS DO
X    <<
X      STORENAME:=MKID(MKID('!*,GROUP),MKID(SUBG,'!*));
X      REMPROP(STORENAME,'NICI);
X      REMPROP(STORENAME,'CMAT);
X      REMPROP(STORENAME,'SUPERGROUPS);
X      REMPROP(STORENAME,'SUPERG);
X      REMPROP(STORENAME,'ELEMS);
X      REMPROP(STORENAME,'OPS);
X    >>;
XEND;
X
Xsymbolic procedure genbreak(name,ll);
Xbegin
X  scalar gentlist,pr;
X  gentlist:=list('literal,"static int isotypic_",name,"(i)",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,"     int i;",'cr!*,"{",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,"     switch (i) {",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  for each pr in ll do
X    <<
X        gentlist:=list('literal,
X          "   case ",car pr," : return  ",cadr pr," ;",'cr!*);
X      %  print list("gentlist",gentlist);
X        eval list('gentran,mkquote gentlist,'nil);
X    >>;
X  gentlist:=list('literal,"     default : return i;",'cr!*);
X % print list("gentlist besser",gentlist);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,"}",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,"}",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
Xend;
X
Xsymbolic procedure gentransgroup(subgroups,group,nrelem);
X% makes a c-procedure change_group_no
X% using gentran
Xbegin
X  scalar gentlist,tble,pr,subg1,subg2;
X  gentlist:=list('literal,"static Group* change_group_",nrelem,"(sigma)",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,"        Group *sigma;",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,"{",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,"     switch (sigma->no) {",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  tble:=get(mkid('!*tab,group),mkid('cgof,nrelem));
X  for each pr in tble do
X    << 
X       subg1:=car pr;
X       subg2:=cadr pr;
X       if not(subg1=subg2) then 
X         <<
X            gentlist:=list('literal,
X                  "     case ",subg1,"_NO : return ",subg2,";",'cr!*);
X            eval list('gentran,mkquote gentlist,'nil);
X         >>;
X    >>;
X  gentlist:=list('literal,"     default : return sigma;",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,"}",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,"}",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
Xend;
X
Xsymbolic procedure genallocgroups(subgroups,group,noncgs);
X% generates allocgroups
Xbegin
X  scalar gentlist,eqs,decls,pname,eqhelp,subnicis,storename,sn,i,subjacnrs,j,
X         supergs;
X  pname:='!a!l!l!o!c!g!r!o!u!p!s;
Xdecls:=list('declare,list('integer,list('!n!s!u!b,'times),'!r,'s),
X                      list('!s!t!a!t!i!c! !v!o!i!d,pname)  );
X  eqs:=nil;
X  for each subg in subgroups do
X     <<
X       storename:=mkid(mkid('!*,group),mkid(subg,'!*));
X       subnicis:=get(storename,'nici);
X       sn:=mkaktuelllength(subnicis);
X       eqhelp:=list('setq,'s,sn);  %number of isotyp. comp.
X       eqs:=append(eqs,list (eqhelp));
X       supergs:=get(storename,'supergroups);
X       eqhelp:=list('setq,'!r,length(supergs));  %nr of supergroups
X       eqs:=append(eqs,list (eqhelp));
X       eqhelp:=list('setq,'!n!s!u!b,
X          mkid(mkid('!i!v!e!c!t!o!r!(,2),'!,s!))); 
X       eqs:=append(eqs,list (eqhelp));
X       subjacnrs:=get(storename,'subjacs);
X       j:=1;
X       eqhelp:=for each i in cdr subjacnrs collect
X        <<j:=j+1;
X         list('setq,list('!n!s!u!b,j),anzsubgs(subg,i,noncgs))
X         >>; %anz of nonconjugate subgs anzsubgs
X       eqs:=append(eqs,eqhelp);
X
X       if subg=group then
X           eqhelp:=list('setq,'!g!r!o!u!p,
X              '!n!e!w!_!g!r!o!u!p!(s!,!n!s!u!b!,!r!)) else  
X       eqhelp:=list('setq,subg,
X            '!n!e!w!_!g!r!o!u!p!(s!,!n!s!u!b!,!r!));  
X       eqs:=append(eqs,list( eqhelp));
X       if subg=group then
X         <<
X           eqhelp:=list('setq,group,'!g!r!o!u!p);
X           eqs:=append(eqs,list( eqhelp));
X         >>;
X     >>;
X   gentlist:=list('procedure,pname,'nil,'expr,'nil,
X                 append(list('block,'nil,decls),eqs));
X  eval list('gentran,mkquote gentlist,'nil);
Xend;
X 
XSYMBOLIC PROCEDURE MKAKTUELLLENGTH(SUBNICIS);
X% COUNT THE NUMBER OF NONVANISHING ISOTYP.COMP.
XBEGIN
X  SCALAR COUNT,I;
X  COUNT:=0;
X  FOR I:=1:LENGTH(SUBNICIS) DO
X      IF NUMR CADR NTH(SUBNICIS,I) THEN COUNT:=COUNT+1;
X  RETURN COUNT;
XEND;
X
Xsymbolic procedure mkbegibnc(initdat,vars,subgroups,n,paras);
X% makes the first declarations in the file containing c
Xbegin
X  scalar gentlist,i,group,p;
X  gentlist:=list('literal,"#include <strings.h>",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,"#include <stdio.h>",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,"#include <math.h>",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,"#include <malloc.h>",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,"#include ",'!","macros.h",'!",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,"#include ",'!","matutil.h",'!",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,"#include ",'!","matalloc.h",'!",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,"#include ",'!","group.h",'!",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X if !*secondoutputfile then 
X     <<
X        gentlist:=list('literal,"extern void gID();",'cr!*);
X        eval list('gentran,mkquote gentlist,'nil);
X        gentlist:=list('literal,"extern void dgID1();",'cr!*);
X        eval list('gentran,mkquote gentlist,'nil);
X        gentlist:=list('literal,"extern void cgID1();",'cr!*);
X        eval list('gentran,mkquote gentlist,'nil);
X     >>;
X  gentlist:=list('literal,'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  gentlist:=list('literal,"int m=",n,", n=",n+1,", npar=",length(paras),
X                      ", nog = ",length(subgroups),";",'cr!*);
X  eval list('gentran,mkquote gentlist,'nil);
X  GENTLIST:=list(";",'CR!*);
X  for each p in paras do gentlist:=append(list(",",p),gentlist);
X  IF !*secondoutputfile THEN 
X       GENTLIST:=append(LIST('LITERAL,"double "),cdr gentlist) else
X       GENTLIST:=append(LIST('LITERAL,"static double "),cdr gentlist);
X  if length(paras)>0 then EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X  parstring(paras);
X  GENTLIST:=LIST('LITERAL,"void setpar()",'CR!*,"{",'CR!*);
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X  i:=0;
X  for each p in paras do
X    <<i:=i+1;
X       GENTLIST:=LIST('LITERAL,p," = par[",i,"];",'CR!*);
X       EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X    >>;
X  GENTLIST:=LIST('LITERAL,"}",'CR!*);
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X % GENTLIST:=LIST('LITERAL,"Group *group;",'CR!*);
X % EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X  GENTLIST:=LIST('LITERAL,'CR!*);
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X      geninitial(initdat,vars,paras);
X  GENTLIST:=LIST('LITERAL,"static Group ");
X  gentlist:=append(gentlist,cdr for each group in subgroups join 
X             list('!, ,mkid('!*,group)));
X  gentlist:=append(gentlist,list('!;,'CR!*));
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X  GENTLIST:=LIST('LITERAL,"static Op *op;");
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X  GENTLIST:=LIST('LITERAL,'CR!*);
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X  i:=0;
X  for each group in subgroups do
X     <<
X       i:=i+1;
X       GENTLIST:=LIST('LITERAL,"#define ",mkid(group,'!_NO)," ",i,'CR!*);
X       EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X     >>;
X  GENTLIST:=LIST('LITERAL,'CR!*);
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
XEND;
X
Xsymbolic procedure parstring(ll);
Xbegin
X  scalar gentlist,par,helpl,npar;
X  npar:=length(ll);
X  gentlist:=list('literal,"char par_string[",
X      if npar>0 then npar else 1,"][10] ");
X  eval list('gentran,mkquote gentlist,'nil);
X  if npar>0 then
X   <<
X      gentlist:=list('literal,"= {");
X      eval list('gentran,mkquote gentlist,'nil);
X      helpl:=for each par in ll join
X        << list('!,,'!",par,'!")
X        >>;
X      eval list('gentran,mkquote append(list('literal),cdr helpl),'nil);
X      gentlist:=list('literal,"}");
X      eval list('gentran,mkquote gentlist,'nil);
X   >>;
X   gentlist:=list('literal,";",'cr!*," ",'cr!*);
X   eval list('gentran,mkquote gentlist,'nil);
Xend;
X
XSYMBOLIC PROCEDURE geninitial(initdat,vars,paras);
Xbegin
X  scalar eqs,args,gentlist,fktname,decls;
X  eqs:=parinit(initdat,paras);
X  eqs:=append(eqs,list(
X                  list('!s!e!t!p!a!r)
X                   ));
X  eqs:=append(eqs,varinit(initdat,vars));
X  eqs:=append(eqs,tauinit(initdat));
X  fktname:='!i!n!i!t!_!d!a!t!a;
X  args:=nil;
X  decls:= LIST('DECLARE, LIST('!v!o!i!d,fktname));
X  gentlist:= LIST('PROCEDURE,fktname,'NIL,'EXPRN,args,
X                 APPEND( LIST('BLOCK,'NIL,decls),eqs));
X  EVAL LIST('GENTRAN,mkquote gentlist,'NIL);
Xend;
X
XSYMBOLIC PROCEDURE tauinit(initdat);
Xbegin
X  scalar res,v,ll,initl,initv,i;
X  ll:=initdat;   
X  initv:=nil;
X  while (length(ll)>0) and (length(initv)=0) do
X        <<
X          initl:= car ll;
X          ll:=cdr ll;
X          if length(initl)>2 and (cadr initl = 'taumin) then
X            initv:=list('setq,'!t!a!u!_!m!i!n,caddr initl);  
X        >>;
X      if length(initv)=0 then rederr"initial value for tau missing";
X  res:=list(initv);
X  ll:=initdat;   
X  initv:=nil;
X  while (length(ll)>0) and (length(initv)=0) do
X        <<
X          initl:= car ll;
X          ll:=cdr ll;
X          if length(initl)>2 and (cadr initl = 'taumax) then
X            initv:=list('setq,'!t!a!u!_!m!a!x,caddr initl);  
X        >>;
X      if length(initv)=0 then rederr"initial value for tau missing";
X  res:=append(res,list(initv));
X  return res;
Xend;
X
XSYMBOLIC PROCEDURE parinit(initdat,paras);
Xbegin
X  scalar res,v,ll,initl,initv,i;
X  ll:=initdat;
X  i:=0;
X  res:=for each v in paras collect
X    << 
X       ll:=initdat;
X       initv:=nil;
X       i:=i+1;
X       while (length(ll)>0) and (length(initv)=0) do
X        <<
X          initl:= car ll;
X          ll:=cdr ll;
X          if length(initl)>2 and (cadr initl = v) then
X            initv:=list('setq,list('!p!a!r,i),caddr initl);  
X        >>;
X      if length(initv)=0 then rederr"value for parameter missing";
X      initv
X    >> ;
X  return res;
Xend;
X
XSYMBOLIC PROCEDURE varinit(initdat,vars);
Xbegin
X  scalar res,v,ll,initl,initv,i;
X  ll:=initdat;
X  i:=0;
X  res:=for each v in vars collect
X    << 
X       ll:=initdat;
X       initv:=nil;
X       i:=i+1;
X       while (length(ll)>0) and (length(initv)=0) do
X        <<
X          initl:= car ll;
X          ll:=cdr ll;
X          if length(initl)>2 and (cadr initl = v) then
X            initv:=list('setq,list('!y!_!g!u!e!s!s,i),caddr initl);  
X        >>;
X       if length(initv)=0 then 
X           << print list("initdat,vars,v",initdat,vars,v);
X              rederr "initial value missing";
X           >>;
X       initv
X    >> ;
X  return res;
Xend;
XSYMBOLIC PROCEDURE genfktns(g,paras);
X% makes the first declarations in the file help.c
XBEGIN
X  SCALAR GENTLIST,i,group,p;
X  GENTLIST:=LIST('LITERAL,"#include <strings.h>",'CR!*);
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X  GENTLIST:=LIST('LITERAL,"#include <stdio.h>",'CR!*);
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X  GENTLIST:=LIST('LITERAL,"#include <math.h>",'CR!*);
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X  GENTLIST:=LIST('LITERAL,"#include <malloc.h>",'CR!*);
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X  GENTLIST:=LIST('LITERAL,"#include ",'!","macros.h",'!",'CR!*);
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X  GENTLIST:=LIST('LITERAL,"#include ",'!","matalloc.h",'!",'CR!*);
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X  GENTLIST:=LIST('LITERAL,'CR!*);
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X  GENTLIST:=LIST('LITERAL,"#include ",'!","group.h",'!",'CR!*);
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X  GENTLIST:=list(";",'CR!*);
X  for each p in paras do gentlist:=append(list(",",p),gentlist);
X  GENTLIST:=append(LIST('LITERAL,"extern double "),cdr gentlist);
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
XEND;
X
Xsymbolic procedure mkconnectmatgsubg(n,group,subg,nicis,subnicis);
X% makes connectionmatrix C between isotyp. components
Xbegin
X  scalar connections,cmat,subnr,gnr,connect,fertigconnect,tups,gni;
X%  print list("in mkconnectmatgsubg",group,subg,nicis,subnicis);
X  connections:=connectiso(group,subg);
X % print list("connections",connections);
X  cmat:=mknullmat(n);
X  while connections do         %  isotyp. Komp. in subg abarbeiten
X   <<
X     connect:=car connections;
X     subnr:=car connect;
X    % print list("connect,subnr",connect,subnr);
X     connect:=cadr connect;
X     connections:=cdr connections;
X     fertigconnect:=nil;
X     while connect do        % isotyp. in connectlist abarbeiten
X      <<%print list("connect",connect);
X        gnr:=car connect;
X        connect:=cdr connect;
X        if connect and car connect = 'split then
X            << tups:=cadr connect;
X               connect:=cddr connect;
X            >> else tups:=nil;
X     %  print list("call mkcmat1 with ",group,subg);
X       cmat:=mkcmat1(cmat,subnr,gnr,subnicis,nicis,tups,fertigconnect,connect);
X       if tups then
X         fertigconnect:=append(fertigconnect,list(gnr,tups)) else
X           fertigconnect:=append(fertigconnect,list(gnr));
X      >>; 
X   >>; 
X  return cmat;
Xend;
X
Xsymbolic procedure
X     mkcmat1(cmat,subnr,nr,subnicis,nicis,tups,fertiggnrs,connect);
X% what has to be added to cmat ?
Xbegin
X  scalar s,z,i,gni,subni,gci,subci,ccase,gnr,merk,tupfactor,befores,afters,mue;
X%  print list("in mkcmat1 subnicis,nicis",subnicis,nicis);
X%  print list("in mkcmat1 connect",connect);
X % print list("cmat",cmat);
X  z:=nil ./ 1; 
X  for i:=1:nr-1 do 
X           z:=addsq(z,multsq(car nth(nicis,i),cadr nth(nicis,i)));
X  z:=numr z;
X% print list("z",z);
X  if not z then z:=0; 
X  s:=nil ./ 1; 
X  for i:=1:subnr-1 do 
X %    if length(nth(subnicis,i))=2 then
X        s:= addsq(s,multsq(car nth(subnicis,i),cadr nth(subnicis,i)));
X %    else
X %      s:= addsq(s,cadr nth(subnicis,i));  % complex case
X  s:=numr s;
X  % print list("s",s);
X    % position z,s
X  gni:=numr car nth(nicis,nr);
X % print list("gni",gni);
X  gci:=numr cadr nth(nicis,nr);
X % print list("gci",gci);
X  if not gci then gci:=0;
X  subni:=numr car nth(subnicis,subnr);
X  subci:=numr cadr nth(subnicis,subnr);
X  if not subci then subci:=0;
X  ccase:=cddr nth(subnicis,subnr);
X  % 5 cases have to be treated
X  if gni=1 and subni=1 then
X    <<
X     % print list("trivial case in cmat1");
X       for each gnr in fertiggnrs do
X          s:=addf(s,numr multsq(cadr nth(nicis,gnr),car nth(nicis,gnr)));
X       if not s then s:=0;
X       cmat:=addsubmat(cmat,mkeinhmat(gci),z,s,length(cmat),gci);
X       merk:='fallgefunden;
X    >>;
X  if gni>1 and subni=1  and not(tups) then
X    << % print list("in case 2");
X       for each gnr in fertiggnrs do
X          s:=addf(s,numr multsq(cadr nth(nicis,gnr),car nth(nicis,gnr)));
X       if not s then s:=0;
X       cmat:=addsubmat(cmat,mkeinhmat(gci*gni),z,s,length(cmat),gci*gni);
X       merk:='fallgefunden;
X    >>;
X  if gni=2 and subni=2  and not(tups) and ccase then  %single complex case
X    << % print list("in case 3");
X       for each gnr in fertiggnrs do
X          s:=addf(s,numr multsq(cadr nth(nicis,gnr),car nth(nicis,gnr)));
X       if not s then s:=0;
X       cmat:=addsubmat(cmat,mkeinhmat(gci*gni),z,s,length(cmat),gci*gni);
X       merk:='fallgefunden;
X    >>;
X  if gni>1 and subni=1 and tups then  %simple split case
X    << % print list("in simple split case",gni,subni,tups);
X       if not length(tups)=gni then print list("error in simple split case");
X       while fertiggnrs do
X          <<
X            gnr:=car fertiggnrs;
X            fertiggnrs:=cdr fertiggnrs;
X            if fertiggnrs and not(numberp(car fertiggnrs)) then
X               <<
X                 mue:=quotsq(length(car fertiggnrs) ./ 1,car nth(nicis,gnr));
X                 fertiggnrs:=cdr fertiggnrs;
X               >> else mue:= car nth(nicis,gnr); 
X            s:=addf(s,numr multsq(cadr nth(nicis,gnr),mue));
X          >>; 
X     %  for each gnr in fertiggnrs do
X       %   s:=addf(s,numr multsq(cadr nth(nicis,gnr),car nth(nicis,gnr)));
X       if not s then s:=0;
X      % print list("jetzt ist s",s);
X       for each tupfactor in tups do
X         <<
X           cmat:=addsubmat(cmat,
X                             matscalmult(tupfactor,mkeinhmat(gci)),
X                                  z,s,length(cmat),gci);
X           z:=z+gci;
X      %  print list("jetzt ist z",z);
X         >>;
X       merk:='fallgefunden;
X    >>;
X  if gni>1 and subni>1 and tups then  % multiple split case
X    <<%print list("in multiple split case");
X       if not length(tups)=gni*subni
X           then print list("error in multiple split case"); 
X       befores:=nil;
X        while fertiggnrs do
X          <<
X            gnr:=car fertiggnrs;
X            fertiggnrs:=cdr fertiggnrs;
X            if fertiggnrs and not(numberp(car fertiggnrs)) then
X               <<
X                 mue:=numr cadr nth(nicis,gnr);
X                 fertiggnrs:=cdr fertiggnrs;
X               >> else mue:= numr cadr nth(nicis,gnr); 
X            befores:=addf(befores,mue);
X          >>; 
X      % for each gnr in fertiggnrs do
X       %   befores:=addf(befores,numr cadr nth(nicis,gnr));
X       if not befores then befores:=0;
X      % print list("befores",befores);
X       afters:=nil;
X       while connect do
X         <<
X            afters:=addf(afters,numr cadr nth(nicis,car connect));
X            connect:=cdddr connect;
X         >>;
X       if not afters then afters:=0;
X      % print list("afters",afters);
X       if not s then s:=0;
X       for i:=1:subni do
X         <<
X            s:=s+befores;
X          %  print list("z,s",z,s);
X            for j:=1:gni do
X              <<
X                 tupfactor:=car tups;
X                 tups:=cdr tups;
X                 cmat:=addsubmat(cmat,
X                             matscalmult(tupfactor,mkeinhmat(gci)),
X                                  z+(j-1)*gci,s+(i-1)*gci,length(cmat),gci);
X              >>;
X             s:=afters+s;
X          >>;
X       merk:='fallgefunden;
X    >>;
X   if not merk='fallgefunden then print list("unknown case in construct c");
X  %print list("cmat",cmat);
X  return cmat;
Xend;
X
Xsymbolic procedure addsubmat(bigmat,smallmat,zm,sm,bigm,smalln);
X% add smallmat at position zm+1,sm+1 ,zm+smalln,sm+smalln to big matrix
Xbegin
X  scalar z,s,resmat;
X  if zm>bigm or sm>bigm then 
X   <<
X      print list("error in addsubmat"); 
X    %  print list("in addsubmat");
X    %  print list("bigmat",bigmat);
X    %  print list("smallmat",smallmat);
X    %  print list("bigm,smalln",bigm,smalln);
X    %  print list("zm,sm",zm,sm);
X   >>;
X  resmat:=for z:=1:bigm collect
X    if z>zm and z<zm+smalln+1 then
X      <<
X        for s:=1:bigm collect
X          if s>sm and s<sm+smalln+1 then 
X       myresimp addsq(nth(nth(bigmat,z),s),nth(nth(smallmat,z-zm),s-sm)) else
X                  nth(nth(bigmat,z),s)
X      >> else
X      <<
X         for s:=1:bigm collect nth(nth(bigmat,z),s)
X      >>;
X % print list("resmat",resmat);
X  return resmat;
Xend;
X
Xsymbolic procedure mknullmat(n);
X   for i:=1:n collect
X       for j:=1:n collect nil ./ 1;
X
Xsymbolic procedure mkeinhmat(n);
X   for i:=1:n collect
X       for j:=1:n collect if i=j then 1 ./ 1 else nil ./ 1;
X
X
Xsymbolic procedure mk1code(supergsis,g,gjac,gjacjac,subg,group,gnicis,
X     subnicis,m,cmat,isogroups,noncgs,paras);
X% for transformated function g make all codes;
Xbegin
X  scalar nsym,assocvars,symvars,i,j,partjac,subjacnrs,nr,gjacnew,supgib,subfkt;
X % print list("in mk1code  ",group,subg);
X% make assoclist for vars - small vars
X  nsym:=numr cadr car subnicis;
X % print list("before  mksymvars",nsym,cmat);
X  assocvars:=mksymvars(length(m),nsym,cmat);
X % print list("after mksymvars");
X % print list("assocvars",assocvars); 
X  symvars:= cadr  assocvars;
X  assocvars:= car assocvars; 
X  if !*secondoutputfile and subg='id then eval list('switchout); 
X  if !*secondoutputfile and subg='id then genfktns('id,paras); 
Xif member(subg,noncgs) then
X<<
X   if !*numericmode then
X      <<
X         gengnum(subg);
X         gengjacnum(subg,subnicis);
X         gensecjacnum(subg,subnicis);
X      >> else
X      <<
X         % make part fkt
X         subfkt:=myins(g,assocvars,nsym,cmat);
X         % print list("fkt made",timc());
X         % mkraus(subfkt);
X         % generate part fkt
X         genfkt(subfkt,subg,group);
X         % print list("fkt generated",timc());
X   subjacnrs:=nil;
X   gjacnew:=mknewjac(gjac,assocvars,cmat);
X %  print list("Jacobian made",timc());
X %  print list("block diagonal Jacobi matrix",group,subg);
X %  printmat(gjacnew);
X  % mkraus(gjacnew);
X   for nr:=1:length(subnicis) do
X     <<
X        partjac:=mkpartjac(gjacnew,nr,subnicis);
X        %mkraus(partjac);
X        if partjac then
X           <<
X              GENPARTJAC(nr,subg,partjac,group);
X             % print list("    one block ready",timc()); 
X              subjacnrs:=append(subjacnrs,list(nr));
X             % GENPJACSC(nr,subg,mkpjacsc(nr,partjac,symvars),group);
X            %  print list("    one block Ct ready",timc()); 
X           >>;
X     >>; 
X  % print list("blocks of Jacobians generated",timc()); 
X  % put(mkid(mkid('!*,group),mkid(subg,'!*)),'subjacs, subjacnrs);
X   genseconds(gjacjac,subg,group,assocvars,subjacnrs,cmat,m);
X     >>;
X>> ;
X%  subjacnumr extra berechnen
X   subjacnrs:=for nr:=1:length(subnicis) join
X      if numr cadr nth(subnicis,nr) then list(nr);
X   put(mkid(mkid('!*,group),mkid(subg,'!*)),'subjacs, subjacnrs);
X  if !*secondoutputfile and subg='id then eval list('switchbak); 
X  % make transforms
X  if !*numericmode then 
X     <<
X        genmatrices(group,subg,m,subnicis,noncgs);
X        gentrans(subg,nsym,length(m));
X     >> else
X     <<
X       GENYMWU(subg, mkymwu(m,cmat,symvars,nsym));
X       % make and generate invtransform
X       GENINVUY(subg, mkinvuy(m,cmat,symvars,nsym));
X     >>;
X  % print list("transforms ready",timc()); 
X   % make and generate tangents
X   for each nr in cdr subjacnrs do
X   if length(nth(subnicis,nr))=2 then  % complex comp. excluded
X   GENTANGENT(nr,subg,mktangent(group,subg,nr,m,cmat,subnicis,noncgs));
X  % print list("tangents ready",timc()); 
Xif member(subg,noncgs) then
X<<
X   % make test funktions
X   % print list("supergroups",supergsis);
X   for each supgib in supergsis do
X       GENTEST(mktest(supgib,subg,group,nsym,cmat),subg,car supgib);
X>>;
X % print list("supergrouptests ready",timc()); 
X% make group initializing functions
X  MKINITIAL(isogroups,noncgs,supergsis,subg,group,subnicis,subjacnrs);
X % print list("initialize ready",timc()); 
Xend;
X
Xsymbolic procedure genseconds(gjacjac,subg,group,assocvars,subjacnrs,cmat,m);
Xbegin
X  scalar i,j,tensor,cmatp1,n,nsym,secblock,nicis,pos,bb;
X  tensor:=substtensor(gjacjac,assocvars);
X% print list("substtensor fertig");
X  nicis:=get(mkid(mkid('!*,group),mkid(subg,'!*) ),'nici);
X  n:=length(cmat);
X  nsym:=cadr nth(nicis,1);
X  cmatp1:=for each z in cmat collect append (z, list(nil ./ 1));
X  cmatp1:=append(cmatp1,
X           list(append(for i:=1:n collect nil ./ 1  , list(1 ./ 1))));
X% second derivatives of blocks A_i z 
X  bb:=tensortransform(tensor,cmat,cmatp1,n);
X  pos:=cadr nth(nicis,1);
X  for each i in cdr subjacnrs do
X    <<% print list("i, nth(nicis,i)",i,nth(nicis,i));
X      % print list("nrs",subjacnrs,"  i ",i);
X       GENPJACSC(i,subg,
X          getblockDAz(pos,cadr nth(nicis,i),bb,n,numr nsym)
X                   ,group);
X       pos:=addsq(pos,multsq(car nth(nicis,i),cadr nth(nicis,i)));
X    >>;
X  % D(A^Tz) second derivative of first block
X  bb:=tensortranspos(tensor,n);
X  bb:=tensor1transform(bb,cmat,cmatp1,n,nsym);  
X  GENPJACSC(1,subg,bb,group);
X%GENPJACSC(nr,subg,mkpjacsc(nr,partjac,symvars),group);
Xend;
X
Xsymbolic procedure tensortranspos(tensor,n);
Xbegin
X  scalar i,j,k,res;
X  res:= for i:=1:(n+1) collect
X    for j:=1:n collect
X      nth(nth(tensor,j),i);
X  return res;
Xend;
X
Xsymbolic procedure getblockDAz(pos,ni,bb,n,nsym);
Xbegin
X  scalar zvec,i,j,k,res,sum;
X % print list("in getblockDAz  pos, ni ",pos,"  ",ni);
X  if numr ni then ni:=numr ni else ni:=0;
X % print list("ni",ni);
X  zvec:=for i:=1:ni collect
X    simp list('z,i);
X  if numr pos then pos:=numr pos else pos:=0; 
X % print list("zvec, pos ",zvec,pos);
X  res:=for i:=(pos+1):(pos+ni) collect
X    for j:=1:nsym collect
X      <<% print list("in schleife",i,j);
X         sum:=nil ./ 1;
X         for k:=(pos+1):(pos+ni) do
X         sum:=addsq(sum,multsq(nth(nth(nth(bb,i),k),j),nth(zvec,k-pos)));
X         sum
X      >>;
X  n:=n+1;
X  res:=for i:=(pos+1):(pos+ni) collect
X    << 
X        sum:=nil ./ 1;
X        for k:=(pos+1):(pos+ni) do
X        sum:=addsq(sum,multsq(nth(nth(nth(bb,i),k),n),nth(zvec,k-pos)));
X        append(nth(res,i-pos),list(sum))
X    >>;
X  return res;
Xend;
X
X
Xsymbolic procedure tensortransform(b,m,mm1,n);
X% b -- tensor, list of lists of lists of sq
X% m -- matrix, list of lists of sq
X% n -- integer
Xbegin
X  scalar i,j,l,k,sum,bb; 
X % print list("in tensortransform tensor",b);
X % print list("in tensortransform matrix m ",m);
X % print list("in tensortransform matrix mm1 ",mm1);
X  bb:=for i:=1:n collect
X    for l:=1:n collect
X      for k:=1:(n+1) collect
X       <<
X          sum:=nil ./ 1;
X          for j:=1:n do sum:=addsq(sum,
X  multsq(nth(nth(nth(b,i),j),k),nth(nth(m,j),l)));
X          sum
X       >>;
X% print list("in tensortransform tensor*m",bb);
X  bb:=for i:=1:n collect
X    for l:=1:n collect
X      for k:=1:(n+1) collect
X       <<
X          sum:=nil ./ 1;
X          for j:=1:(n+1) do sum:=addsq(sum,
X  multsq(nth(nth(nth(bb,i),l),j),nth(nth(mm1,j),k)));
X          sum
X       >>;
X% print list("in tensortransform tensor*m*mm1",bb);
X
X  m:=mkmattrans(m);
X  bb:=for i:=1:n collect
X    for k:=1:n collect
X      for l:=1:(n+1) collect
X        <<
X           sum:=nil ./ 1;
X           for j:=1:n do sum:=addsq(sum,
Xmultsq(nth(nth(m,i),j),nth(nth(nth(bb,j),k),l)));
X           sum
X        >>;
X % print list("schluss von tensortransform tensor",bb);
X  return bb;
Xend;
X
Xsymbolic procedure tensor1transform(b,m,mm1,n,nsym);
X% b -- tensor, list of lists of lists of sq
X% m -- matrix, list of lists of sq
X% mm1 -- matrix m + 1
X% n -- integer
Xbegin
X  scalar n1,i,j,l,k,sum,bb,bb1,vecz,vec;
X  nsym:=numr nsym;
X  n1:=n+1;
X % print list("n,nsym",n,nsym);
X  vecz:=append(
X     for i:=1:nsym collect list(simp list('z,i)),
X     for i:=1:(n-nsym) collect list(nil ./ 1));
X % print list("vecz",vecz);
X  vecz:=mkmatvek(m,vecz); 
X % print list("vecz",vecz);
X  bb:=for i:=1:(n1) collect
X      for k:=1:n1 collect
X       <<
X          sum:=nil ./ 1;
X          for j:=1:n do sum:=addsq(sum,
X  multsq(nth(nth(nth(b,i),j),k),car nth(vecz,j)));
X          sum
X       >>;
X%  print list("matrix bb",bb);
X  bb:=matmult(bb,mm1);
X % print list("letzte Spalte von bb");
X % for j:=1:(n+1) do print list("bb",j,nth(nth(bb,j),n1));
X  mm1:=mkmattrans(mm1);
X % print list("mm1",mm1);
X  bb1:=for i:=1:nsym collect
X      for l:=i:nsym collect
X        <<
X        %   print list("in schleife",i,l);
X           sum:=nil ./ 1;
X           for j:=1:(n+1) do sum:=addsq(sum,
Xmultsq(nth(nth(mm1,i),j),nth(nth(bb,j),l)));
X         %  print list("sum",sum);
X           sum
X        >>;
X  i:=0;
X%  print list("schleifen fertig");
X  bb1:=for each z in bb1 collect
X     append(z,list(
X      <<sum:= nil ./ 1;
X         i:=i+1;
X          for j:=1:n1 do sum:=addsq(sum,
Xmultsq(nth(nth(mm1,i),j),nth(nth(bb,j),n1)));
X      %  print list("sum fuer index",i," ",sum);
X        sum
X      >>));
X % vec:=for i:=1:(nsym+1) collect nth(nth(bb,n1),i);
X  vec:=list( nth(nth(bb,n1),n1));
X  bb:=append(bb1,list(vec));
X % print list("matrix mm1^T*bb*mm1",bb);
X  return bb;
Xend;
X
Xsymbolic procedure substtensor(gjacjac,assocvars);
Xbegin
X  scalar s,z,xx,res;
X  res:=for each z in gjacjac collect
X      for each s in z collect
X         for each xx in s collect subsq(xx,assocvars);
X  return res;
Xend;
X
Xsymbolic procedure mkraus(ma1);
Xbegin
X  scalar s,z,res;
X  writepri(" ",'last);
X  writepri("new matrix",'last);
X  writepri(" ",'last);
X  res:=for each z in ma1 collect
X    for each s in z collect prepsq s;
X  res:=cons('mat,res);
X  writepri(list('aeval,mkquote res),'last);
Xend;
X
Xprocedure switchout();
Xbegin
X  gentranpush"genhelp.c";
Xend;
X
Xprocedure switchbak();
Xbegin
X  gentranpop nil;
Xend;
X
Xsymbolic procedure mktest(supgib,subg,group,nsym,cmat);
X% makes testvector for break up test from subg to car supgib
Xbegin
X  scalar nulltup,tup,newtup,n,i,supernicis,mi,ni,ci,tstkomp1,helplist,storn,count;
X  storn:=mkid(mkid('!*,group),mkid(subg,car supgib));
X  tup:=for i:=1:nsym collect list(simp list('u,i));
X  n:=length(cmat);
X  nulltup:=for i:=1:(n-nsym) collect list(nil ./ 1);
X  tup:=append(tup,nulltup);
X  tup:=mkmatvek(cmat,tup);  % tup in oberster Gruppe
X  cmat:=get(mkid(mkid('!*,group),mkid(car supgib,'!*) ),'cmat);
X  tup:=mkmatvek(mkmattrans(cmat),tup); 
X        % tup in Obergruppe, die Untergr. von group ist
X  supernicis:=get(mkid(mkid('!*,group),mkid(car supgib,'!*) ),'nici);
X  count:=0;
X  newtup:=nil;
X  for i:=1:length(supernicis) do
X    << ci:=numr cadr nth(supernicis,i);
X       ni:=numr car nth(supernicis,i);
X       if not ci then ci:=0;
X       if not ni then ni:=0;
X     %  print list("isotyp.comp.,ni,ci",i,ni,ci);
X     %  if cadr supgib = i then
X       if member(i,cdr supgib) then
X         <<
X          % ist tup in den Komponenten ungleich null,  sind bei mehrdim.
X          % die komponeneten vielfaches voneinander?
X          tstkomp1:=car nth(tup,count+1);
X        %  print list("tstcomp1",tstkomp1);
X          helplist:=nil;
X          if null(numr tstkomp1) then 
X             <<
X               count:=count+ci;
X               ni:=ni-1;
X               tstkomp1:=1 ./ 1;
X             >> else
X             <<
X               ni:=ni-1;
X               helplist:=for j:=1:ci  collect 
X                   <<count:=count+1;
X                     nth(tup,count)>>;
X               newtup:=append(newtup,helplist);
X             >>;
X          if ni>0 then
X              <<
X                tstkomp1:=quotsq( car nth(tup,count+1),tstkomp1);
X                 tstkomp1:=simp replacesqrt(tstkomp1);
X
X                if null(numr tstkomp1) or numberp(numr tstkomp1) then 
X                    <<
X                      count:=count+ci;
X                      ni:=ni-1;
X                      tstkomp1:=1 ./ 1;
X                    >> else
X                    <<
X                       ni:=ni-1;
X                       helplist:=for j:=1:ci  collect 
X                          <<count:=count+1;
X                            nth(tup,count)>>;
X                       newtup:=append(newtup,helplist);
X                    >>;
X              >>;
X          if ni>0 then
X              <<
X                tstkomp1:=quotsq( car nth(tup,count+1),tstkomp1);
X                 tstkomp1:=simp replacesqrt(tstkomp1); 
X                if null(numr tstkomp1) or numberp(numr tstkomp1) then 
X                   <<
X                      count:=count+ci;
X                      ni:=ni-1;
X                      tstkomp1:=1 ./ 1;
X                   >> else
X                   <<
X                      ni:=ni-1;
X                      helplist:=for j:=1:ci  collect 
X                        <<count:=count+1;
X                          nth(tup,count)>>;
X                      newtup:=append(newtup,helplist);
X                  >>;
X              >>;
X         >> else
X             count:=count+ci*ni;
X    >>;
X  put(storn,'testdim,length(newtup)); 
X  return newtup;
Xend;
X
XSYMBOLIC PROCEDURE GENTEST(fktmat,subg,supergroup);
X% makes a C-procedure with output test with names with subg
X% using gentran
XBEGIN
X  SCALAR gentlist,eqs,decls,args,fktname,comp,i;
X % PRINT LIST("aufruf von gentest",fktmat,subg,supergroup);
X  fktname:=MKID(MKID('!t!e!s!t,subg),supergroup);
X  decls:= LIST('DECLARE, LIST('!s!t!a!t!i!c! !v!o!i!d,fktname),
X                       LIST('DOUBLE, LIST('U,'TIMES), LIST('!t,'TIMES)));
X  args:= LIST('U,'!t);
X  i:=0;
X  eqs:=FOR EACH comp IN fktmat COLLECT
X    <<i:=i+1;
X      LIST('SETQ, LIST('!t,i),replacesqrt(CAR comp))
X    >>;
X  gentlist:= LIST('PROCEDURE,fktname,'NIL,'EXPRN,args,
X                 APPEND( LIST('BLOCK,'NIL,decls),eqs));
X % print list("in GENTEST groups",subg,supergroup);
X  EVAL LIST('GENTRAN,mkquote gentlist,'NIL);
XEND;
X
XSYMBOLIC PROCEDURE mknewjac(gjac,assocvars,cmat);
X% C^t*Dg(Cu)*C
Xbegin
X  scalar resjac,i,j,n,lastc;
X % print list("in mknewjac");
X  resjac:=mymatinsert(gjac,assocvars);
X  resjac:=matmult(mkmattrans(cmat),resjac);
X  n:=length(cmat);
X  lastc:=for i:=1:n collect list(nth(nth(resjac,i),n+1));
X  resjac:=for i:=1:n collect
X    for j:=1:n collect nth(nth(resjac,i),j);
X  resjac:=matmult(resjac,cmat);
X  resjac:=for i:=1:n collect append(nth(resjac,i),nth(lastc,i));
X % print list("mknewjac finished");
X  return resjac;
Xend;
X
XSYMBOLIC PROCEDURE MKINITIAL(isogroups,noncgs,SUPERGPIS,SUBG,GROUP,SUBNICIS,
X  SUBJACNRS);
X% MAKES THE C-PROZEDURE WHICH INITIALIZES THE GROUP
XBEGIN 
X  SCALAR 
X    GENTLIST,EQS,DECLS,ARGS,PNAME,EQHELP,NR,di,TUP,fkttyp,gr,storn,i;
X % print list("in mkinitial",subg);
X  if subg=group then GENALLOCGROUPS(isogroups,group,noncgs);
X %  print list("nach allocg");
X  if subg=group then PNAME:=MKID('!i!n!i!t!_,'!g!r!o!u!p) else
X    PNAME:=MKID('!i!n!i!t!_,subg);
X  if subg=group then 
X       fkttyp:=list('!v!o!i!d,pname) else
X       fkttyp:=list('!s!t!a!t!i!c! !v!o!i!d,pname);
XDECLS:=LIST('DECLARE,fkttyp,  %LIST('G!r!o!u!p,MKID('!*,subgname)),
X                       LIST('!s!t!i!l!l!&!l!e!i!s!eINTEGER,
X                                           MKID(subg,'!-!>!m),
X                                      %     MKID(subg,'!-!>!n!o),
X                                           MKID(subg,'!-!>!n!t!e!s!t),
X                                           MKID(subg,'!-!>!i!b!r!e!a!k))
X                   );
X  if not(subg=group) then decls:=append(decls,list(list('O!p,'!*!o!p)));
X  if subg=group then
X    <<
X      eqs:=for each gr in cdr reverse isogroups collect
X           list(mkid('!i!n!i!t!_, gr));
X      eqhelp:=list('!a!l!l!o!c!g!r!o!u!p!s);
X      eqs:=cons(eqhelp,eqs);% 
X      eqhelp:=numinits();
X      eqs:=append(eqhelp,eqs);
X    >>;
X  EQHELP:=LIST('SETQ,MKID(subg,'!-!>!l!a!b!e!l),MKID(MKID('!",SUBG),'!")); 
X  EQS:=APPEND(EQS,LIST(EQHELP));
X  EQHELP:=LIST('SETQ,MKID(subg,'!-!>!i!m!p!l!e!m!e!n!t!e!d),
X       if member(subg,noncgs) then 'TRUE else 'FALSE); 
X  EQS:=APPEND(EQS,LIST(EQHELP));
X  EQHELP:=LIST('SETQ,MKID(subg,'!-!>!t!r!a!n!s!f!o!r!m),
X       MKID('!t!r!a!n!s!f!o!r!m,SUBG));  % TRANS
X  EQS:=APPEND(EQS,LIST(EQHELP));
X  EQHELP:=LIST('SETQ,MKID(subg,'!-!>!i!n!v!_!t!r!a!n!s!f!o!r!m),
X      MKID('!i!n!v!t!r!a!n!s!f!o!r!m,SUBG)); 
X  EQS:=APPEND(EQS,LIST(EQHELP));
X%  print list("for chooseop");
X  eqs:=append(eqs,chooseoperations(group,subg));
X   % EQHELP:=FOR NR:=1:LENGTH(SUBNICIS) COLLECT
X  eqhelp:=for i:=1:length(subjacnrs) collect
X      <<
X         nr:=nth(subjacnrs,i);
X         IF LENGTH(NTH(SUBNICIS,NR))=2 THEN
X            di:=CADR NTH(SUBNICIS,NR) ELSE
X       di:= MULTSQ(CADR NTH(SUBNICIS,NR),CAR NTH(SUBNICIS,NR)) ;%complex case
X         LIST('SETQ,LIST(MKID(subg,'!-!>!m),i),
X         PREPSQ di)
X       >>;
X  EQS:=APPEND(EQS,EQHELP);
X  if member(subg,noncgs) then
X    <<
X      EQHELP:=LIST('SETQ,MKID(subg,'!-!>!g),MKID('!g,SUBG));  % FCT.
X      EQS:=APPEND(EQS,LIST(EQHELP));
X      i:=0;
X      EQHELP:=FOR EACH NR IN  SUBJACNRS COLLECT 
X         <<i:=i+1;
X           LIST('SETQ,LIST(MKID(subg,'!-!>!d!g),i),MKID(MKID('!d!g,SUBG),NR))
X         >>; 
X      EQS:=APPEND(EQS,EQHELP); % SUBPARTS OF JACOBIAN
X      i:=0;
X      EQHELP:=FOR EACH NR IN SUBJACNRS COLLECT 
X         << i:=i+1;
X            LIST('SETQ,LIST(MKID(subg,'!-!>!c!g),i),MKID(MKID('!c!g,SUBG),NR))
X         >>; 
X      EQS:=APPEND(EQS,EQHELP);
Xif !*numericmode then
X   <<
X      i:=0;
X      EQHELP:=FOR EACH NR IN SUBJACNRS COLLECT 
X         << i:=i+1;
X            LIST('SETQ,LIST(MKID(subg,'!-!>!i!s!o!_!t!r!a!n!s!f!o!r!m),i),
X                   MKID(MKID('!t!r!a!n!s,NR),SUBG))
X         >>; 
X      EQS:=APPEND(EQS,EQHELP);
X      i:=0;
X      EQHELP:=FOR EACH NR IN SUBJACNRS COLLECT 
X         << i:=i+1;
X      LIST('SETQ,LIST(MKID(subg,'!-!>!i!n!v!_!i!s!o!_!t!r!a!n!s!f!o!r!m),i),
X                   MKID(MKID('!i!n!v!t!r!a!n!s,NR),SUBG))
X         >>; 
X      EQS:=APPEND(EQS,EQHELP);
X   >>;
X   >>;
X% subgroups will be treated
X  EQS:=APPEND(EQS,MKSUBTREE(group,length(subnicis),
X                            SUBG,CDR SUBJACNRS,noncgs));
X%print list("nach subgr");
X% supergroups will be treated
X  if member(subg,noncgs) then
X    <<
X       NR:=0;
X       EQHELP:=FOR EACH TUP IN SUPERGPIS COLLECT 
X          << NR:=NR+1;
X             LIST('SETQ,LIST(MKID(subg,'!-!>!t!e!s!t),NR),
X                          MKID(MKID('!t!e!s!t,SUBG),car tup))
X          >>;
X       EQS:=APPEND(EQS,EQHELP);
X       NR:=0;
X       EQHELP:=FOR EACH TUP IN SUPERGPIS COLLECT 
X           << NR:=NR+1;
X              storn:=mkid(mkid('!*,group),mkid(subg,car tup));
X              LIST('SETQ,LIST(MKID(subg,'!-!>!n!t!e!s!t),NR),
X                   get(storn,'testdim))
X           >>;
X       EQS:=APPEND(EQS,EQHELP);
X    >>;% end of if member(subg,noncgs) 
X%  NR:=0;
X%  EQHELP:=FOR EACH TUP IN SUPERGPIS COLLECT 
X%     << NR:=NR+1;
X%  LIST('SETQ,LIST(MKID(subg,'!-!>!i!b!r!e!a!k),NR),
X%                       mkisonr(cadr tup,car tup,group))
X%     >>;
X%  EQS:=APPEND(EQS,EQHELP);
X  NR:=0;
X  FOR EACH TUP IN SUPERGPIS do
X     << NR:=NR+1;% car tup is a group
X        eqhelp:=LIST('SETQ,LIST(MKID(subg,'!-!>!s!u!p!e!r!g!r!o!u!p),NR)
X                         ,car tup);
X        EQS:=APPEND(EQS,list(EQHELP));
X     >>;
X  EQHELP:=LIST('SETQ,MKID(subg,'!-!>!n!e!x!t),
X      findnext(reverse isogroups,subg)); 
X  EQS:=APPEND(EQS,LIST(EQHELP));
X  EQHELP:=LIST('SETQ,MKID(subg,'!-!>!n!o),
X       mkid(subg,'!_NO));
X  EQS:=APPEND(EQS,LIST(EQHELP));
X
X  GENTLIST:=LIST('PROCEDURE,PNAME,'NIL,'EXPR,'NIL,
X                 APPEND(LIST('BLOCK,'NIL,DECLS),EQS));
X  %print list("gentlist");
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
XEND;
X
Xsymbolic procedure chooseoperations(group,subg);
Xbegin
X  scalar transl,storename,nrelem,eqs;
X  eqs:=nil;
X  storename:=mkid(mkid('!*,group),mkid(subg,'!*));
X  transl:=get(storename,'ops);
X  eqs:=for each nrelem in transl collect
X        LIST('!a!p!p!e!n!d!_!o!p,subg,
X              mkid(mkid(group,'!_!p!r!o!c!_),nrelem),
X              mkid(mkid(group,'!_!p!r!o!c!_),inverse(group,nrelem)),
X              mkid('!c!h!a!n!g!e!_!g!r!o!u!p!_,nrelem),
X              mkid('!i!s!o!t!y!p!i!c!_,fdiso(group,subg,nrelem)));
X  return eqs;
Xend;
X
X%append_op(S3, proc_r2, proc_r2, group_triv, isotypic_triv);
X
Xsymbolic procedure fdiso(group,subg,nrelem);
Xbegin
X  scalar storename;
X  storename:=mkid(mkid('!*,group),mkid(subg,'!*));
X  if length(get(storename,mkid('isol,nrelem)))> 0 then 
X      return mkid(mkid(subg,'!_),nrelem) else
X  return '!t!r!i!v;
Xend;
X
Xsymbolic procedure mkisonr(nr,subg,group);
X% computes the position of isotyp. comp nr in aktuell list
Xbegin
X  scalar nici,i,count;
X  nici:=get(mkid(mkid('!*,group),mkid(subg,'!*)),'nici);
X  count:=0;
X  for i:=1:nr do
X    if numr cadr nth(nici,i) then count:=count+1;
X  return count;
Xend;
X
Xsymbolic procedure findnext(isogroups,subg);
X    if length(isogroups)>1 then
X      <<
X        if car isogroups = subg then cadr isogroups else
X              findnext(cdr isogroups,subg) 
X      >> else '!n!i!l;
X
XSYMBOLIC PROCEDURE MKSUBTREE(group,ISOANZ,SUBG, SUBJACNRS,noncgs);
X% SUBJACNRS -- list of nr of important isotyp. comp.
XBEGIN
X  SCALAR GENEQS,IGT,COMP,ISONR,GROUPNR,GROUPLIST,EQHELP,GROUP1,akiso,gcount;
X % print list("in mksubtree",group,subg,isoanz,subjacnrs);
X  IGT:= ISOGROUPTREE(SUBG);
X  GENEQS:=NIL;
X  FOR ISONR:=2:ISOANZ DO
X    <<
X      IF (length(igt)>0) and (CAAR IGT = ISONR) THEN
X        <<
X          GROUPLIST:=CDR CAR IGT;
X          IGT:=CDR IGT;
X        >>;
X      IF (length(subjacnrs)>0) and (CAR SUBJACNRS = ISONR) THEN
X        <<
X          SUBJACNRS:=CDR SUBJACNRS;
X          akiso:=mkisonr(ISONR,subg,group);
X          GCOUNT:=0;
X       %   print list("mksubtree",grouplist,akiso,SUBJACNRS,isonr);
X          FOR EACH GROUP1 IN GROUPLIST do
X           <<
X     %         if member(group1,noncgs) then
X               if not(flagp(mkid(mkid(group1,'in),subg),'conjugate) ) then
X                <<
X                  GCOUNT:=GCOUNT+1;
X                  eqhelp:= LIST('SETQ,
X                       LIST(MKID(subg,'!-!>!s!u!b!g!r!o!u!p),akiso,GCOUNT),
X                                  group1);
X                  GENEQS:=APPEND(GENEQS,list(EQHELP));
X                  eqhelp:=  LIST('SETQ,
X                       LIST(MKID(subg,'!-!>!s!y!m!m!e!t!r!i!c),akiso,GCOUNT),
X                                 findsymm(subg,group1));
X                  GENEQS:=APPEND(GENEQS,list(EQHELP));
X             %     if member(subg,noncgs) then
X             %        <<
X                       eqhelp:=LIST('SETQ,
X                         LIST(MKID(subg,'!-!>!t!a!n!g!e!n!t),akiso,GCOUNT),
X                         MKID(MKID('!t!a!n!g!e!n!t,SUBG) ,
X                         MKID('!n!a!c!h,GROUP1))   );
X                        GENEQS:=APPEND(GENEQS,list(EQHELP));
X              %       >>;
X                >>;% end of if member(
X           >>;% end of for each
X        grouplist:=nil;
X        >>; %end of IF CAR SUBJACNRS = ISONR
X    >>; 
X  RETURN GENEQS;
XEND;
X
Xsymbolic procedure findsymm(subg,subg2);
X   if flagp(mkid(mkid(subg2,'in),subg),'symmetric) then  'TRUE  else 'FALSE;
X
Xsymbolic procedure anzsubgs(subg,nr,noncgs);
X% determines the number of symmetry breaking groups from iso. comp. nr
Xbegin
X  scalar comp,anz;
X  for each comp in isogrouptree(subg) do
X    if car comp = nr then 
X                 %anz:=length(intersection(cdr comp,noncgs));
X      <<
X         anz:=0;
X         for each g in cdr comp do 
X           if not(flagp(mkid(mkid(g,'in),subg),'conjugate)) then anz:=anz+1;
X      >>;
X  return anz;
Xend;
X
XSYMBOLIC PROCEDURE GENTANGENT(NR,SUBG,YL);
X% GENERATE TRANSFUNCTION Z -> Y DEPENDING ON NR and isogroup
X% yl is a list of lists with isogroups and directions 
XBEGIN
X  SCALAR GENTLIST,EQS,DECLS,ARGS,FKTNAME,COMP,I,pairgt;
X % print list("in gentangetn");
X  FOR EACH pairgt IN YL DO
X  <<
X  FKTNAME:=MKID(MKID('!t!a!n!g!e!n!t,SUBG),MKID('!n!a!c!h,CAR pairgt));
X  DECLS:=LIST('DECLARE,LIST('!s!t!a!t!i!c! !v!o!i!d,FKTNAME),
X                       LIST('DOUBLE,LIST('Z,'TIMES),LIST('!y,'TIMES)));
X  ARGS:=LIST('Z,'!y);
X  I:=0;
X  EQS:=FOR EACH COMP IN CADR pairgt COLLECT
X    <<I:=I+1;
X     LIST('SETQ,LIST('!y,I),replacesqrt(CAR COMP))
X    >>;
X  GENTLIST:=LIST('PROCEDURE,FKTNAME,'NIL,'EXPR,ARGS,
X                 APPEND(LIST('BLOCK,'NIL,DECLS),EQS));
X  EVAL LIST('GENTRAN,MKQUOTE GENTLIST,'NIL);
X  >>;
XEND;
X
Xsymbolic procedure mktangent(group,subg,nr,m,cmat,subnicis,noncgs);
X% how to lift a tangent z to a tupel y depending on isotypical comp. nr
Xbegin
X  scalar i,j,tup,tup1,ci,dimbefore,dimafter,nulltup,comp,res,cneu,isogci,len;
X % print list("in mktangent");
X  ci:=numr cadr nth(subnicis,nr);
X  if not ci then ci:=0;
X  dimbefore:=nil;
X  for i:=1:(nr-1) do
X    <<
X      % if length(nth(subnicis,i))=2 then
X        len:=multsq(car nth(subnicis,i),cadr nth(subnicis,i));% else
X       % len:= cadr nth(subnicis,i); % complex case
X     dimbefore:=addf(dimbefore,numr len);
X       %    numr multsq(car nth(subnicis,i),cadr nth(subnicis,i)));
X    >>;
X  if not dimbefore then dimbefore:=0;
X  dimafter:=nil;
X  for i:=(nr+1):length(subnicis) do
X   <<
X      % if length(nth(subnicis,i))=2 then
X        len:=multsq(car nth(subnicis,i),cadr nth(subnicis,i));% else
X       % len:= cadr nth(subnicis,i); % complex case
X     dimafter:=addf(dimafter,numr len);
X      %     numr multsq(car nth(subnicis,i),cadr nth(subnicis,i)));
X   >>;
X  if not dimafter then dimafter:=0;
X  nulltup:=for i:=1:dimbefore collect list(nil ./ 1);
X  % Schleife ueber Multiplizitaet
X  if length(nth(subnicis,nr))=2 then len:=numr car nth(subnicis,nr) else
X    % len:=1; % complex case
X    print list("impossible case in mktangent");
X  for j:=1:len do
X    <<
X       tup:=for i:=1:ci collect list multsq(j ./ 1,simp list('z,i));
X       nulltup:=append(nulltup,tup);
X    >>;
X  tup:=nulltup;
X  nulltup:=for i:=1:(dimafter) collect list(nil ./ 1);
X  tup:=append(tup,nulltup);
X % print list("tangents,group,subgroup,nr",group,subg,nr,tup);
X  %print list("length of tupel",length(tup));
X  tup:=mkmatvek(cmat,tup);
X  for each comp in isogrouptree(subg) do
X    if car comp = nr then 
X      res:=for each isogroup in cdr comp join 
X   %       if member(isogroup,noncgs) then list
X          if not(flagp(mkid(mkid(isogroup,'in),subg),'conjugate)) then list
X       <<
X          cneu:=get(mkid(mkid('!*,group),mkid(isogroup,'!*)),'cmat);
X         % print list("cneu gegriffen");
X          tup1:=mkmatvek(mkmattrans(cneu),tup);
X         % print list("tup erstellt");
X isogci:=numr(cadr car get(mkid(mkid('!*,group),mkid(isogroup,'!*)),'nici));
X       %   print list("groups",group,isogroup);  
X % print list("nicis",get(mkid(mkid('!*,group),mkid(isogroup,'!*)),'nici));  
X %  print list("multi",cadr car get(mkid(mkid('!*,group),mkid(isogroup,'!*)),'nici));  
X        %  print list("isogci",isogci);
X          tup1:=for i:=1:isogci collect nth(tup1,i);
X          tup1:=append(tup1,list(list( nil ./ 1)));
X         % print list("tup verkleinert");
X          list(isogroup,tup1)
X       >>; 
X % print list("ende von mktangent",res);
X  return res;
Xend;
X
Xsymbolic procedure mkinvuy(m,cmat,symvars,nsym);
X% makes inverse transformation from y via w to u
Xbegin
X  scalar eql,i,j,n,tup,aslhelp;
X  n:=length(m);
X  tup:=for i:=1:n collect list(simp list('y,i));
X  tup:=mkmatvek(mkmattrans(m),tup);
X  tup:=mkmatvek(mkmattrans(cmat),tup);
X  eql:=for i:=1:nsym collect car nth(tup,i);
X  aslhelp:= list( simp list('y,n+1) );
X  eql:=append(eql,aslhelp);
X  return eql;
Xend;
X
XSYMBOLIC PROCEDURE GENINVUY(SUBG, EQL); %geninvuy GENINVUY
X% MAKES A C-PROCEDURE WITH OUTPUT INVTRANSFORM WITH NAMES WITH SUBG
X% USING GENTRAN
XBEGIN
X  SCALAR GENTLIST,EQS,DECLS,ARGS,FKTNAME,COMP,I;
X%  PRINT LIST("IN GENINVUY EQL",EQL);
X  FKTNAME:=MKID('!i!n!v!t!r!a!n!s!f!o!r!m,SUBG);
X  DECLS:=LIST('DECLARE,LIST('!s!t!a!t!i!c! !v!o!i!d,FKTNAME),
X                       LIST('DOUBLE,LIST('!u,'TIMES),LIST('Y,'TIMES)));
X  ARGS:=LIST('Y,'!u);
X  I:=0;
X  EQS:=FOR EACH COMP IN EQL COLLECT
X    <<I:=I+1;
X %     PRINT LIST("GENINVUY EINGANG GENTRAN",CAR COMP,PREPSQ CADR COMP);
X     LIST('SETQ,LIST('!u,I),replacesqrt(COMP))  %CDR COMP ?
X    >>;
X  GENTLIST:=LIST('PROCEDURE,FKTNAME,'NIL,'EXPR,ARGS,
X                 APPEND(LIST('BLOCK,'NIL,DECLS),EQS));
X  EVAL LIST('GENTRAN,mkquote GENTLIST,'NIL);
XEND;
X
X
XSYMBOLIC PROCEDURE GENYMWU(SUBG, MYVEC);
X% MAKES A C-PROCEDURE WITH OUTPUT TRANSFORM WITH NAMES WITH SUBG
X% USING GENTRAN
XBEGIN
X  SCALAR GENTLIST,EQS,DECLS,ARGS,FKTNAME,COMP,I;
X  FKTNAME:=MKID('!t!r!a!n!s!f!o!r!m,SUBG);
X  DECLS:=LIST('DECLARE,LIST('!s!t!a!t!i!c! !v!o!i!d,FKTNAME),
X                       LIST('DOUBLE,LIST('U,'TIMES),LIST('!y,'TIMES)));
X  ARGS:=LIST('U,'!y);
X  I:=0;
X  EQS:=FOR EACH COMP IN MYVEC COLLECT
X    <<I:=I+1;
X     LIST('SETQ,LIST('!y,I),replacesqrt(CAR COMP))
X    >>;
X  GENTLIST:=LIST('PROCEDURE,FKTNAME,'NIL,'EXPR,ARGS,
X                 APPEND(LIST('BLOCK,'NIL,DECLS),EQS));
X  EVAL LIST('GENTRAN,mkquote GENTLIST,'NIL);
XEND;
X
Xsymbolic procedure mkymwu(m,cmat,symvars,nsym);
X% transformation of symmetric vector u to y=M~ w
Xbegin
X  scalar resmat,pr,lcomp,len,i,nullvek;
X % print list("in mkynwu");
X  len:=length(m);
X  nullvek:=for i:=1:(len-nsym) collect list(nil ./ 1);
X % print list("nullvek",nullvek);
X  resmat:=for i:=1:nsym collect list(simp nth( symvars,i));
X % print list("resmat 1",resmat);
X  resmat:=append(resmat,nullvek);
X % print list("resmat   2 ",resmat);
X  resmat:=mkmatvek(m, mkmatvek(cmat,resmat));
X % print list("resmat       3",resmat);
X  resmat:=append(resmat,list(list(simp nth( symvars,nsym+1))));
X  %print list("end of mkymwu");
X  return resmat;
Xend;
X
Xsymbolic procedure mkpjacsc(nr,partjac,vars);
X% makes derivatives of subparts of the jacobian
Xbegin
X % print list("second derivatives");
X  if nr=1 then return mkpjacsc1(partjac,vars) else 
X       return mkpjacsc2(partjac,vars);
Xend;
X
Xsymbolic procedure mkpjacsc1(partjac,vars);
X% makes derivatives of subparts of the jacobian (trivial case -- matrix C)
Xbegin
X  scalar tppjac,zvec,i,np1;
X % print list("in mkpjacsc1");
X % print list("partjac",partjac);
X  tppjac:=mkmattrans(partjac);
X % print list("tppjac",tppjac);
X  zvec:=for i:=1:(length(partjac)) collect
X    list(simp list('z,i));
X  tppjac:=mkmatvek(tppjac,zvec);
X % print list("tppjac   2.tens",tppjac);
X  tppjac:=mkjac(tppjac,vars);
X % print list("schluss von  mkpjacsc1");
X % only upper matrix is needed
X  np1:=length(car tppjac);
X % mkraus(tppjac);
X  tppjac:=for i:=1:np1 collect
X             for j:=i:np1 collect nth(nth(tppjac,i),j);
X % tppjac stands for an upper matrix but is given in lists of lists with 
X % decreasing number of arguments
X
X  return tppjac;
Xend;
X
Xsymbolic procedure mkpjacsc2(partjac,vars);
X% makes derivatives of subparts of the jacobian
Xbegin
X  scalar tppjac,zvec,i;
X % print list("in mkpjacsc2");
X  zvec:=for i:=1:(length(partjac)) collect
X    list(simp list('z,i));
X  tppjac:=mkmatvek(partjac,zvec);
X  tppjac:=mkjac(tppjac,vars);
X  %print list("schluss von  mkpjacsc2");
X % mkraus(tppjac);
X  return tppjac;
Xend;
X
X
XSYMBOLIC PROCEDURE GENPJACSC(NR,SUBG,MAC,group);
X% WRITE DERIVATIVE OF PARTJAC  * Z IN C WITH GENTRAN
XBEGIN
X  SCALAR GENTLIST,EQS,DECLS,ARGS,FKTNAME;
X % PRINT LIST("IN GENPJACSC");
X  FKTNAME:=MKID(MKID('!c!g,SUBG),NR);
X  DECLS:=LIST('DECLARE,LIST(
X     if !*secondoutputfile and subg='Id then '!v!o!i!d else '!s!t!a!t!i!c! !v!o!i!d,
X                       FKTNAME),
X   LIST('DOUBLE,LIST('U,'TIMES),LIST('Z,'TIMES),
X %                  LIST('!o!r!g!_!d!d!f,'TIMES,'TIMES,'TIMES),
X                   LIST('!c,'TIMES,'TIMES)));
X%  ARGS:=LIST('U,'Z,'!o!r!g!_!d!d!f,'!c);
X  ARGS:=LIST('U,'Z,'!c);
X  if nr=1 then eqs:=genmac1(mac) else eqs:=genmac2(mac);
X  GENTLIST:=LIST('PROCEDURE,FKTNAME,'NIL,'EXPR,ARGS,
X                 APPEND(LIST('BLOCK,'NIL,DECLS),EQS));
X  EVAL LIST('GENTRAN,mkquote GENTLIST,'NIL);
X%  PRINT LIST("ENDE VON GENPJACSC");
XEND;
X
Xsymbolic procedure genmac1(mac);
X% eqs for gentran for matrix C in Newton method for system Moore
Xbegin
X  scalar i,j,eqs,s,z;
X % print list("in genmac1",mac);
X  I:=0;
X  EQS:=FOR EACH Z IN MAC JOIN
X    <<
X      J:=i;
X      I:=I+1;
X     % print list("i,j",i," ",j);
X      FOR EACH S IN Z COLLECT
X        <<
X           J:=J+1;
X         %  print list("j",j);
X           LIST('SETQ,LIST('!c,I,J),replacesqrt(S))
X        >>
X    >>;
X % print list("ende von genmac1");
X  return eqs;
Xend;
X
Xsymbolic procedure genmac2(mac);
X% eqs for gentran for matrix C in Newton method for system with symmetry
Xbegin
X  scalar i,j,eqs,s,z;
X % print list("in genmac2");
X  I:=0;
X  EQS:=FOR EACH Z IN MAC JOIN
X    <<
X      I:=I+1;
X      j:=0;
X      FOR EACH S IN Z COLLECT
X        <<
X           J:=J+1;
X           LIST('SETQ,LIST('!c,I,J),replacesqrt(S))
X        >>
X    >>;
X % print list("ende von genmac2");
X  return eqs;
Xend;
X
XSYMBOLIC PROCEDURE GENPARTJAC(NR,SUBG,PARTJAC,group);
X% WRITE PARTJAC IN C
XBEGIN
X  SCALAR GENTLIST,EQS,DECLS,ARGS,FKTNAME,S,Z,I,J,hugo;
X % PRINT LIST("IN GENPARTJAC PARTJAC",PARTJAC);
X  FKTNAME:=MKID(MKID('!d!g,SUBG),NR);
X  hugo:=LIST('DOUBLE,LIST('U,'TIMES),
X %       LIST('!o!r!g!_!d!f,'TIMES,'TIMES),
X        LIST('!d!g!u,'TIMES,'TIMES));
X  if !*secondoutputfile and subg='ID then
X     DECLS:=LIST('DECLARE,LIST('!v!o!i!d,FKTNAME),hugo) else
X     DECLS:=LIST('DECLARE,LIST('!s!t!a!t!i!c! !v!o!i!d,FKTNAME),hugo);
X % ARGS:=LIST('U,'!o!r!g!_!d!f,'!d!g!u);
X  ARGS:=LIST('U,'!d!g!u);
X  I:=0;
X  EQS:=FOR EACH Z IN PARTJAC JOIN
X    <<I:=I+1;
X      J:=0;
X      FOR EACH S IN Z COLLECT
X        <<
X           J:=J+1;
X           LIST('SETQ,LIST('!d!g!u,I,J),replacesqrt (S))
X        >>
X    >>;
X % PRINT LIST("EQS IN GENPARTJAC",EQS);
X  GENTLIST:=LIST('PROCEDURE,FKTNAME,'NIL,'EXPR,ARGS,
X                 APPEND(LIST('BLOCK,'NIL,DECLS),EQS));
X  EVAL LIST('GENTRAN,mkquote GENTLIST,'NIL);
XEND;
X
Xsymbolic procedure mkpartjac(gjacnew,nr,subnicis);
X% mkpartjac makes a subpart of the jacobian
Xbegin
X  scalar s,z,d,partjac,i,j,mi,n; 
X % print list("in mkpartjac");
X  n:=length(gjacnew);
X  d:=nil;
X  for i:=1:(nr-1) do  
X     d:=addf(d,numr multsq(car nth(subnicis,i),cadr nth(subnicis,i)));
X  if not d then d:=0;
X  mi:=numr cadr nth(subnicis,nr);
X  if length(nth(subnicis,nr))>2 then mi:=multf(mi,2); %complex case
X  if not mi then mi:=0;
X  partjac:=for i:=1:mi collect
X    for j:=1:mi collect  nth(nth(gjacnew,i+d),j+d);
X  if nr=1 then
X      partjac:=for i:=1:mi collect
X          append(nth(partjac,i),list(nth(nth(gjacnew,i),n+1)));
X % print list("partjac");
X % for each z in partjac do
X  %  for each s in z do print list("ele",s);
X  return partjac;
Xend;
X
X
X
Xsymbolic procedure mymatinsert(ma,assocvars);
X% substitutes in a matrix the symmetric vars
Xbegin
X  scalar s,z,res;
X  res:=for each z in ma collect
X      for each s in z collect
X         subsq(s,assocvars);
X % print list(" ");
X % print list("is the jacobian correct ? ");
X % for each z in res do
X  %    for each s in z do
X   %    print list(s);
X  return res;
Xend;
X
XSYMBOLIC PROCEDURE GENFKT(subfkt,subg,group);
X% makes a C-procedure with output subfkt with names with subg
X% using gentran
XBEGIN
X  SCALAR gentlist,eqs,decls,args,fktname,comp,i,hugo;
X % PRINT LIST("aufruf von genfkt");
X  fktname:=MKID('!g,subg);
X  hugo:=LIST('DOUBLE, LIST('U,'TIMES),
X%               LIST('!o!r!g!_!f,'TIMES),
X               LIST('!g,'TIMES));
X  if !*secondoutputfile and subg='ID then
X  decls:= LIST('DECLARE, LIST('!v!o!i!d,fktname),
X                       hugo) else
X  decls:= LIST('DECLARE, LIST('!s!t!a!t!i!c! !v!o!i!d,fktname),
X                       hugo);
X%  args:= LIST('U,'!o!r!g!_!f,'!g);
X  args:= LIST('U,'!g);
X  i:=0;
X  eqs:=FOR EACH comp IN subfkt COLLECT
X    <<i:=i+1;
X      LIST('SETQ, LIST('!g,i),replacesqrt (CAR comp))
X    >>;
X  gentlist:= LIST('PROCEDURE,fktname,'NIL,'EXPRN,args,
X                 APPEND( LIST('BLOCK,'NIL,decls),eqs));
X  EVAL LIST('GENTRAN,mkquote gentlist,'NIL);
XEND;
X
X
X%!procedure raiseaus(u);
X %  off raise;
X
X%procedure raisean(u);
X %  on raise;
X
Xsymbolic procedure mksymvars(anz,nsym,cmat); 
X% produces an assoclist wi's -- symmetric ugs
Xbegin
X  scalar i,symvars,asl,tup,nullsqs,sbstmat,aslhelp;
X  tup:=for i:=1:nsym collect list('u,i);
X  symvars:=append(tup,list(list('u,nsym+1)));
X  nullsqs:=for i:=1:anz-nsym collect list(nil ./1);
X  tup:= for each var in tup collect list(simp var);
X  tup:=append(tup,nullsqs);
X  sbstmat:=mkmatvek(cmat,tup);
X  asl:=for i:=1:anz collect
X               mkid('w,i) . prepsq car nth(sbstmat,i);
X  aslhelp:= list(mkid('w,anz+1) . nth(symvars,nsym+1));
X  asl:=append(asl,aslhelp);
X % print list("ersetzung fuer symmetrische variablen",asl);
X  return list(asl,symvars);
Xend;
X
Xsymbolic procedure myins(g,assocvars,nsym,cmat);
Xbegin
X  scalar res,z;
X  res:=mkmatvek(mkmattrans(cmat),g);
X     res:=for each z in res collect
X               list (subsq(car z,assocvars));
X  res:=for i:=1:nsym collect nth(res,i);  % first part of g
X  res:=for each z in res collect list(myresimp car z); % simplify
X % print list("symmetric function",res);
X  return res;
Xend;
X
X
Xsymbolic procedure mkjac(g,vars);
X% makes the jacobian of g as matrix of sq
X% g -- list of lists with one element
Xbegin
X  scalar i,n,res,fi,gi,varia;
X % print list("in mkjac");
X  n:=length(g);
X % print list("function",caar g);
X  res:=for each fi in g collect
X        for each varia in vars collect 
X         simp reval list('df ,prepsq car fi, varia);
X  %for each fi in res do
X  %  for each gi in fi do print list("func.",gi);
X  return res;           
Xend;
X
Xsymbolic procedure replacesqrt(u);
X% u ,v -- sq  output is an algebraic form
X% replace sqrt(2),sqrt(3) by sqrt2,sqrt3
X% replace SIN,COS,EXP by !sin,!c!o!s,!e!x!p
Xbegin
X  scalar v;
X%  print list("u=  ",u);
X%  print list("prepsq u=  ",prepsq u);
X % v:= eval list('simpsub,mkquote list(
X  v:= eval list('subeval,mkquote append (unsereliste,
X  % list(
X                   %     list('equal, list('sqrt,2) , 'sqrt2),
X                   %     list('equal, list('sqrt,3) ,  'sqrt3),
X                    %    list('equal, list('sqrt,6) ,  'sqrt6),
X                   %     list('equal, list('sqrt,37) ,  'sqrt37),
X                  %      list('equal, list('sqrt,111) ,  'sqrt111),
X                   %     list('equal, 'SIN ,  '!s!i!n),
X                   %     list('equal, 'COS ,  '!c!o!s),
X                                                 list( prepsq u)));  
X  return v;
Xend;
X
X%flag('(mkfcdec lispcodeassign dimcexp cexp1 fktp),'lose);
X
Xend;
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X%%% alconsym(f,xse,D4,{r**4,r,r**2,r**3,s,s*r,s*r**2,s*r**3});      %%%
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
END_OF_FILE
if test 64742 -ne `wc -c <'hybridconjug'`; then
    echo shar: \"'hybridconjug'\" unpacked with wrong size!
fi
# end of 'hybridconjug'
fi
if test -f 'hybridfirst' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'hybridfirst'\"
else
echo shar: Extracting \"'hybridfirst'\" \(17747 characters\)
sed "s/^X//" >'hybridfirst' <<'END_OF_FILE'
X% SYMCON hybridfirst 
Xoff echo$
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X%%
X%% functions for symmetry check and preparation (symmetric normal forms,
X%% connection matrices)  for hybridconjug
X%%
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Xsymbolic procedure  prepare(f,vars,group,grouplist,initdat);
Xbegin
X   scalar m,g,nicis,n,i,al,al1,c1,s,z,paras,oldvars,newvars;
X   unsereliste:=nil;  %is filled with sqrt's in suchen
X  % print list("in prepare");
X   paras:=findparas(f,vars);
X   m:=mktrmatrice(group,grouplist);
X   nicis:=car m;  %List with dimension and muliplicity 
X %  print list("in prepare dim,multiplicity",nicis);
X   m:=cadr m;  % transformation matrix
X %  print list("transformation matrix");
X %  printmat(m);
X   for each z in f do suchen(car z,nil);
X   for each z in m do
X     for each s in z do suchen(s,nil);
X %  print list("in prepare after suchen");
X   n:=length(f);
X   newvars:=for i:=1:(n+1) collect mkid('w,i);
X% make the symmetrical normal form for largest supergroup
Xif not(!*numericmode) then
X   <<
X   g:=transform(f,m,vars);        % g=m^t f (m * (ui,tau))
X %  print list("in prepare after transform");
X   oldvars:=mknewvars(n); 
X  % vars ersetzen, assoc liste bauen
X   %c1:=numr (cadr (car nicis));
X  % al:=for i:=1:c1 collect 
X   al:=for i:=1:n collect 
X        cons(nth(oldvars,i),prepf nth(newvars,i));
X   al:=append(al,list(cons(nth(vars,n+1),prepf  nth(newvars,n+1))));
X % verzweigungsparameter tau bleibt immer hinten
X   g:=for each z in g collect
X        for each s in z collect subsq(s,al);
X          %    print list("new variables replaced",timc()); 
X   g:=for each z in g collect
X        for each s in z collect myresimp s;
X  % print list("call  mkccode with ",g,m);
X %  print list ("symmetrical normal form");
X  >> else g:='numericg;
X   mkccode(f,g,m,nicis,initdat,vars,newvars,group,grouplist,paras);
X  % genfunctionsf(f,m);
Xend;
X
X
Xsymbolic procedure  suchen (x,y);
Xif atom x then nil else
X  if suchen1(x,y) then t else
X    if suchen (car x,y) then t else
X       suchen(cdr x,y);
X
Xsymbolic procedure  suchen1(x,y);
X  if atom x then nil else
X    if pairp car x then nil else
X     if and (eq(car x, 'expt),
X        fixp cadr x,
X        eqcar(caddr x,'quotient),
X        fixp cadr caddr x,
X        fixp caddr caddr x) then wurzliste(x) else nil;
X
Xsymbolic procedure wurzliste(x);
X  begin
X  scalar hh;
X  hh:=list('equal,car exchk(list(x . 1)) ,wurzname(x));
X  if member(hh,unsereliste) then nil else
X  unsereliste:=cons(hh,unsereliste);
X  end;
X
Xsymbolic procedure wurzname(x);
X  if equal(caddr x ,'(quotient 1 2))
X     then intern bldmsg("SQRT%w",Cadr x)
X     else intern bldmsg("WURZ/%w/%w/%w",cadr x, cadr caddr x,caddr caddr x);
X
X
Xsymbolic procedure findparas(f,vars);
X% find the parameters in f
Xbegin
X  scalar comp,paras1,paras2,c,paras;
X  paras1:=for each comp in f join  kernord (numr car comp,nil);
X  paras2:=for each comp in f join  kernord (denr car comp,nil);
X % print list("paras 1 und 2",paras1,"  ",paras2);
X  paras:=union(paras1,paras2);
X % print list("paras",paras);
X  paras:=condense paras;
X  %print list("paras",paras);
X  for each c in vars do paras:=delete(c,paras);
X % print list("remaining paras",paras);
X  for each c in paras do 
X    if listp c and member(car c,list('EXPT,'sqrt,'sin,'cos,'tan,'atan,'exp)) then
X       paras:=delete(c,paras);
X % print list("paras=",paras);
X  if length(paras)>0 then writepri("Parameter:",'first);
X  for each c in paras do
X   <<
X     writepri(" ",'nil);
X     writepri(mkquote c,'nil);
X   >>;
X  writepri(" ",'last);
X  return paras;
Xend;
X
X%symbolic procedure mytestpara(arg);
X%begin
X%  scalar f,vars,g;
X%  f:=reval car arg;
X%  f:=for each g in cdr f collect list(simp car g);
X%  vars:=cdr reval cadr arg;
X%  vars:=for each v in vars collect reval v;
X%  findparas(f,vars);
X%end;
X
X%put('testpara,psopfn,'mytestpara);
X
X
Xsymbolic procedure equicheck(f,grouplist,vars);
X% check of equivariance concerning groplist
Xbegin
X  scalar count,ma;
X  count:=0;
X % print list("in equicheck");
X % print list("group",grouplist);
X  for each ma in grouplist do 
X     if equicheck1(f,ma,vars) then count:=count+1;
X  if count=length(grouplist) then count:=-1;
X  if count=-1 then print list("system is equivariant") else
X       print list("system is  n o t  equivariant") ;
X  if count=-1 then return t;
Xend;
Xsymbolic procedure equicheckD6(f,ma1,ma2,vars);
X% check of equivariance concerning groplist
Xbegin
X  scalar count,ma;
X  count:=0;
X % print list("in equicheck");
X % print list("group",grouplist);
X % for each ma in grouplist do 
X     if equicheck1(f,ma1,vars) then count:=count+1;
X     if equicheck1(f,ma2,vars) then count:=count+1;
X % if count=length(grouplist) then count:=-1;
X  if count=2 then writepri("system is equivariant",'last) else
X       writepri("system is  n o t  equivariant",'last) ;
X  if count=2 then return t;
Xend;
X
Xsymbolic procedure equicheck1(f,ma,vars);
X% check whether f(ma*vars)=ma*f(vars);
Xbegin
X  scalar newvars,s,i,len,res,z,f,avt,fi,maf,g,tf;
X % print list("in equicheck1");
X  len:=length(f);
X  newvars:=mknewvars(len);
X  newvars:=for each s in newvars collect simp prepf s;
X  res:=for each z in ma collect 
X   <<                                % ma*newvars
X     g:=multsq(car z,car newvars);
X     for i:=2:len do
X        g:=addsq(g,multsq(nth(z,i),nth(newvars,i)));
X     g
X   >>;
X  % assocliste bauen
X  avt:=for i:=1:len collect cons(nth(vars,i),prepsq  nth(res,i));
X  % tf=f(ma*vars)
X  tf:=for each fi in f collect list(subsq(car fi,avt));
X  % variables rechange
X  newvars:=mknewvars(len); %newvars as kernels
X  avt:=for i:=1:len collect cons(nth(newvars,i), nth(vars,i));
X  tf:=for each fi in tf collect list(subsq(car fi,avt));
X  tf:=for each fi in tf collect list(negsq(car fi));
X  maf:=for z:=1:len collect list(
X    << g:=(nil ./ 1);
X       for s:=1:len do g:=addsq(g,multsq(car nth(f,s),nth(nth(ma,z),s)));
X        g
X     >>);
X  tf:=for z:=1:len collect list(myresimp addsq(car nth(maf,z),car nth(tf,z)));
X  g:=(nil ./ 1);
X  for each fi in tf do g:=addsq(g,multsq(car fi,car fi));
X  %g:=myresimp(g);
X % print list ("zero = g = ",g);
X%  if not (numr g) then print list("test for one matrix okay") else
X % print list("test  n o t   okay");
X  if not (numr g) then return t;
Xend;
X
Xsymbolic procedure mkmatvek(m,v);
X% matrix m * vector v
X% m -- Liste mit gleich langen Listen
X% v -- Liste mit einelementigen Listen
Xbegin
X  scalar i,res,f,len,z;
X  len:=length(v);
X  res:=for each z in m collect list(
X   <<f:=multsq(car z,caar v);
X     for i:=2:len do
X        f:=addsq(f,multsq(nth(z,i),car nth(v,i)));
X     myresimp f
X   >>);
X  return res;
Xend;
X
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X%%%
X%%%  program
X%%%
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X
Xsymbolic procedure matmult(ma1,ma2);
X% matrix multiplication
X% ma1,ma2 - list of lists of sq
Xbegin
X  scalar z,s,len,res,g,s1,s2;
X  len:=length(car  ma2); % number of columns in ma2
X  res:=for each z in ma1 collect
X     for s2:=1:len collect
X      << g:=( nil ./ 1);
X         for s1:=1:length(z) do
X           g:= addsq(g,multsq(nth(z,s1),nth(nth(ma2,s1),s2)));
X          myresimp g
X      >>;
X  return res;
Xend;
X
Xsymbolic procedure myresimp u;     %subsqst2 u; %subst2 u;
X           simp prepsq u;
X
X%symbolic procedure suchen u;
X %  if atom u then nil else
X %   if eqcar(u,'times) and numberp cadr u and numberp caddr u then
X%      <<prin2t "wurm gefunden";
X%         print u; print mist; backtrace(); rederr "schlussjetzt">>
X%    else suchen car u or suchen cdr u;
X
Xsymbolic procedure mktrmatrice(group,grouplist);
X% makes the orthogonal transformation matrice consisting of 
X% columns in the isotypical components
Xbegin
X  scalar glist,groupchar,charirr,s,z,ma,rowirr,mhigh,nicis,nicis1,i,m,mt;
X % print list("in mktrmatrice");
X  glist:=for each ma in grouplist collect
X     for each z in ma collect
X        for each s in z collect prepsq s;
X  glist:=cons('list,for each m in glist collect cons('mat,m));
X % calculate character of grouplist 
X  groupchar:=eval list('characterdeterm, mkquote glist);
X  groupchar:=cdr groupchar;
X  groupchar:=for each i in groupchar collect simp i;
X  writepri("Character :",'first);
X  for each s in groupchar do 
X    <<writepri(" ",'nil);
X      writepri(list('aeval,mkquote prepsq s),'nil);
X    >>;
X  writepri(" ",'last);
X % print list("groupchar",groupchar);
X % for each onedim rep. compute multiplicity and orthonormal basis 
X % with the Gram Schmid Prozess
X  nicis1:=for each charirr in onedimchar(group) collect
X     list(car charirr,charproduct(charirr,groupchar));
X % print list("nicis1",nicis1);
X  mt:=for each charirr in onedimchar(group) join
X basisotyp(car charirr,numr charproduct(charirr,groupchar) ,charirr,grouplist);
X% print list("m^t");
X % representations of higher dimension 
X%  print list("goupchar",groupchar);
X%  print list("moredimchar(group)",moredimchar(group));
X  nicis:=for each charirr in moredimchar(group) collect
X     list(car charirr,charproduct(charirr,groupchar));
X%  print list("nicis",nicis); 
X  i:=0; 
X  for each rowirr in moredimrep(group) do
X   <<charirr:=for each z in rowirr collect car z;
X     i:=i+1;
X   mhigh:=basisotyp(car nth(nicis,i),numr cadr nth(nicis,i),charirr,grouplist);
X   %  print list("mhigh",mhigh);
X     mt:=append(mt,mhigh);
X   %  print list("mhigh",mhigh);
X     mt:=append(mt,trafosymbas(mhigh,rowirr,grouplist));
X   >>;
X% print list("m^t");
X % for each z in mt do print list("mt z",z);
X  nicis:=append(nicis1,nicis);
X  writepri(" ",'last);
X  writepri("dimensions and multiplicities of irr. rep:",'last);
X % writepri(" ",'last);
X  writepri(" ",'first);
X  for each z in nicis do
X    <<
X      writepri(" (",'nil);
X      writepri(list('aeval,mkquote prepsq car z),'nil);
X      writepri(",",'nil);
X      writepri(list('aeval,mkquote prepsq cadr z),'nil);
X      writepri(")  ",'nil);
X    >>;
X  writepri(" ",'last);
X % print  list("end of mktrmatrix");
X  return list(nicis,mkmattrans(mt));
Xend;
X
Xsymbolic procedure basisotyp(ni,ci,charirr,grouplist);
X% orthonormale Basis einer isotyp. Komp. des R^n berechnen
X% ci -- multiplicity
X% charirr -- character of irreducible representation
X% grouplist -- list of n x n matrices
Xbegin
X  scalar einvectors,n,p,bas,z,tup,sum,vec;
X%  print list("in basisisotyp ");
X  n:=length(caar grouplist);
X  einvectors:=geneinheit(n);
X  p:=projection(ni,charirr,grouplist);
X  bas:=nil;
X % print list("ci",ci);
X  while ci and length(bas)<ci do
X   <<
X      % p * car einvectors
X      vec:=car einvectors;
X      einvectors:=cdr einvectors;
X      tup:=for each z in p collect
X        <<
X          sum:=multsq(car z, car vec);
X          for i:=2:n do sum:=addsq(sum,multsq(nth(z,i),nth(vec,i)));
X          myresimp sum
X        >>; % projizierter vector tup as list
X      % orthonormalize with bas
X % print list("bas");
X % for each z in bas do print list("bas z ",z);
X
X      bas:=append(bas,orthonormal(bas,tup));
X   >>;
X % print list("basisisotyp fertig");
X % print list("ci ",ci);
X % print list("bas");
X % for each z in bas do print list("bas z ",z);
X  return bas;  %list with tupels in lists
Xend;
X
Xsymbolic procedure orthonormal(bas,tup);
X% bas -- list of orthonormal tupels
X% tup -- tupel to be orthonormalized
Xbegin
X  scalar v,w,s,n,i,nens,zaes,wuzaes,wunens,normiere;
X % print list("in orthonormal");
X  n:=length(tup);
X  for each v in bas do
X    <<
X %     print list("orthonormalisiere in richtung v");
X      s:=scalprod(v,tup);
X      tup:=for i:=1:n collect myresimp addsq(nth(tup,i),
X                                      negsq(multsq(s,nth(v,i))));
X    >>;
X  s:=scalprod(tup,tup);
X % print list("scal ",s);
X  %print list("prepsq scal ",prepsq s);
X  zaes:=numr s;
X % print list("zaes",zaes);
X  nens:=denr s;
X  %print list("nens",nens);
X % wus:=simp eval list('mysqrt,mkquote  prepsq s);
X % print list("scal ",s);
X
X % print list("tup vorher ",tup);
X  if zaes then
X   << % compute 1/sqrt(s);
X      wuzaes:=simp eval list('mysqrt,mkquote  prepf zaes);
X      wunens:=simp eval list('mysqrt,mkquote  prepf nens);
X      normiere:=quotsq(multsq(wunens,wuzaes),zaes ./ 1);
X      tup:=list(for i:=1:n collect
X            myresimp multsq(normiere,nth(tup,i)));
X   >> else tup:=nil;
X % print list("tup hinterher ",tup);
X % print list("orthonormal fertig");
X  return tup;
Xend;
X
Xprocedure mysqrt(a);
X sqrt(a);
X
Xsymbolic procedure scalprod(tup1,tup2);
X% eukl. inner product of two tupels in lists
Xbegin
X  scalar i,n,sum;
X  n:=length(tup1);
X  sum:=multsq(car tup1,car tup2);
X  for i:=2:n do sum:=addsq(sum,multsq(nth(tup1,i),nth(tup2,i)));
X  return myresimp sum;  
Xend;
X
X
Xsymbolic procedure geneinheit(n);
X% generate the canonical basis in R^n
Xfor i:=1:n collect for j:=1:n collect if i=j then 1 ./ 1 else nil./1;
X
Xsymbolic procedure trafosymbas(mhigh,rowirr,grouplist);
X% first column of symmetric basis in mhigh will be transformed to
X% a complete symmetric basis
Xbegin
X scalar ni,j,p,charirr,res,res2,vec;
X% print list("in trafosymbas"); 
X ni:= length(car rowirr);
X res:=for j:=2:ni join
X   <<
X     charirr:=for each z in rowirr collect nth(z,j);
X   %  print list("ni,charirr",ni,"  ",charirr);
X     p:=projection((ni ./ 1),charirr,grouplist);
X     res2:=for each vec in mhigh collect
X       mymult(p,vec);
X     res2
X   >>; 
X %print list("in trafosymbas fertig"); 
X %print list("res",res);
X return res;
Xend;
X
Xsymbolic procedure mymult(p,vec);
X% matrix p * vec in list -> res is a list
Xfor each z in p collect
X   scalprod(z,vec);
X 
Xsymbolic procedure projection(ni,charirr,grouplist);
X% ni -- dimension
X% computes the proj. onto the isotyp. comp.
Xbegin
X scalar res,len;
X % print list("in projection");
X  res:=matscalmult(car charirr,car grouplist);
X  len:=length(charirr);
X  for i:=2:len do 
X     res:=addmat(matscalmult(nth(charirr,i),nth(grouplist,i)),res);
X  res:=matscalmult(quotsq(ni,( length(grouplist) ./ 1)),res);
X % print list("projection fertig");
X  return res;
Xend;
X
Xsymbolic procedure matscalmult(zahl,ma);
X  for each z in ma collect
X    for each s in z collect multsq(zahl,s);
X
Xsymbolic procedure addmat(ma1,ma2);
X% adds matrices ma1,ma2
Xbegin
X  scalar lenz,lens,s,z,resmat;
X  lenz:=length(ma1);
X  lens:=length(car ma1);
X  resmat:=for z:=1:lenz collect
X     for s:=1:lens collect 
X         addsq(nth(nth(ma1,z),s),nth(nth(ma2,z),s));
X   return resmat;
Xend;
X
X
X% verifying transform
X%symbolic procedure transform1(arg);
X%begin
X%  scalar f,m,vars;
X%  f:=car arg;
X%  f:= reval f;
X%  f:=for each fi in cdr f collect list(simp fi);
X%  m:=reval cadr arg;
X%  m:=for each z in cdr m collect
X%   for each s in cdr z collect simp s;
X%  vars:=cdr reval caddr arg;
X%  g:=transform(f,m,vars);
X%  g:=for each z in g collect prepsq car z;
X%  return cons('list,g);
X%end;
X%put('tran,psopfn,'transform1);
X
Xsymbolic procedure transform(f,m,vars);
X% make new function m^t f m
X% f -- Liste mit einelementigen Listen
X% m -- Liste mit Listen
X% vars -- Liste mit kernels
Xbegin
X  scalar newvars,n,tup,s,avt,tf;
X  n:=length(f);
X       newvars:=mknewvars(n);
X       newvars:=for each s in newvars collect list( simp prepf s);
X       tup:=mkmatvek(m,newvars);
X        % assocliste bauen
X       avt:=for i:=1:n collect cons(nth(vars,i),prepsq car nth(tup,i));
X       tf:=for each fi in f collect list(myresimp subsq(car fi,avt));
X       % print list("function f(mu)");
X       % mkraus(tf);
X  tf:=mkmatvek(mkmattrans(m),tf);
X % print list("function m^T f(mu)");
X % mkraus(tf);
X  return tf;
Xend;
X
Xsymbolic procedure mkmattrans(m);
X% transpose a matrix
Xbegin
X  scalar res,s,z;
X % print list("in mktransmat",m);
X  res:=
X       for s:=1:length(car m) collect
X           for z:=1:length(m) collect
X                      nth(nth(m,z),s);
X % print list("ende von  mktransmat",res);
X  return res;
Xend;
X
X
Xsymbolic procedure mknewvars(n);
X  for i:=1:n collect mkid('u,i);
X
Xprocedure characterdeterm(grouplist);
X% grouplist -- list of representation matrices
X% chargam -- character of the group, a list of numbers
Xbegin
X  scalar m,chargam;
X  chargam:=for each m in grouplist collect trace(m);
X  return chargam;
Xend;
X
Xsymbolic procedure charproduct(char1,char2);
X% char1, char2 -- product of two characters, an integer
X% if char2 is an character of an irreducible repr. then res is the multiplicity
Xbegin
X  scalar res;
X    res:= multsq(charproduct1(char1,char2),(1 ./length(char1)));
X   % print list ("in charpr ",res);
X    return res;
Xend;
X
Xsymbolic procedure charproduct1(char1,char2);
Xbegin
X  if length(char1)>1 then return
X      myresimp addsq (charproduct1(cdr char1,cdr char2),
X             multsq(car char1,car char2)) else
X     return myresimp multsq(car(char1),car(char2));
Xend;
X
Xsymbolic procedure genfunctionsf(f,m);
Xbegin
X  genf(f);
X  gendf(f,m);
X  genddf2(f,m);
Xend;
X
Xsymbolic procedure genf(f);
Xbegin
X  scalar 
X  gentlist,eqs,eq1,decls,args,fktname,comp,i;
X % PRINT LIST("aufruf von gentest",fktmat,subg,supergroup);
X  fktname:='!s!y!m!f!o!r!m!g;
X  decls:= LIST('DECLARE, LIST('!s!t!a!t!i!c! !v!o!i!d,fktname),
X                       LIST('DOUBLE, LIST('X,'TIMES), LIST('!f,'TIMES),
X                                                      LIST('!g,'TIMES)
X));
X  args:= LIST('X,'!g);
X  i:=0;
X  eqs:=FOR EACH comp IN f COLLECT
X    <<i:=i+1;
X      LIST('SETQ, LIST('!f,i),replacesqrt(CAR comp))
X    >>;
X  eq1:=list(list('!m!t!r!a!n!s,'!f,'!g));
X  eqs:=append(eqs,list(eq1));
X  gentlist:= LIST('PROCEDURE,fktname,'NIL,'EXPRN,args,
X                 APPEND( LIST('BLOCK,'NIL,decls),eqs));
X % print list("in GENTEST groups",subg,supergroup);
X  EVAL LIST('GENTRAN,mkquote gentlist,'NIL);
X
Xend;
X
Xsymbolic procedure mytestgenfkt(arg);
Xbegin
X  scalar f,vars,g,m;
X  f:=reval car arg;
X  f:=for each g in cdr f collect list(simp car g);
X  m:=reval cadr arg;
X  m:=for each z in cdr m collect
X      for each s in z collect simp s;
X  genfunctionsf(f,m);
Xend;
X
Xput('test,psopfn,'mytestgenfkt);
Xend;
X
END_OF_FILE
if test 17747 -ne `wc -c <'hybridfirst'`; then
    echo shar: \"'hybridfirst'\" unpacked with wrong size!
fi
# end of 'hybridfirst'
fi
echo shar: End of shell archive.
exit 0

