module symaux; % Data for symmetry package.
% Author: Karin Gatermann <Gatermann@sc.ZIB-Berlin.de>.
CREATE!-PACKAGE('(symaux
symatvec
symcheck
symchrep
symhandl
sympatch
symwork),
'(contrib symmetry));
load!-package 'matrix;
algebraic(operator @);
algebraic( infix @);
algebraic( precedence @,*);
symbolic procedure give!_groups (u);
% prints the elements of the abstract group
begin
return mk!+outer!+list(get!*available!*groups());
end;
put('availablegroups,'psopfn,'give!_groups);
symbolic procedure print!_group (groupname);
% prints the elements of the abstract group
begin
scalar g;
if length(groupname)>1 then rederr("too many arguments");
if length(groupname)<1 then rederr("group as argument missing");
g:=reval car groupname;
if available!*p(g) then
return alg!:print!:group(g);
end;
put('printgroup,'psopfn,'print!_group);
symbolic procedure print!_generators (groupname);
% prints the generating elements of the abstract group
begin
scalar g;
if length(groupname)>1 then rederr("too many arguments");
if length(groupname)<1 then rederr("group as argument missing");
g:=reval car groupname;
if available!*p(g) then
return alg!:generators(g);
end;
put('generators,'psopfn,'print!_generators);
symbolic procedure character!_table (groupname);
% prints the characters of the group
begin
scalar g;
if length(groupname)>1 then rederr("too many arguments");
g:=reval car groupname;
if available!*p(g) then
return alg!:characters(g);
end;
put('charactertable,'psopfn,'character!_table);
symbolic procedure character!_nr (groupname);
% prints the characters of the group
begin
scalar group,nr,char1;
if length(groupname)>2 then rederr("too many arguments");
if length(groupname)<2 then rederr("group or number missing");
group:=reval car groupname;
nr:=reval cadr groupname;
if not(available!*p(group)) then
rederr("no information upon group available");
if not(irr!:nr!:p(nr,group)) then
rederr("no character with this number");
if !*complex then
char1:=get!*complex!*character(group,nr) else
char1:=get!*real!*character(group,nr);
return alg!:print!:character(char1);
end;
put('characternr,'psopfn,'character!_nr);
symbolic procedure irreducible!_rep!_table (groupname);
% prints the irreducible representations of the group
begin
scalar g;
if length(groupname)>1 then rederr("too many arguments");
if length(groupname)<1 then rederr("group missing");
g:=reval car groupname;
if available!*p(g) then
return alg!:irr!:reps(g);
end;
put('irreduciblereptable,'psopfn,'irreducible!_rep!_table);
symbolic procedure irreducible!_rep!_nr (groupname);
% prints the irreducible representations of the group
begin
scalar g,nr;
if length(groupname)>2 then rederr("too many arguments");
if length(groupname)<2 then rederr("group or number missing");
g:=reval car groupname;
if not(available!*p(g)) then
rederr("no information upon group available");
nr:=reval cadr groupname;
if not(irr!:nr!:p(nr,g)) then
rederr("no irreducible representation with this number");
if !*complex then
return
alg!:print!:rep(get!*complex!*irreducible!*rep(g,nr))
else return
alg!:print!:rep(get!*real!*irreducible!*rep(g,nr));
end;
put('irreduciblerepnr,'psopfn,'irreducible!_rep!_nr);
symbolic procedure canonical!_decomposition(representation);
% computes the canonical decomposition of the given representation
begin
scalar repr;
if length(representation)>1 then rederr("too many arguments");
repr:=reval car representation;
if representation!:p(repr) then
return alg!:can!:decomp(mk!_internal(repr));
end;
put('canonicaldecomposition,'psopfn,'canonical!_decomposition);
symbolic procedure sym!_character(representation);
% computes the character of the given representation
begin
scalar repr;
if length(representation)>1 then rederr("too many arguments");
if length(representation)<1 then
rederr("representation list missing");
repr:=reval car representation;
if representation!:p(repr) then
return alg!:print!:character(mk!_character(mk!_internal(repr))) else
rederr("that's no representation");
end;
put('character,'psopfn,'sym!_character);
symbolic procedure symmetry!_adapted!_basis (arg);
% computes the first part of the symmetry adapted bases of
% the nr-th component
% arg = (representation,nr)
begin
scalar repr,nr,res;
if length(arg)>2 then rederr("too many arguments");
if length(arg)<2 then rederr("group or number missing");
repr:=reval car arg;
nr:=reval cadr arg;
if representation!:p(repr) then
repr:=mk!_internal(repr) else
rederr("that's no representation");
if irr!:nr!:p(nr,get!_group!_in(repr)) then
<<
if not(null(mk!_multiplicity(repr,nr))) then
res:= mk!+outer!+mat(mk!_part!_sym!_all(repr,nr))
else
res:=nil;
>> else
rederr("wrong number of an irreducible representation");
return res;
end;
put('symmetrybasis,'psopfn,'symmetry!_adapted!_basis);
symbolic procedure symmetry!_adapted!_basis!_part (arg);
% computes the first part of the symmetry adapted bases
% of the nr-th component
% arg = (representation,nr)
begin
scalar repr,nr,res;
if length(arg)>2 then rederr("too many arguments");
if length(arg)<2 then rederr("group or number missing");
repr:=reval car arg;
nr:=reval cadr arg;
if representation!:p(repr) then
repr:=mk!_internal(repr) else
rederr("that's no representation");
if irr!:nr!:p(nr,get!_group!_in(repr)) then
<<
if not(null(mk!_multiplicity(repr,nr))) then
res:= mk!+outer!+mat(mk!_part!_sym1(repr,nr))
else
res:=nil;
>> else
rederr("wrong number of an irreducible representation");
return res;
end;
put('symmetrybasispart,'psopfn,'symmetry!_adapted!_basis!_part);
symbolic procedure symmetry!_bases (representation);
% computes the complete symmetry adapted basis
begin
scalar repr,res;
if length(representation)>1 then rederr("too many arguments");
if length(representation)<1 then rederr("representation missing");
repr:=reval car representation;
if representation!:p(repr) then
<<
res:= mk!+outer!+mat(mk!_sym!_basis(mk!_internal(repr)));
>> else
rederr("that's no representation");
return res;
end;
put('allsymmetrybases,'psopfn,'symmetry!_bases);
symbolic procedure sym!_diagonalize (arg);
% diagonalizes a matrix with respect to a given representation
begin
scalar repr,matrix1;
if (length(arg)>2) then rederr("too many arguments");
if (length(arg)<2) then rederr("representation or matrix missing");
repr:=reval cadr arg;
matrix1:=reval (car arg);
if alg!+matrix!+p(matrix1) then
matrix1:=mk!+inner!+mat(matrix1)
else
rederr("first argument must be a matrix");
if representation!:p(repr) then
repr:=mk!_internal(repr) else
rederr("that's no representation");
if symmetry!:p(matrix1,repr) then
return mk!+outer!+mat(mk!_diagonal(
matrix1,repr)) else
rederr("matrix has not the symmetry of this representation");
end;
put('diagonalize,'psopfn,'sym!_diagonalize);
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% function to add new groups to the database by the user
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
symbolic procedure set!_generators!_group (arg);
% a group is generated by some elements
begin
scalar group, generators,relations,rel;
if length(arg)>3 then rederr("too many arguments");
if length(arg)<2 then
rederr("group identifier or generator list missing");
group:=reval car arg;
generators:=reval cadr arg;
if length(arg)=3 then
relations:=reval caddr arg else
relations:=nil;
if not(idp(group)) then
rederr("first argument must be a group identifier");
generators:=mk!+inner!+list(generators);
if not(identifier!:list!:p(generators)) then
rederr("second argument must be a list of generator identifiers")
else set!*generators(group,generators);
relations:=mk!_relation!_list(relations);
for each rel in relations do
if not(relation!:list!:p(group,rel)) then
rederr("equations in generators are demanded");
set!*relations(group,relations);
writepri("setgenerators finished",'only);
end;
put('setgenerators,'psopfn,'set!_generators!_group);
symbolic procedure set!_elements(arg);
% each element<>id of a group has a representation
% as product of generators
% the identity is called id
begin
scalar elemreps,replist,elems,group;
if length(arg)>2 then rederr("too many arguments");
if length(arg)<2 then
rederr("missing group or list with group elements with generators ");
group:=reval car arg;
if not(idp(group)) then
rederr("first argument must be a group identifier");
elemreps:=reval cadr arg;
elemreps:=mk!_relation!_list(elemreps);
for each replist in elemreps do
if not(generator!:list!:p(group,cadr replist)) then
rederr("group elements should be represented in generators");
for each replist in elemreps do
if not((length(car replist)=1) and idp(caar replist)) then
rederr("first must be one group element");
elems:= for each replist in elemreps collect caar replist;
elems:=append(list('id),elems);
set!*elems!*group(group,elems);
set!*elemasgen(group,elemreps);
writepri("setelements finished",'only);
end;
put('setelements,'psopfn,'set!_elements);
symbolic procedure set!_group!_table (arg);
% a group table gives the result of the product of two elements
begin
scalar table,group,z,s;
if length(arg)>2 then rederr("too many arguments");
if length(arg)<2 then
rederr("missing group or group table as a matrix ");
group:=reval car arg;
if not(idp(group)) then
rederr("first argument must be a group identifier");
table:=reval cadr arg;
if alg!+matrix!+p(table) then
table:=mk!+inner!+mat(table);
table:=for each z in table collect
for each s in z collect prepsq(s);
if group!:table!:p(group,table) then
<<
set!*grouptable(group,table);
set!*inverse(group,mk!*inverse!*list(table));
set!*group(group,mk!*equiclasses(table));
set!*storing(group);
>> else rederr("table is not a group table");
writepri("setgrouptable finished",'only);
end;
put('setgrouptable,'psopfn,'set!_group!_table);
symbolic procedure set!_real!_rep(arg);
% store the real irreducible representations
begin
scalar replist,type;
if length(arg)>2 then rederr("too many arguments");
if length(arg)<2 then
rederr("representation or type missing");
replist:=reval car arg;
type:=reval cadr arg;
if (not(type= 'realtype) and not(type = 'complextype)) then
rederr("only real or complex types possible");
if get!*order(get!_group!_out(replist))=0 then
rederr("elements of the groups must be set first");
if representation!:p(replist) then
replist:=(mk!_internal(replist));
set!*representation(get!_group!_in(replist),
append(list(type),cdr replist),'real);
writepri("Rsetrepresentation finished",'only);
end;
put('Rsetrepresentation,'psopfn,'set!_real!_rep);
symbolic procedure set!_complex!_rep(arg);
% store the complex irreducible representations
begin
scalar replist;
if length(arg)>1 then rederr("too many arguments");
if length(arg)<1 then
rederr("representation missing");
replist:=reval car arg;
if get!*order(get!_group!_out(replist))=0 then
rederr("elements of the groups must be set first");
if representation!:p(replist) then
replist:=(mk!_internal(replist));
set!*representation(get!_group!_in(replist),cdr replist,'complex);
writepri("Csetrepresentation finished",'only);
end;
put('Csetrepresentation,'psopfn,'set!_complex!_rep);
symbolic procedure mk!_available(arg);
% group is only then made available, if all information was given
begin
scalar group;
if length(arg)>1 then rederr("too many arguments");
if length(arg)<1 then
rederr("group identifier missing");
group:=reval car arg;
if check!:complete!:rep!:p(group) then
set!*available(group);
writepri("setavailable finished",'only);
end;
put('setavailable,'psopfn,'mk!_available);
symbolic procedure update!_new!_group (arg);
% stores the user defined new abstract group in a file
begin
scalar group;
if length(arg)>2 then rederr("too many arguments");
if length(arg)<2 then
rederr("group or filename missing");
group:=reval car arg;
if available!*p(group) then write!:to!:file(group,reval cadr arg);
writepri("storegroup finished",'only);
end;
put('storegroup,'psopfn,'update!_new!_group);
procedure loadgroups(fname);
% loads abstract groups from a file which was created from a user
% by newgroup and updategroup
begin
in fname;
write"group loaded";
end;
endmodule;
end;