Quelle  realforms.gi   Sprache: unbekannt

# This file contains functions for constructing real simple LAs, Vogan diagrams, Satake diagrams, etc
#
# These are the functions contained here:
#
#  CartanSubalgebrasOfRealForm
#  CartanSubspace
#  VoganDiagram
#  SatakeDiagram
#  IdRealForm
#  RealFormById
#  NumberRealForms
#  AllRealForms
#  RealFormsInformation
#  IsomorphismOfRealSemisimpleLieAlgebras#
#
#  corelg.getDirectSumOfPureLA 
#  corelg.getPureLA
#  corelg.realification 
#  PositiveRootsNF
#  BilinearFormMatNF
#  PositiveRootsAsWeights
#  SignatureTable
#  corelg.ConjugationFct
#  corelg.SOSets  
#  corelg.conj_func
#  corelg.so_sets
#  corelg.signs
#  corelg.signsandperm
#  corelg.Sub3
#  corelg.RealFormsOfSimpleLieAlgebra
#  corelg.MakeSqrtFieldCopyOfLieAlgebra
#  corelg.NonCompactRealFormsOfSimpleLieAlgebra
#  corelg.ParametersOfNonCompactRealForm
#  corelg.RealFormByInnerInvolutiveAutomorphism
#  corelg.makeCanGenByBase
#  corelg.enumOfBase
#  corelg.VoganDiagramOfRealForm
#  corelg.VoganDiagramRealification
#  corelg.getRootsystem
#  corelg.SingleVoganDiagram
#  corelg.makeBlockDiagMat
#  corelg.computeIdRealForm
#  corelg.splitRealFormOfSL
#  corelg.prntdg


############################################################################
###########################################################################
#
# first a few functions from QuaGroup, SLA and the library:
# 


# From QuaGroup
InstallMethod( PositiveRootsNF,
        "for a root system",
        true, [ IsRootSystem ], 0,
        function( R )

    local b, st;

    st:= SimpleSystem(R);
    b:= Basis( VectorSpace( DefaultFieldOfMatrix(st), st ), st );
    return List( PositiveRoots(R), x -> Coefficients( b, x ) );
end );


# From QuaGroup
InstallMethod( BilinearFormMatNF,
        "for a root system",
        true, [ IsRootSystem ], 0,
        function( R )

    local m;

    m:= Minimum( List([1..Length(CartanMatrix(R))], i -> 
            BilinearFormMat(R)[i][i] ) );
    return BilinearFormMat(R)*(2/m);
end );


# from GAP library:
InstallMethod( PositiveRootsAsWeights,
    "for a root system",
    true, [ IsRootSystem ], 0,
    function( R )

      local posR,V,lcombs;

      posR:= PositiveRoots( R );
      V:= VectorSpace( DefaultFieldOfMatrix(SimpleSystem(R) ), SimpleSystem( R ) );
      lcombs:= List( posR, r ->
                       Coefficients( Basis( V, SimpleSystem(R) ), r ) );
      return List( lcombs, c -> LinearCombination( CartanMatrix(R), c ) );

end );


# From SLA:
InstallMethod( SignatureTable,
"for Lie algebra", true, [IsLieAlgebra], 0,
function( L )

    local o, R, p, tab, x, w, max, dims, r, u, wt, dc, char, it, i, 
          Ci, h, ev, pos, tp, res, en;
    
    o:= NilpotentOrbits(L);
    R:= RootSystem(L);

    tp:= CartanType( CartanMatrix(R) ).types[1];
    if tp[1] in [ "A", "B", "C", "E", "F", "G" ] then

       p:= PositiveRootsNF(R);
       tab:= [ ];
       for x in o do
           w:= WeightedDynkinDiagram(x);
           max:= p[Length(p)]*w;
           if not IsInt( max ) then # hack to make it work with SqrtField...
              max:= max![1][1][1];
           fi;
           dims:= List([1..max+1], u -> 0 );
           for r in p do
               u:= r*w+1;
               if not IsInt( u ) then
                  u:= u![1][1][1];
               fi;
               dims[u]:= dims[u]+1;
           od;
           dims[1]:= 2*dims[1]+Length(CartanMatrix(R));
           Add( tab, [ dims, w ] );
       od;

       return rec( tipo:= "notD", tab:= tab );

    else

       en:= CartanType( CartanMatrix(R) ).enumeration[1];
       wt:= List( CartanMatrix( R ), x -> 0 );
       wt[en[1]]:= 1;
       dc:= DominantCharacter( L, wt );
       char:= [[],[]];
       for i in [1..Length(dc[1])] do
           it:= WeylOrbitIterator( WeylGroup(R), dc[1][i] );
           while not IsDoneIterator( it ) do
              Add( char[1], NextIterator( it ) );
              Add( char[2], dc[2][i] );
           od;
       od;

       Ci:= FamilyObj(o[1])!.invCM;
       tab:= [ ];
       for x in o do

           h:= Ci*WeightedDynkinDiagram(x);

           dims:= [ ];
           for i in [1..Length(char[1])] do
               ev:= h*char[1][i];

               pos:= PositionProperty( dims, y -> y[1]=ev);
               if pos = fail then
                  Add( dims, [ev, char[2][i]] );
               else
                  dims[pos][2]:= dims[pos][2]+char[2][i];
               fi;
           od;
           Sort( dims, function(a,b) return a[1] < b[1]; end );

           Add( tab, [dims, WeightedDynkinDiagram(x)] );
       od;

       res:= rec( tipo:= "D", char1:= char, tab1:= tab, V1:= 
                HighestWeightModule( L, wt ) );

       wt:= List( CartanMatrix( R ), x -> 0 );
       wt[en[Length(wt)]]:= 1;
       dc:= DominantCharacter( L, wt );
       char:= [[],[]];
       for i in [1..Length(dc[1])] do
           it:= WeylOrbitIterator( WeylGroup(R), dc[1][i] );
           while not IsDoneIterator( it ) do
              Add( char[1], NextIterator( it ) );
              Add( char[2], dc[2][i] );
           od;
       od;

       Ci:= FamilyObj(o[1])!.invCM;
       tab:= [ ];
       for x in o do

           h:= Ci*WeightedDynkinDiagram(x);

           dims:= [ ];
           for i in [1..Length(char[1])] do
               ev:= h*char[1][i];

               pos:= PositionProperty( dims, y -> y[1]=ev);
               if pos = fail then
                  Add( dims, [ev, char[2][i]] );
               else
                  dims[pos][2]:= dims[pos][2]+char[2][i];
               fi;
           od;
           Sort( dims, function(a,b) return a[1] < b[1]; end );

           Add( tab, [dims, WeightedDynkinDiagram(x)] );
       od;

       res.char2:= char; res.tab2:= tab;
       res.V2:= HighestWeightModule( L, wt );
       return res;
    fi;   

end );



#############################
#
# computes the realification of a simple complex LA over F
#
corelg.realification := function(arg)
local sc, scn, i, j, k, F, type, rank, L, cg, cb, rs, bas, dim, rts, cbn, n, prs, nrs,posp,posn,
      l1,l2,l3,en,Ln, basn, l, csa, K, P, bascd, theta,cd, cgn,tmp,v, sp, R, CartInt,allrts, fundr;

   type := arg[1];
   rank := arg[2];
   F    := SqrtField;
   if Length(arg)=3 then F:=arg[3]; fi;
  
 ##this is complex simple LA and its data
   L    := SimpleLieAlgebra(type,rank,GaussianRationals);
   rs   := RootSystem(L);;
   cg   := CanonicalGenerators(rs);;
   cb   := ChevalleyBasis(L);; ##changed this!
   bas  := Basis(L);
   sc   := StructureConstantsTable(bas);;
   dim  := Dimension(L);
 
 ##now create structure constants of realification of L
 ##take as basis the elements of bas and \imath*bas
 ##
   scn  := EmptySCTable( 2*dim,  Zero(F),  "antisymmetric" );;
   for i in [1..dim-1] do
      SetEntrySCTable( scn, i, i+dim, []);
      for j in [i+1..dim] do
         en := sc[i][j];
         l1 := [];
         l2 := [];
         l3 := [];
         for k in [1..Length(en[1])] do
            Add(l1,en[2][k]*One(F));  Add(l1,en[1][k]);     
            Add(l2,en[2][k]*One(F));  Add(l2,en[1][k]+dim);
            Add(l3,-en[2][k]*One(F)); Add(l3,en[1][k]);
         od;
         SetEntrySCTable( scn, i, j, l1 );        ## prod of two old basis vecs
         SetEntrySCTable( scn, i, j+dim, l2);     ## prod of old + new basis 
         SetEntrySCTable( scn, i+dim,j , l2);     ## prod of old + new basis
         SetEntrySCTable( scn, i+dim, j+dim, l3); ## prod of two new basis
      od;
   od;
   SetEntrySCTable( scn, dim, 2*dim, []);
   
 ##now construct realification and set CSA
 ##
   Ln   := LieAlgebraByStructureConstants(F,scn);
   basn := Basis(Ln);
   csa  := basn{Concatenation([dim-rank+1..dim],[2*dim-rank+1..2*dim])};
   csa  := SubalgebraNC(Ln,csa);
   SetCartanSubalgebra(Ln,csa);

   SetMaximallyCompactCartanSubalgebra(Ln,csa);
 
 ##Cartan decomposition: K is compact real form of L (onishik p 26)
 ##that is, spanned by \imath*h_i, x_a - x_{-a}, \imath*(x_a+x_{-a})
 ##consequently, P is spanned by \imath times these elts
 ##
   K    := basn{[2*dim-rank+1..2*dim]};  ## ih_1,..,ih_rank
   l    := Length(cb[1]);
   for i in [1..l] do
      Add(K, basn[i]-basn[l+i]);         ## (x_a-x_{-a})
      Add(K, basn[dim+i]+basn[dim+l+i]); ## i(x_a+x_{-a})
   od;
   K    := SubalgebraNC(Ln,K,"basis");
   P    := basn{[dim-rank+1..dim]};      ## h_1,..,h_rank
   for i in [1..l] do
      Add(P, basn[dim+i]-basn[dim+l+i]); ## i(x_a-x_{-a})
      Add(P, basn[i]+basn[l+i]);         ## (x_a+x_{-a})
   od;
   P     := Subspace(Ln,P,"basis");
   SetCartanSubalgebra(K,SubalgebraNC(K,basn{[2*dim-rank+1..2*dim]}));

 ##set Cartan decomposition; 
 ##create corresponding Cartan involution
   bascd := BasisNC(Ln,Concatenation(Basis(K),Basis(P)));
   theta := function(v)
      local k, p, cf, i;   
      k   := Length(Basis(K));
      p   := Length(Basis(P));
      cf  := List(Coefficients(bascd,v),x->x);
      for i in [k+1..k+p] do cf[i] := -cf[i]; od;
      return cf*bascd;
   end;
   
   SetCartanDecomposition(Ln,rec( K:= K, P:= P, CartanInv :=theta));

  ##new chevalley basis
   cbn := [[],[],[]];
   l   := Length(cb[1]);
   for i in [1..l] do
      Add(cbn[1], 1/2*One(F)*( basn[i]+E(4)*One(F)*basn[i+dim]   ) );
      Add(cbn[1], 1/2*One(F)*( basn[i]-E(4)*One(F)*basn[i+dim]   ) );
      Add(cbn[2],  1/2*One(F)*( basn[i+l]+E(4)*One(F)*basn[i+dim+l]   ) );
      Add(cbn[2],  1/2*One(F)*( basn[i+l]-E(4)*One(F)*basn[i+dim+l]   ) );
      if i <= rank then
         Add(cbn[3], (1/2)*One(F)*(basn[2*l+i]+E(4)*One(F)*basn[2*l+i+dim]));
         Add(cbn[3],  (1/2)*One(F)*(basn[2*l+i]-E(4)*One(F)*basn[2*l+i+dim]));
      fi;
   od;

    n   := 2*rank;
    rts := [ ]; 
    for v in cbn[1] do 
        sp:= BasisNC(SubspaceNC(Ln,[v],"basis"),[v]); 
        Add( rts, List( cbn[3], t -> Coefficients(sp,t*v)[1] ) ); 
    od;

    R:= Objectify( NewType( NewFamily( "RootSystemFam", IsObject ),
                IsAttributeStoringRep and IsRootSystemFromLieAlgebra ), 
                rec() );
    SetCanonicalGenerators( R, [ cbn[1]{[1..n]}, cbn[2]{[1..n]}, cbn[3] ] );
    SetUnderlyingLieAlgebra( R, Ln );
    SetPositiveRootVectors( R, cbn[1] );
    SetNegativeRootVectors( R, cbn[2] );

    CartInt := function( R, a, b )
       local s,t,rt;
       s:=0; t:=0;
       rt:=a-b;
       while (rt in R) or (rt=0*R[1]) do
         rt:=rt-b;
         s:=s+1;
       od;
       rt:=a+b;
       while (rt in R) or (rt=0*R[1]) do
         rt:=rt+b;
         t:=t+1;
       od;
       return s-t;
    end;

    allrts:= Concatenation( rts, -rts );
    fundr:= rts{[1..n]};
    SetCartanMatrix( R, List( fundr, x -> List( fundr, y -> CartInt( allrts, x, y ) ) ) );
    
    #roots are rationals
    if IsSqrtField(F) then
       rts := List(rts, x-> List(x, SqrtFieldEltToCyclotomic));
    fi;

    SetPositiveRoots( R, rts );
    SetNegativeRoots( R, -rts ); 
    SetSimpleSystem( R, rts{[1..n]} );

    SetRootSystem(L,R);
    SetChevalleyBasis(R,cbn);
    SetRootSystem(MaximallyCompactCartanSubalgebra(Ln),R);
    SetRootSystem(CartanSubalgebra(Ln),R);
    SetChevalleyBasis( Ln, cbn );
 
    return Ln;
end;




########################################################################

corelg.signs:= function( type, n )

     local sgn, i, m, s;

     sgn:= [ ];
     if type ="A" then
        if IsEvenInt(n) then
           m:= n/2;
        else
           m:= (n+1)/2;
        fi;
        for i in [1..m] do
            s:= List( [1..n], x -> 1 );
            s[i]:= -1;
            Add( sgn, s );
        od;
     elif type = "B" then
        for i in [1..n] do
            s:= List( [1..n], x -> 1 );
            s[i]:= -1;
            Add( sgn, s );
        od;
     elif type = "C" then
        if IsEvenInt(n-1) then
           m:= (n-1)/2;
        else
           m:= n/2;
        fi;
        for i in [1..m] do
            s:= List( [1..n], x -> 1 );
            s[i]:= -1;
            Add( sgn, s );
        od;
        s:= List( [1..n], x -> 1 ); s[n]:= -1;
        Add( sgn, s );
     elif type = "D" then
        if n = 4 then
           return [ [ 1, 1, -1, 1 ], [ 1, -1, 1, 1 ] ];
        fi;
        if IsEvenInt(n-3) then
           m:= 1+(n-3)/2;
        else
           m:= 1+(n-2)/2;
        fi;
        for i in [1..m] do
            s:= List( [1..n], x -> 1 );
            s[i]:= -1;
            Add( sgn, s );
        od;
        s:= List( [1..n], x -> 1 ); s[n-1]:= -1;
        Add( sgn, s );
     elif type = "E" then
        if n = 6 then
           sgn:= [ [ -1, 1, 1, 1, 1, 1 ], [ 1, -1, 1, 1, 1, 1 ] ];
        elif n = 7 then 
           sgn:= [ [ -1, 1, 1, 1, 1, 1, 1 ], [ 1, -1, 1, 1, 1, 1, 1 ], [ 1, 1, 1, 1, 1, 1, -1 ] ];
        elif n = 8 then
           sgn:= [ [ -1, 1, 1, 1, 1, 1, 1, 1 ], [ 1, 1, 1, 1, 1, 1, 1, -1 ] ];
        fi;
     elif type = "F" then
        sgn:= [ [ 1, 1, 1, -1 ], [ 1, 1, -1, 1 ] ];
     else
        sgn:= [ [ 1, -1 ] ];
     fi;

     return sgn;

end;




########################################################################
corelg.signsandperm:= function( type, n )

   local p, sgn, s, i, m;

    if type = "A" then
       p:= PermList( [n,n-1..1] );
       if IsEvenInt(n) then
          # there is only one...
          sgn:= [ List( [1..n], x -> 1 ) ];
       elif n > 1 then
          sgn:= [ List( [1..n], x -> 1 ), List( [1..n], x -> 1 ) ];
          sgn[2][ (n+1)/2 ]:= -1;
       fi;
    elif type = "D" then
       p:= (n-1,n);
       sgn:= [ List( [1..n], x -> 1 ) ];
       if IsEvenInt(n) then
          m:= n/2-1;
       else
          m:= (n-1)/2;
       fi;
       for i in [1..m] do
           s:= List( [1..n], x -> 1 );
           s[i]:= -1;
           Add( sgn, s );
       od;
    elif type ="E" and n=6 then
       p:= (1,6)*(3,5);
       sgn:= [ [1,1,1,1,1,1], [1,1,1,-1,1,1] ];
    else
       Error("no outer auts");
    fi;

    return rec( sg:= sgn, perm:= p );

end;





########################################################################
corelg.Sub3:=function( arg )

local L, R, P, S, T, s, p, TT, i, j, w, g, F, makeCartInv, a, n, F0, bb, BB, KK1, KK2, rts, v, sp, 
      CartInt, allrts, fundr; 

a:= arg[1];
n:= arg[2];
if Length(arg)=3 then
   F0:= arg[3];
else
   F0:= GaussianRationals;
fi;

#R:=[]; P:=[]; S:=[]; C:=[]; T:=[]; TT:=[]; D:=[]; U:=[]; c:=[]; w:=[];  
L:= SimpleLieAlgebra( a,  n,  Rationals);
R:= RootSystem(L);
P:= PositiveRoots(R);
S:= SimpleSystem(R);
#C:= ChevalleyBasis(L);
#V:= VectorSpace(Rationals,  S);
#B:= Basis(V, S);
T:= StructureConstantsTable(Basis(L));;
s:= Length(S);;
p:= Length(P);;
#D:=[];;
#U:=[];;
TT:=EmptySCTable( 2*p+s,  Zero(F0),  "antisymmetric" );;


# Cerchiamo ora di assegnare i valori dei bracket nella tabella moltiplicativa
#Quelli fra i generatori H sono nulli,  quindi non devo fare niente,  è automatico in TT


#Cerco di sistemare i bracket fra i generatori [H, X] e [H.Y]
 
for i in [1..s] do
 for j in [1..p] do
  if not IsEmpty(T[2*p+i][j][2]) then
SetEntrySCTable( TT,  2*p+i,    j, Flat( [ T[2*p+ i][j][2][1]  ,  p+j    ] )  );
  fi;
  if not IsEmpty(T[2*p+i][p+j][2]) then
SetEntrySCTable( TT,  2*p+i,  p+j, Flat( [ T[2*p+ i][p+j][2][1],    j    ] )  );
  fi;
 od;
od;



#setto i prodotti [X,X] [Y,Y] con indici diversi 

for i in [1..p] do
 for j in [1..i-1] do
  if P[i]+P[j] in P then
   if P[i]-P[j] in P then  #ricordo che i>j in questo caso
SetEntrySCTable( TT, i, j, Flat([ T[i][j][2], Position(P, P[i]+P[j]),  T[p+i][j][2],  Position(P, P[i]-P[j] )   ]));
SetEntrySCTable( TT, p+i, p+j,Flat([ T[p+i][p+j][2], Position(P, P[i]+P[j]), T[p+i][j][2], Position(P, P[i]-P[j] )  ]));
   else #i-j non fa radice
SetEntrySCTable( TT, i, j, Flat([ T[i][j][2], Position(P, P[i]+P[j] )  ]));
SetEntrySCTable(TT, p+i, p+j, Flat([ T[p+i][p+j][2], Position(P, P[i]+P[j] )   ]));
   fi;
  else #i+j non radice
   if P[i]-P[j] in P then
SetEntrySCTable( TT, i, j, Flat([ T[p+i][j][2],  Position(P, P[i]-P[j] )   ]));
SetEntrySCTable( TT, p+i, p+j, Flat([ T[p+i][j][2], Position(P, P[i]-P[j] )   ]));
   fi;
  fi;
 od;

 for j in [i+1..p] do
  if P[i]+P[j] in P then
   if P[j]-P[i] in P then
SetEntrySCTable( TT, i, j, Flat([ T[i][j][2], Position(P, P[i]+P[j]),  T[i][p+j][2],  Position(P, P[j]-P[i] )   ]));
SetEntrySCTable(TT, p+i, p+j, Flat([ T[p+i][p+j][2], Position(P, P[i]+P[j]), T[i][p+j][2], Position(P, P[j]-P[i] )  ]));
    else #j-i non fa radice
SetEntrySCTable( TT, i, j, Flat([ T[i][j][2], Position(P, P[j]+P[i] )  ]));
SetEntrySCTable(TT, p+i, p+j, Flat([ T[p+i][p+j][2], Position(P, P[j]+P[i] )   ]));
   fi;
  else
   if P[j]-P[i] in P then
SetEntrySCTable( TT, i, j, Flat([ T[i][p+j][2],  Position(P, P[j]-P[i] )   ]));
SetEntrySCTable(TT, p+i, p+j, Flat([ T[i][p+j][2], Position(P, P[j]-P[i] )   ]));
   fi;
  fi;
 od;

od;

#metto a posto i generatori [X, Y] con lo stesso indice

for i in [1..p] do
 g:=T[i][p+i];
 w:=[];
 for j in [1..Length(g[2])] do
  Add( w, 2*g[2][j]); 
  Add( w, g[1][j] );
 od;
SetEntrySCTable( TT,  i, p+i,  w);
od;


#cerco di sistemare i prodotti [X,Y] con indici differenti


for i in [1..p] do
 for j in [1..i-1] do
  if  P[i]+P[j] in P then
   if P[i]-P[j] in P  then
SetEntrySCTable( TT, i, p+j, Flat([ T[i][j][2], p+Position(P, P[i]+P[j] ), T[i][p+j][2], p+Position(P, P[i]-P[j] )  ]));
   else
SetEntrySCTable( TT, i, p+j, Flat([ T[i][j][2], p+Position(P, P[i]+P[j] )   ]));
   fi;
  else
   if P[i]-P[j] in P then
SetEntrySCTable( TT, i, p+j, Flat([  T[i][p+j][2],  p+Position(P, P[i]-P[j] )   ]));
   fi;
  fi;
 od;

 for j in [i+1..p] do
  if  P[i]+P[j] in P then
   if P[j]-P[i] in P  then
SetEntrySCTable( TT, i, p+j, Flat([ T[i][j][2], p+Position(P, P[i]+P[j] ), T[i][p+j][2], p+Position(P, P[j]-P[i] )  ]));
   else
SetEntrySCTable( TT, i, p+j, Flat([ T[i][j][2],  p+Position(P, P[i]+P[j] )   ]));
   fi;
  else
   if P[j]-P[i] in P then
SetEntrySCTable( TT, i, p+j, Flat([ T[i][p+j][2],  p+Position(P, P[j]-P[i] )   ]));
   fi;
  fi;
 od;
od;


  makeCartInv := function(L,K,P)
  local bas;
     bas := BasisNC(L,Concatenation(Basis(K),Basis(P)));
     return function(v)
     local k, p, cf, i;   
        k   := Length(Basis(K));
        p   := Length(Basis(P));
        cf  := List(Coefficients(bas,v),x->x);
        for i in [k+1..k+p] do cf[i] := -cf[i]; od;
           return cf*bas;
        end;
   end; 
 

  L:=LieAlgebraByStructureConstants(F0, TT);
  SetCartanDecomposition( L, rec( K:= L, P:= SubspaceNC( L, [ ],"basis" ),
                          CartanInv := makeCartInv(L,L,SubspaceNC(L,[],"basis"))));
  SetIsCompactForm( L, true );

  # fare un elenco con tre elenchi: [x_alpha], [x_{-alpha}], [h_1,...,h_l], alpha > 0, tutti
  # i vettori espressi in termini della base di L.
  # Se b:= Basis(L); allora b[1] è il primo elemento della base, ecc. 

  bb:=Basis(L);
  BB:=[[],[],[]];
  KK1:=0;
  KK2:=0;

  for j in [1..s] do
      BB[3][j]:=(-1*E(4)*One(F0)*bb[2*p+j]);
  od;

  for i in [1..p] do

      KK1:=(bb[i]); #X_alpha
      KK2:=(bb[p+i]); #Y_alpha
      BB[1][i]:= 1/2*One(F0)*(KK1-1*E(4)*One(F0)*KK2);
      BB[2][i]:= 1/2*One(F0)*(-1*One(F0)*KK1-1*E(4)*One(F0)*KK2);

  od;

  SetCartanSubalgebra(L,Subalgebra(L,BB[3]) );
  SetMaximallyCompactCartanSubalgebra( L, CartanSubalgebra(L) );

    rts:=[ ]; 
    for v in BB[1] do 
        sp:= Basis(SubspaceNC(L,[v],"basis"),[v]); 
        Add( rts, List( BB[3], t -> Coefficients(sp,t*v)[1] ) ); 
    od;

    R:= Objectify( NewType( NewFamily( "RootSystemFam", IsObject ),
                IsAttributeStoringRep and IsRootSystemFromLieAlgebra ), 
                rec() );
    SetCanonicalGenerators( R, [ BB[1]{[1..n]}, BB[2]{[1..n]}, BB[3] ] );
    SetUnderlyingLieAlgebra( R, L );
    SetPositiveRootVectors( R, BB[1] );
    SetNegativeRootVectors( R, BB[2] );

    CartInt := function( R, a, b )
       local s,t,rt;
       s:=0; t:=0;
       rt:=a-b;
       while (rt in R) or (rt=0*R[1]) do
         rt:=rt-b;
         s:=s+1;
       od;
       rt:=a+b;
       while (rt in R) or (rt=0*R[1]) do
         rt:=rt+b;
         t:=t+1;
       od;
       return s-t;
    end;

    allrts:= Concatenation( rts, -rts );
    fundr:= rts{[1..n]};
    SetCartanMatrix( R, List( fundr, x -> List( fundr, y -> CartInt( allrts, x, y ) ) ) );
    
    
    
    #roots are rationals
    if IsSqrtField(F0) then
       rts := List(rts, x-> List(x, SqrtFieldEltToCyclotomic));
    fi;
 

    SetPositiveRoots( R, rts );
    SetNegativeRoots( R, -rts ); 
    SetSimpleSystem( R, rts{[1..n]} );

    SetRootSystem(L,R);
    SetRootSystem(MaximallyCompactCartanSubalgebra(L),R);
    SetRootSystem(CartanSubalgebra(L),R);  ###!!! added this recently

    SetChevalleyBasis( L, BB );


  return L;

end;



##############################################################################
##
##  returns all real forms of simple Lie algebras of type <type> and rank <n>
##  up to isomorphism
##
corelg.RealFormsOfSimpleLieAlgebra := function( arg )

  local forms, s, i, tmp, type, n, F;

  type := arg[1];   
  n    := arg[2];
  if Length(arg)=3 then F:=arg[3]; else F:=GaussianRationals; fi;

  forms:= [ corelg.Sub3( type, n, F ) ]; # so the compact form...
  SetIsRealFormOfInnerType(forms[1],true);
  SetRealFormParameters(forms[1],[type,n,ListWithIdenticalEntries(n,1),()]);
  
  s:= corelg.signs( type, n );
  for i in [1..Length(s)] do
      tmp := corelg.SuperLie( type, n, s[i], (), F );
      SetRealFormParameters(tmp, [type,n,s[i],()]);
      SetIsRealFormOfInnerType(tmp,true);
      Add( forms, tmp );
  od;

  if type in ["A","D","E"] and (type <> "E" or n = 6) and not (type = "A" and n = 1) then

     s:= corelg.signsandperm( type, n ); 
     for i in [1..Length(s.sg)] do
         tmp := corelg.SuperLie( type, n, s.sg[i], s.perm, F );
         SetRealFormParameters(tmp, [type,n,s.sg[i],s.perm]);
         SetIsRealFormOfInnerType(tmp,false);
         Add( forms, tmp );
     od;

  fi;
  
  return forms;
end;


########################################################################

InstallOtherMethod( CartanSubspace,
   "for a Lie algebra with Cartan decomposition",
   true, [ IsLieAlgebra ], 0,
   function( L )

   # L = K + P, note that P does not have nilpotent elements, as a nilpotent
   # e would lie in a hom sl_2 triple, with h\in K, not possible. So a subspace C
   # is a Cartan subspace iff its centralizer in P is equal to C.

   local P, found, b, V, C, k;

   P:= CartanDecomposition(L).P;
   # first we determine the rank by computing any Cartan subspace...

   found:= false;
   b:= ShallowCopy( BasisVectors( Basis( Intersection( P, CartanSubalgebra(L) ) ) ) );
   # first try with just basis elements...
   V:= SubspaceNC( P, b );
   C:= Filtered( Basis(P), x -> ForAll( b, y -> IsZero(x*y) ) and not x in V ); 
   while Length(C) > 0 do
      Add( b, C[1] );
      V:= SubspaceNC( P, b );
      C:= Filtered( C, x -> ForAll( b, y -> IsZero(x*y) ) and not x in V ); 
   od;

   if Dimension( Intersection( LieCentralizer( L, V ), P ) ) = Length(b) then
      return V;
   fi;

   b:= ShallowCopy( BasisVectors( Basis( Intersection( P, CartanSubalgebra(L) ) ) ) );
   V:= SubspaceNC( P, b );
   C:= Intersection( LieCentralizer( L, V ), P );
   while not found do
      k:= 1;
      while k <= Dimension(C) do
         if not Basis(C)[k] in V then
            Add( b, Basis(C)[k] );
            break;
         else
            k:= k+1;
         fi;
      od;
      C:= Intersection( LieCentralizer( L, SubalgebraNC( L, b ) ), P );
      if Dimension(C) = Length(b) then
         found:= true;
      else
         V:= SubspaceNC( P, b );
      fi;
   od;

   return C;

end );


########################################################################

corelg.MakeSqrtFieldCopyOfLieAlgebra := function(L)
local MSF, RSF, writeToSF, T, R, rank, csa, ct, cb, ci, K, P, k, p, v, vnew, tmp, mkWhere,TT, i,j, bas;

   ct := Runtime();
   T  := StructureConstantsTable(Basis(L)); 
   if not ForAll(Flat(T),IsRat) then
      Error("SCTable not rational");
   fi; 
   
   TT := ShallowCopy(T);
   for i in [1..Length(TT)] do 
      if IsList(TT[i]) then
         TT[i] := ShallowCopy(TT[i]); 
         for j in [1..Length(TT[i])] do
            TT[i][j] := ShallowCopy(TT[i][j]);
            TT[i][j][2] := TT[i][j][2]*One(SqrtField);
         od; 
      fi;
   od;
   TT[Length(TT)] := Zero(SqrtField);
   T := TT;

   if not HasRootSystem(L) then
      Error("Liealg has no rootsystem attached");
   fi;
   R    := RootSystem(L);
   MSF  := LieAlgebraByStructureConstants( SqrtField, T);
   writeToSF := function(v)
   local er;
     #er := ExtRepOfObj(v)*Sqroot(1);
      er := List(ExtRepOfObj(v),SqrtFieldEltByCyclotomic);
      return ObjByExtRep(FamilyObj(Zero(MSF)),er);
   end;            
   csa := BasisVectors(Basis(CartanSubalgebra(L)));
   csa := List(csa,writeToSF);
   csa := SubalgebraNC(MSF, csa,"basis");
   SetCartanSubalgebra(MSF, csa);

   RSF := Objectify( NewType( NewFamily( "RootSystemFam", IsObject ),
               IsAttributeStoringRep and IsRootSystemFromLieAlgebra ), 
               rec() );
   SetCanonicalGenerators( RSF, List(CanonicalGenerators(R),x->List(x,writeToSF)));
   SetUnderlyingLieAlgebra( RSF, MSF );
   SetPositiveRootVectors( RSF, List(PositiveRootVectors(R),writeToSF));
   SetNegativeRootVectors( RSF, List(NegativeRootVectors(R),writeToSF));
   SetCartanMatrix( RSF,  CartanMatrix(R) );
   SetPositiveRoots( RSF, PositiveRoots(R));
   SetNegativeRoots( RSF, NegativeRoots(R));
   SetSimpleSystem( RSF, SimpleSystem(R));
   SetRootSystem(MSF,RSF);
   SetChevalleyBasis(MSF,List(ChevalleyBasis(L),x->List(x,writeToSF)));
   K  := CartanDecomposition(L).K;
   P  := CartanDecomposition(L).P;
   ci := CartanDecomposition(L).CartanInv;
   K  := SubalgebraNC(MSF,List(Basis(K),writeToSF), "basis");
   SetCartanSubalgebra(K,SubalgebraNC(K,
             List(Basis(CartanSubalgebra(CartanDecomposition(L).K)),writeToSF)));
   P  := SubspaceNC(MSF, List(Basis(P),writeToSF), "basis");
   if HasRealFormParameters(L) then SetRealFormParameters(MSF,RealFormParameters(L)); fi;
   bas := BasisNC(MSF,Concatenation(Basis(K),Basis(P)));
   ci  := function(v)
         local k, p, cf, i;
             k   := Length(Basis(K));
             p   := Length(Basis(P));
             cf  := List(Coefficients(bas,v),x->x);
             for i in [k+1..k+p] do cf[i] := -cf[i]; od;
             return cf*bas;
          end;
   SetCartanDecomposition(MSF, rec(K:=K, P:=P, CartanInv:=ci));


   mkWhere := function(signs,mv)
   local i, new;
      new :=[];
      for i in [1..Length(signs)] do
         if signs[i]=-1 then Add(new,"P");
         elif i in Flat(mv) then Add(new,"?");
         else Add(new,"K");
         fi;
     od;
     return new;
   end;

   if HasVoganDiagram(L) then
      v   := VoganDiagram(L);
      tmp := corelg.VoganDiagramOfRealForm(MSF,
                  rec(cg      := List(CanonicalGenerators(v),x->List(x,writeToSF)), 
                      base    := ShallowCopy(BasisOfSimpleRoots(v)), 
                      mv      := ShallowCopy(MovedPoints(v)),
                      signs   := mkWhere(Signs(v),MovedPoints(v)),
                      cfsigma := ShallowCopy(CoefficientsOfSigmaAndTheta(v).cfsigma), 
                      cftheta := ShallowCopy(CoefficientsOfSigmaAndTheta(v).cftheta)));
     #SetPermInvolution(tmp,PermInvolution(v));
      SetVoganDiagram(MSF,tmp);
   fi;

   return rec(liealg := MSF, writeToSF := writeToSF);
end;
######################################################################




##############################################################################
##
##  returns all lists [<type>,<n>, signs, perm] parametrising the real forms
##  of simple Lie algebras of type <type> and rank <n> up to isomorphism
## 
corelg.ParametersOfNonCompactRealForm := function(type,n)
local params, s, i;
  params := [];
  s      := corelg.signs( type, n );
  for i in [1..Length(s)] do
      Add(params, [type,n,s[i],()]);
  od;
  if type in ["A","D","E"] and (type <> "E" or n = 6) then
     s := corelg.signsandperm( type, n ); 
     for i in [1..Length(s.sg)] do
         Add(params,[type,n,s.sg[i],s.perm]);
     od;
  fi;
  return params;
end;



##############################################################################
##  ONLY USED FOR NILPOTENT ORBITS (RECONSTRUCTION OF DATABASE)
##  returns all noncompact real forms of simple Lie algebras of type <type> 
##  and rank <n> up to isomorphism. If <params> is given, then it has to be
##  a sublist of corelgParametersOfNonCompactRealForm( <type>, <n> ); in this case
##  only the real forms parametrised by these entries are constructed.
##  The output is a list with the following entries:
##            liealg    : the real form defined over Gaussian Rationals, 
##            liealgSF  : the real form defined over SqrtField,
##            writeToSF : function from liealg to liealgSF,
##            rank      : <n>,
##            type      : <type>,
##  all Lie algebras have a rootsystem, CartanSubalgebra and CartanDecompositon
##  attached.
##
corelg.NonCompactRealFormsOfSimpleLieAlgebra := function(arg)
local type, n, rforms, L, LSF, forms, tmp, F, withField, i, sigma;

   withField := false;
   if IsField(arg[Length(arg)]) then 
      F := arg[Length(arg)]; 
      withField := true;
      arg := arg{[1..Length(arg)-1]};
   else 
      F := GaussianRationals; 
   fi;
   if Length(arg) = 2 then   
      type := arg[1];
      n    := arg[2];
      rforms := corelg.RealFormsOfSimpleLieAlgebra( type, n, F);
      rforms := rforms{[2..Length(rforms)]};
   elif Length(arg)=1 then
      arg  := arg[1];
      type := arg[1];
      n    := arg[2];
   fi;
   if Length(arg) = 4 then
      tmp := corelg.SuperLie( type, n, arg[3], arg[4],F );
      SetRealFormParameters(tmp, [type,n,arg[3],arg[4]]);
      rforms := [tmp];
   fi;

   if withField then 
      if E(4) in F or IsSqrtField(F) then      
         for i in rforms do sigma := RealStructure(i); od;
      fi;
      if Length(rforms)=1 then return rforms[1]; else return rforms; fi; 
   fi;

   forms := [];
   for L in rforms do
     #Print("now make copies...\n");
      LSF := corelg.MakeSqrtFieldCopyOfLieAlgebra(L);
      SetIsCompactForm(L,false);
      SetIsCompactForm(LSF.liealg,false);
      if RealFormParameters(LSF.liealg)[4]=() then
         SetIsRealFormOfInnerType(LSF.liealg,true);
         SetIsRealFormOfInnerType(L,true);
      else
         SetIsRealFormOfInnerType(LSF.liealg,false);
         SetIsRealFormOfInnerType(L,false);
      fi;
      sigma := RealStructure(LSF);
      Add(forms, rec( liealg    := L, 
                      liealgSF  := LSF.liealg, 
                      writeToSF := LSF.writeToSF,
                      rank      := n,
                      type      := type));
   od;

   if Length(arg)=4 then return forms[1]; else return forms; fi;
end;


##################################################################


##################################################################
# input:  output of FiniteOrderInnerAutomorphism(type,rank,2)
#         (assumes that theta is in std form, that is, it maps
#          (h_i,x_i,y_i) to (h_i,\mu_i x_i, \mu_i^{-1} y_i)
# output: real form with attached CSA, RS and CartanDecomposition;
#         defined over GaussianRationals wrt theta^tau
#
corelg.RealFormByInnerInvolutiveAutomorphism := function(theta)
local makeCartInv, L, ch, i, k0, p0, k, K, P, bas, T, M, R, im, cg,F;

   if IsList(theta) then
      if Length(theta)=4 then F:=theta[4]; else F:=GaussianRationals; fi;
      L  := SimpleLieAlgebra(theta[1],theta[2],F);
      cg := CanonicalGenerators(RootSystem(L));
      im := [List([1..theta[2]],x-> theta[3][x]*cg[1][x]),
             List([1..theta[2]],x-> theta[3][x]*cg[2][x]),
             List([1..theta[2]],x->cg[3][x])];
      theta := LieAlgebraIsomorphismByCanonicalGenerators(L,cg,L,im);
   fi;
 
   
  makeCartInv := function(L,K,P)
  local bas;
     bas := BasisNC(L,Concatenation(Basis(K),Basis(P)));
     return function(v)
     local k, p, cf, i;   
        k   := Length(Basis(K));
        p   := Length(Basis(P));
        cf  := List(Coefficients(bas,v),x->x);
        for i in [k+1..k+p] do cf[i] := -cf[i]; od;
           return cf*bas;
        end;
   end; 
 
   L     := Source(theta); 
   F     := LeftActingDomain(L);
   ch    := ChevalleyBasis(L);
   i     := E(4)*One(F);
   k0    := List( ch[3], x -> i*x );
   p0    := [ ];
   for k in [1..Length(ch[1])] do
      if Image( theta, ch[1][k] ) = ch[1][k] then
         Append( k0, [ ch[1][k]-ch[2][k], i*(ch[1][k]+ch[2][k]) ] );
      else
         Append( p0, [ i*(ch[1][k]-ch[2][k]), ch[1][k]+ch[2][k] ] );
      fi;
   od;
   bas := Concatenation( k0, p0 );
   T   := StructureConstantsTable( Basis(L,bas) );
   M   := LieAlgebraByStructureConstants( F , T );
   SetCartanSubalgebra( M, SubalgebraNC( M, Basis(M){[1..Length(ch[3])]}) );
   R   := RootsystemOfCartanSubalgebra(M);
   SetRootSystem(M,R);
   K   := SubalgebraNC(M,Basis(M){[1..Length(k0)]});
   P   := SubspaceNC(M,Basis(M){[Length(k0)+1..Length(bas)]});
   SetCartanDecomposition(M, rec(K:=K, P:=P, CartanInv := makeCartInv(M,K,P)));
   return M;
end;



##################################################################
# input:  positive roots "pr" with corresponding Chev. basis "cb",
#         and a (new) base of simple roots "bas" contained in pr cat -pr
# output: canonical generators wrt base contained in "cb" 
#
corelg.makeCanGenByBase := function(pr,cb,bas)
local tmp, j, pos;
   tmp := [[],[],[]];
   for j in [1..Length(bas)] do
      pos := Position(pr,bas[j]);
      if not pos = fail then
         Add(tmp[1],cb[1][pos]);
         Add(tmp[2],cb[2][pos]);
         Add(tmp[3],cb[1][pos]*cb[2][pos]);
      else
         pos := Position(pr,-bas[j]);
         Add(tmp[1],cb[2][pos]);
         Add(tmp[2],cb[1][pos]);
         Add(tmp[3],cb[2][pos]*cb[1][pos]);
      fi;
   od; 
   return tmp;
end;



##################################################################
# input:  R a root system, base a base:
# output: enumeration wrt can ordering
#
corelg.enumOfBase := function(R,base)
local tmp, bbas, C, en, rank, B;
   rank := Length(SimpleSystem(R));    
   tmp  := BasisNC(VectorSpace(Rationals,IdentityMat(rank)),SimpleSystemNF(R));
   B    := BilinearFormMatNF(R);
   bbas := List(base,x->Coefficients(tmp,x));
   C    := List( bbas, x -> List( bbas, y -> 2*(x*B*y)/(y*B*y) ) );
   en   := Concatenation( CartanType(C).enumeration );
   return en;
end;



##################################################################
# 
# the stuff for Vogan diagrams
#
corelg.VoganDiagramOfRealForm := function(L, list)
      local o, fam, H,R,en,base,C,tmp,signs,i;

      if not IsBound( L!.voganDiagType ) then
         fam:= NewFamily( "vogandiagfam", IsVoganDiagramOfRealForm );
         L!.voganDiagType:= NewType( fam, IsVoganDiagramOfRealForm and IsAttributeStoringRep );
      fi;
     #these just for getting CartanType!
      C :=  corelg.CartanMatrixOfCanonicalGeneratingSet(L,list.cg);
      o := Objectify( L!.voganDiagType, rec(param:=CartanType(C).types) ); #!!!
      SetCanonicalGenerators(o,List(list.cg,x->List(x,y->y)));
      SetBasisOfSimpleRoots(o,list.base);
      SetMovedPoints(o,list.mv);
      tmp := [1..Length(C)];
      for i in list.mv do tmp[i[1]] := i[2]; tmp[i[2]] := i[1]; od;
      SetPermInvolution(o,PermList(tmp));
      signs := [];
      for i in list.signs do if i="P" then Add(signs,-1); else Add(signs,1); fi; od;
      SetSigns(o,signs);    
      
      SetCartanMatrix(o,C);
      
      SetCoefficientsOfSigmaAndTheta(o,rec(cfsigma:=list.cfsigma, cftheta:=list.cftheta));
      return o;
end ;



################################################################################

#this is display:
InstallMethod( PrintObj,
   "for Vogan diagram",
   true,
   [ IsVoganDiagramOfRealForm ], 0,
   function( o )
   local r,t,m,i,minus,signs, tmp;
      r := Sum(List(o!.param,x->x[2]));
      m := MovedPoints(o);
      signs := Signs(o);
      minus := Filtered([1..r],x->Signs(o)[x]=-1);
      corelg.prntdg(CartanMatrix(o),minus);
      Print("\nInvolution: ",PermInvolution(o));
      
      if IsBound(o!.sstypes) then 
         Print("\nTypes of direct summands:\n");
         Print(o!.sstypes); 
      fi;
end );


InstallMethod( ViewObj,
   "for Vogan diagram",
   true,
   [ IsVoganDiagramOfRealForm ], 0,
   function( o )
   local i,tmp,new;
      tmp := List(o!.param,x->Concatenation(x[1],String(x[2])));
      if Length(tmp)>1 then
         new :="";
         for i in [1..Length(tmp)-1] do new := Concatenation([new,tmp[i],"+"]); od;
         tmp := Concatenation(new,tmp[Length(tmp)]);
      else
         tmp := tmp[1];
      fi;
      Print(Concatenation(["<Vogan diagram in Lie algebra of type ",tmp,">"]));
end );



##############################################################################
# input:  realification,
#         defined over Gaussian rationals, with attached Cartan decompositions
#         (record with entries K, P and a function CartanInv)
# output: vogan diagram of Lie algebra
#
corelg.VoganDiagramRealification := function(L)
local res, rank, cd, h, r, c, cg, e, sigma, cf, cb, newcg, iso, wh, phi, i, testCFs, tmpcb,tmpsp,
      getWeyl, liealgs, whs, pos, L1, Lj, isoms, l, isos, j, inn, R, cfs, cft, bb, W, notmv, act,
      tmp,  applyReflection, hs, found, es, fs, h0, vals, pr, posr,  s, B, C, en, base, where,
      sps, mv, cf2, mat, newpr, ims, bbase, bcg, theta, sums, posK, posP, orb, bbas,
      prKind, prK, prP, dim, bas, ct, tt, rr, todo, todoE, todoL, getNewWeyl;
 
      if HasVoganDiagram(L) then return VoganDiagram(L); fi;

      Info(InfoCorelg,2,"   start Vogan Diagram for realification; get CartDecomp and CSA");
      cd    := CartanDecomposition(L);
      h     := MaximallyCompactCartanSubalgebra(L);
      rank  := Dimension(h);
      theta := cd.CartanInv;
      sigma := RealStructure(L);
      R    := RootsystemOfCartanSubalgebra(L,h);
      cb   := ChevalleyBasis(R);
      cg   := CanonicalGenerators(R);
      ct   := CartanType(CartanMatrix(R));
      if not ForAll(Basis(h),x->theta(x) in h) then
         Error("need a theta-stable CSA; Cartan Dec and CSA must be compatible!");
      fi;
      SetIsRealFormOfInnerType(L,false);
      Info(InfoCorelg,2,"   ... done; continue with Vogan Diagram for realification");
      

     #find h0 to define new root ordering; take CSA compatible with h
      tmp := Intersection(cd.K,h);
      hs  := ShallowCopy( CanonicalGenerators(RootsystemOfCartanSubalgebra(cd.K,tmp))[3]);
      
      if not ForAll(hs,x->x in h) then Error("ups..CSA"); fi;
      found := false;
      es    := PositiveRootVectors(R);
      while not found do 
         h0 := Sum( hs, h -> Random([-100..100])*h );
         if ForAll( es, x -> not IsZero( h0*x ) ) then found:= true; fi;
      od;
     #find new basis of simple roots (def by root ordering induced by h0)
      vals := List( es, x -> Coefficients( Basis( SubspaceNC( L, [x],"basis" ), [x] ), h0*x )[1] );
      pr   := PositiveRootsNF(R);
      posr := [ ];
      for i in [1..Length(pr)] do
         if vals[i] > vals[i]*0 then Add( posr, pr[i] ); else Add( posr, -pr[i] ); fi; ###^0
      od;
      sums := [];
      for r in posr do for s in posr do Add( sums, r+s ); od; od;
      base := Filtered( posr, x -> not x in sums );
      B    := BilinearFormMatNF(R);
      C    := List( base, x -> List( base, y -> 2*(x*B*y)/(y*B*y) ) );
      ct   := CartanType(C);
      en   := Concatenation( CartanType(C).enumeration );
      if ct.types[1] = ["F",4] then
           en := en{[4,1,3,2,   8,5,7,6]};
      fi;             
      base := base{en};
       
     #now construct corresponding canonical generators
      newcg := corelg.makeCanGenByBase(pr,cb,base);
      es    := newcg[1];
      fs    := newcg[2];

      sps := List( es, x -> SubspaceNC( L, [x],"basis" ) );
      mv  := [];
      for i in [1..Length(es)] do
         j := PositionProperty( sps, U -> theta( es[i] ) in U );
         if j > i then
            Add(mv,[i,j]);
            es[j]:= theta( es[i] );
            fs[j]:= theta( fs[i] );
         fi;
     od;
     Sort(mv);
     notmv := Filtered([1..rank],x->not x in Flat(mv));
     newcg := [es,fs,List( [1..Length(es)], i -> es[i]*fs[i] ) ];
      
     #computes coefficients wrt sigma and theta 
      testCFs := function(newcg)
      local cft, cfs, i;
         cfs  := ListWithIdenticalEntries(rank,1);
         cft  := ListWithIdenticalEntries(rank,1);
         for i in notmv do
            cfs[i] := Coefficients(Basis(SubspaceNC(L,[newcg[2][i]],"basis"),[newcg[2][i]]),
                                   sigma(newcg[1][i]))[1];
         od;
         for i in mv do
            cfs[i[1]] := Coefficients(Basis(SubspaceNC(L,[newcg[2][i[2]]],"basis"),[newcg[2][i[2]]]), 
                                       sigma(newcg[1][i[1]]))[1] ;
            cfs[i[2]] := Coefficients(Basis(SubspaceNC(L,[newcg[2][i[1]]],"basis"),[newcg[2][i[1]]]), 
                                       sigma(newcg[1][i[2]] ))[1] ;
          od;
         for i in notmv do
            cft[i] := Coefficients(Basis(SubspaceNC(L,[newcg[1][i]],"basis"),[newcg[1][i]]), 
                                    theta(newcg[1][i] ))[1] ;
         od;
         for i in mv do
            cft[i[1]] := Coefficients(Basis(SubspaceNC(L,[newcg[1][i[2]]],"basis"),[newcg[1][i[2]]]),
                                      theta(newcg[1][i[1]]))[1] ;
            cft[i[2]] := Coefficients(Basis(SubspaceNC( L,[newcg[1][i[1]]],"basis"),[newcg[1][i[1]]]), 
                                      theta(newcg[1][i[2]] ))[1] ;
         od;
         if not ForAll([1..rank],x-> cfs[x]*cft[x]<cft[x]*0) then Error("mhmm..signs wrong"); fi; ##^0
         if not ForAll(Flat(mv),x->cft[x]=cft[x]^0) then Error("mhmm"); fi;
         return rec(cfs := cfs, cft := cft);
      end; 


 
      tmp := testCFs(newcg);
      cft := tmp.cft;
      cfs := tmp.cfs;
      tmp := corelg.VoganDiagramOfRealForm(L,
                 rec(cg:=newcg,  
                     base:=base, 
                     mv := mv,
                     signs:=ListWithIdenticalEntries(2*Length(mv),"?"),
                     cfsigma:=cfs, 
                     cftheta:=cft));
      SetVoganDiagram(L,tmp);
     
      if Length(tmp!.param)=1 then
         mv := IdRealForm(L);
         SetRealFormParameters(L,RealFormParameters(RealFormById(mv)));
      fi;
      Info(InfoCorelg,2,"   end Vogan Diagram for realification"); 
      tmp := VoganDiagram(L);
### added this
      if Length(ct.types)=2 and ct.types[1] = ct.types[2] then
         tmp!.sstypes :=  [Concatenation(ct.types[1],[0])];
        #Print("added ",tmp!.sstypes,"\n");
      else
         Display("did NOT add id to realification...");
      fi;
       return tmp;
end;


##############################################################################
# input:  simple real form,
#         defined over Gaussian rationals, with attached Cartan decompositions
#         (record with entries K, P and a function CartanInv)
# output: vogan diagram of Lie algebra
#
corelg.SingleVoganDiagram := function(L)
local res, rank, cd, h, r, c, cg, e, sigma, cf, cb, newcg, iso, wh, phi, i, testCFs, tmpcb,tmpsp,
      getWeyl, liealgs, whs, pos, L1, Lj, isoms, l, isos, j, inn, R, cfs, cft, bb, W, notmv, act,
      tmp,  applyReflection, hs, found, es, fs, h0, vals, pr, posr,  s, B, C, en, base, where,
      sps, mv, cf2, mat, newpr, ims, bbase, bcg, theta, sums, posK, posP, orb, bbas,
      prKind, prK, prP, dim, bas, ct, tt, rr, todo, todoE, todoL, getNewWeyl;
 
      if HasVoganDiagram(L) then return VoganDiagram(L); fi;

      Info(InfoCorelg,2,"   start Vogan Diagram for simple LA; get CartDecomp and CSA");
      cd    := CartanDecomposition(L);
      h     := MaximallyCompactCartanSubalgebra(L);
      rank  := Dimension(h);
      theta := cd.CartanInv;
      sigma := RealStructure(L);
      inn  := rank = Dimension(CartanSubalgebra(cd.K));
      R    := RootsystemOfCartanSubalgebra(L,h);
      cb   := ChevalleyBasis(R);
      cg   := CanonicalGenerators(R);
      ct   := CartanType(CartanMatrix(R));
      if not ForAll(Basis(h),x->theta(x) in h) then
         Error("need a theta-stable CSA; Cartan Dec and CSA must be compatible!");
      fi;
      SetIsRealFormOfInnerType(L,inn);
      Info(InfoCorelg,2,"    ... done; continue with Vogan Diagram for simple LA");

    ##compact form
      if Dimension(cd.P)=0 then
         base  := SimpleSystemNF(R);
         pr    := PositiveRootsNF(R);
         en    := Concatenation( CartanType(CartanMatrix(R)).enumeration );
         base  := base{en};
        #now enumeration is [1...r]; for F4 make it [2,4,3,1]:
         if ct.types[1]=["F",4] then base := base{[4,1,3,2]}; fi;
        #now construct corresponding canonical generators
         cg := corelg.makeCanGenByBase(pr,cb,base);

         cfs  := ListWithIdenticalEntries(rank,1);
         for i in [1..rank] do
            cfs[i] := Coefficients(BasisNC(SubspaceNC(L,[cg[2][i]],"basis"),[cg[2][i]]),
                                                    sigma(cg[1][i]))[1];
         od;  
         tmp  := corelg.VoganDiagramOfRealForm(L,rec(cg   := cg, 
                                                      base := base, 
                                                      mv:=[],
                                                      signs:=ListWithIdenticalEntries(rank,"K"), 
                                                      cfsigma:=cfs, 
                                                      cftheta:=ListWithIdenticalEntries(rank,1)));
         SetVoganDiagram(L,tmp);
         SetRealFormParameters(L,[ct.types[1][1],ct.types[1][2],ListWithIdenticalEntries(ct.types[1][2],1),()]);

         tmp := VoganDiagram(L);
         tmp!.sstypes := [IdRealForm(L)];
         L!.sstypes   := [IdRealForm(L)];
         return tmp;
      fi;
 
      

    ################################
    # SOME PRELIMINARY FUCTIONS    #
    ################################

    #input Cartan decomposition "cd" and can gens "cg"
    #returns list of "K" and "P" wrt cg[i] lying in cd.K or cd.P
      where := function(cd,cg)
      local i, wh; 
         wh := [];     
         for i in cg[1] do
            if i in cd.K then Add(wh,"K"); 
            elif i in cd.P then Add(wh,"P"); 
            else Add(wh,"?"); fi;
         od; 
      return wh;
      end;


     #computes coefficients wrt sigma and theta 
      testCFs := function(newcg)
      local cft, cfs, i;
         cfs  := ListWithIdenticalEntries(rank,1);
         cft  := ListWithIdenticalEntries(rank,1);
         for i in notmv do
            cfs[i] := Coefficients(Basis(SubspaceNC(L,[newcg[2][i]],"basis"),[newcg[2][i]]),
                                   sigma(newcg[1][i]))[1];
         od;
         for i in mv do
            cfs[i[1]] := Coefficients(Basis(SubspaceNC(L,[newcg[2][i[2]]],"basis"),[newcg[2][i[2]]]), 
                                       sigma(newcg[1][i[1]]))[1] ;
            cfs[i[2]] := Coefficients(Basis(SubspaceNC(L,[newcg[2][i[1]]],"basis"),[newcg[2][i[1]]]), 
                                       sigma(newcg[1][i[2]] ))[1] ;
          od;
         for i in notmv do
            cft[i] := Coefficients(Basis(SubspaceNC(L,[newcg[1][i]],"basis"),[newcg[1][i]]), 
                                    theta(newcg[1][i] ))[1] ;
         od;
         for i in mv do
            cft[i[1]] := Coefficients(Basis(SubspaceNC(L,[newcg[1][i[2]]],"basis"),[newcg[1][i[2]]]),
                                      theta(newcg[1][i[1]]))[1] ;
            cft[i[2]] := Coefficients(Basis(SubspaceNC( L,[newcg[1][i[1]]],"basis"),[newcg[1][i[1]]]), 
                                      theta(newcg[1][i[2]] ))[1] ;
         od;
         if not ForAll([1..rank],x-> cfs[x]*cft[x]<cft[x]*0) then Error("mhmm..signs wrong"); fi; ##^0
         if not ForAll(Flat(mv),x->cft[x]=cft[x]^0) then Error("mhmm"); fi;
         return rec(cfs := cfs, cft := cft);
      end; 
     
     #apply the reflection s_{base[j]}\in W to the can gen set newcg
     #return record with new can gens, new base, new Weyl group gens (wrt new base)
      applyReflection := function(newcg,j,base)
      local tmp, pos,ims,W;

        #get Weyl automorphism
          ims := List(base,x-> x-(2*(x*B* base[j])/( base[j]*B* base[j]))* base[j]);           
          W   := LieAlgebraIsomorphismByCanonicalGenerators(L,newcg,L,corelg.makeCanGenByBase(pr,cb,ims));

         newcg := List(newcg,x->List(x,y->Image(W,y)));
         for i in mv do
            #really need this, e.g. if L=RealFormById("E",6,2)
             newcg[1][i[2]] := theta(newcg[1][i[1]]);
             newcg[2][i[2]] := theta(newcg[2][i[1]]);
             newcg[3][i[2]] := newcg[1][i[2]]*newcg[2][i[2]];
         od;
         wh  := where(cd,newcg);         
         tmp := [];
         for i in newcg[1] do 
            pos := PositionProperty(cb[1],x->i in SubspaceNC(L,[x],"basis")); 
            if not pos = fail then
               Add(tmp,pr[pos]);
            else
               pos := PositionProperty(cb[2],x->i in SubspaceNC(L,[x],"basis")); 
               Add(tmp,-pr[pos]);
            fi;
         od;
         
         return rec(cg:=newcg, wh:=wh, base:=tmp);
      end;

 
     ################################################# 

     #consider form of INNER TYPE
 
     if inn then

         mv    :=[];
         notmv := [1..rank];
         base  := SimpleSystemNF(R); 
         pr    := PositiveRootsNF(R);
         en    := Concatenation( CartanType(CartanMatrix(R)).enumeration );
         base  := base{en};

        #now enumeration is [1...r]; for F4 make it [2,4,3,1]:
         if ct.types[1]=["F",4] then 
            base := base{[4,1,3,2]};
         fi;

        #now construct corresponding canonical generators
         newcg := corelg.makeCanGenByBase(pr,cb,base);
         B     := BilinearFormMatNF(R);
  
         wh    := where(cd,newcg);
        #Print("this is 1st wh ",wh,"\n");
         tt    := ct.types[1][1];  
         rr    := ct.types[1][2]; 
         
         if tt="D" and rr=4 then
             pos   := PositionsProperty(wh,x->x="P");
             todo := [];
             if Length(pos)=4 then todo := [2]; fi;
             if Length(pos)=3 then
                tmp := Filtered([1..4],x-> not x in pos)[1];
                if tmp = 2 then todo := [1,2]; else todo := [2,tmp]; fi;
             fi;
             if Length(pos)=2 then
                tmp := Filtered([1..4],x-> not x in pos);
                if 2 in tmp then 
                   i    := Filtered(tmp,x-> not x = 2)[1]; 
                   todo := [pos[1],2,i];
                else
                   todo := Filtered(pos,x->not x=2);
                fi;
             fi;
             for i in todo do
                newcg := applyReflection(newcg,i,base);
                wh    := newcg.wh; 
                base  := newcg.base;
                newcg := newcg.cg;
                pos := PositionsProperty(wh,x->x="P");
               #Print("this is new wh ",wh,"\n");
            od;
            if not Length(pos)=1 then Error("ups"); fi;
            if not pos[1] in [2,3] then
               tmp   := Filtered([1..4],x-> not x in [pos[1],2]);
               tmp   := [tmp[1],2,pos[1],tmp[2]];
               if not IsDuplicateFreeList(tmp) then Error("ups"); fi;
               base  := base{tmp};
               newcg := corelg.makeCanGenByBase(pr,cb,base);
               wh    := where(cd,newcg);
               pos   := PositionsProperty(wh,x->x="P");              
            fi;
            if not Length(pos)=1 or not pos[1] in [2,3] then Error("upsi"); fi;
         fi;

       ###
       # TYPE A and B:
       # find a base such that
       #   A: have at most one "P" in the first \lceil rank/2\rceil entries
       #   B: have at most one "P"
       ###
         if tt in ["A","B"] then
            pos := PositionsProperty(wh,x->x="P");
            while Length(pos)>1 do 
               newcg := applyReflection(newcg,pos[Length(pos)-1],base);
               wh    := newcg.wh; 
               base  := newcg.base;
               newcg := newcg.cg;
               pos := PositionsProperty(wh,x->x="P");
            od;
           #diag aut:
            if tt = "A" and pos[1] > rank/2 then
               base  := Reversed(base);
               newcg := corelg.makeCanGenByBase(pr,cb,base);
               wh    := where(cd,newcg);
               pos := PositionsProperty(wh,x->x="P");
            fi;
         fi;     

        ###
        # TYPE C and D:
        # find a base such that
        #   C: have at most one "P"
        #   D: have at most one "P" in first < (n+1)/2 entries, or 1..1-11
        ###
         if tt in ["C","D"] and not [tt,rr]=["D",4] then
            pos := PositionsProperty(wh,x->x="P");
            while Length(pos)>1 and not (tt="D" and pos = [rank-1,rank]) do 
               newcg := applyReflection(newcg,pos[2],base);
               wh    := newcg.wh; 
               base  := newcg.base;
               newcg := newcg.cg;
               pos := PositionsProperty(wh,x->x="P");
              #Print("this is new wh ",wh,"\n");
            od;
            todo := [];
            if tt="D" and pos = [rank-1,rank] then 
               todo := Reversed([1..rank-1]); 
               for i in todo do
                  newcg := applyReflection(newcg,i,base);
                  wh    := newcg.wh; 
                  base  := newcg.base;
                  newcg := newcg.cg;
                  pos := PositionsProperty(wh,x->x="P");
                 #Print("this is new wh ",wh,"\n");
               od;
            fi;
           #bring P in first half
            if tt="D" and Length(pos)=1 and pos[1]>=(rank+1)/2 and not pos[1] in [rank,rank-1] then
               tmp  := rank-2-pos[1]+2;
               todo := List(Reversed([1..pos[1]]),x->List([1..tmp],y->x+y-1));
               todo := Concatenation(todo); 
               for i in todo do
                  newcg := applyReflection(newcg,i,base);
                  wh    := newcg.wh; 
                  base  := newcg.base;
                  newcg := newcg.cg;
                  pos := PositionsProperty(wh,x->x="P");
                 #Print("this is new wh ",wh,"\n");
               od;
            fi;
           #apply diag aut for D
            if tt="D" and pos = [rank] then
               tmp   := base[rank]; base[rank] := base[rank-1]; base[rank-1] := tmp;
               newcg := corelg.makeCanGenByBase(pr,cb,base);           
               wh    := where(cd,newcg);
               pos := PositionsProperty(wh,x->x="P");
            fi;
            if tt = "C" and (pos[1]>(rank)/2 and not pos[1]=rank) then
               tmp  := rank-1-pos[1];
               todo := List(Reversed([1..pos[1]]),x->List([0..tmp],y->x+y));
               todo := Concatenation(todo); 
               for i in todo do
                  newcg := applyReflection(newcg,i,base);
                  wh    := newcg.wh; 
                  base  := newcg.base;
                  newcg := newcg.cg;
                  pos := PositionsProperty(wh,x->x="P");
                 #Print("this is new wh ",wh,"\n");
               od;
            fi;
         fi; 


         ####
         # TYPE G2, F4, E6, E7, E8:
         # find base such that in std numbering of simple roots:
         #   G2: -11
         #   F4: 1-111 or 11-11 
         #   E6: (-111111), (1-11111)
         #   E7: (-1111111), (1-111111), (111111-1)
         #   E8: (-11111111), (1111111-1)
         ####
         if tt in ["G","F","E"] then
            pos  := PositionsProperty(wh,x->x="P");
            todo := [];
           #case G2
            if rr = 2 then
               if Length(pos)=2 then todo := [2]; fi;
               if pos = [1] then todo := [1,2]; fi;
           #case F4
            elif rr = 4 then
              #this is for the case that base has can ord [1,2,3,4]:
              #todoL := [[[],[]],[[2],[]],[[1,2,3],[2]],[[1,2,3,4],[3,2]],
              #       [[1,2,4],[4,3,2]],[[1,3],[1,2]],
              #       [[1,3,4],[1,3,2]],[[1,4],[1,4,3,2]],
              #       [[2,4],[2,3,2]],[[2,3,4],[2,4,3,2]],
              #       [[2,3],[3,2,4,3,2]],[[1,2],[2,3,2,4,3,2]],
              #       [[1],[1,2,3,2,4,3,2]],[[3],[]],[[3,4],[3]],[[4],[4,3]]];
              # todo := todoL[Position(List(todoL,x->x[1]),pos)][2];

              #this is for the case that base has can ord [2,4,3,1]:
              todoL:=[[[],[]],[[4],[]],[[2,3,4],[4]],[[1,2,3,4],[3,4]],[[1,2,4],[1,3,4]],
                     [[2,3],[2,4]],[[1,2,3],[2,3,4]],[[1,2],[2,1,3,4]],[[1,4],[4,3,4]],
                     [[1,3,4],[4,1,3,4]],[[3,4],[3,4,1,3,4]],[[2,4],[4,3,4,1,3,4]],
                      [[2],[2,4,3,4,1,3,4]],[[3],[]],[[1,3],[3]],[[1],[1,3]]];
              #todoL := [ [[],[]], [[1],[1,3]], [[2],[2,4,3,4,1,3,4]]];
               todo := todoL[Position(List(todoL,x->x[1]),pos)][2];

           #case E
            else
                while Length(pos)>1 and not (Length(pos)=2 and 2 in pos) do
                  tmp := pos[Length(pos)-1];
                  if tmp=2 then tmp:=pos[Length(pos)-2]; fi;
                  newcg := applyReflection(newcg,tmp,base);
                  wh    := newcg.wh; 
                  base  := newcg.base;
                  newcg := newcg.cg;
                  pos := PositionsProperty(wh,x->x="P");
                 #Print("this is new wh ",wh,"\n");
               od;               
              #E: now either 1x(-1) or 2x(-1) where lambda_2=-1
               if rr = 6 then       
                  todoL := [[[],[]],[[1],[]],[[1,3],[1]],[[3,4],[3,1]],
                           [[2,6],[6,5,4,3,1]],[[2,5],[2,4,3,1]],
          [[3,5],[5,4,2,6,5,4,3,1]],
      [[1,6],[1,3,4,2,5,4,3,1]],
      [[1,2],[2,4,3,5,4,2,6,5,4,3,1]],
      [[2,3],[3,1,4,3,5,4,2,6,5,4,3,1]],
      [[4,5],[4,3,2,1,4,3,5,4,2,6,5,4,3,1]],
      [[5,6],[5,4,3,2,1,4,3,5,4,2,6,5,4,3,1]],
      [[6],[6,5,4,3,2,1,4,3,5,4,2,6,5,4,3,1]],
      [[2],[]],[[2,4],[2]],[[3,6],[6,5,4,2]],
      [[1,5],[1,3,4,2]],[[1,4],[4,2,1,5,4,3,6,5,4,2]]
      ,[[4],[4,3,1,5,4,3,6,5,4,2]],
      [[4,6],[4,3,2,1,4,3,6,5,4,2]],
      [[5],[5,4,3,2,1,4,3,5,4,2]],
      [[3],[3,4,2,5,4,3,6,5,4,2]]];
               elif rr = 7 then
                  todoL :=[[[],[]],[[7],[]],[[6,7],[7]],[[5,6],[6,7]],
                           [[4,5],[5,6,7]],[[2,3],[2,4,5,6,7]],
      [[1,7],[7,6,5,4,3,2,4,5,6,7]],
      [[1,2],[1,3,4,5,6,7]],
      [[3,5],[3,1,4,3,2,4,5,6,7]],
      [[2,6],[6,5,4,3,1,7,6,5,4,3,2,4,5,6,7]],
      [[2],[]],[[2,4],[2]],[[3,7],[7,6,5,4,2]],
      [[1,5],[1,3,4,2]],[[4,7],[4,3,1,5,4,3,6,5,4,2]]
      ,[[5],[5,4,3,1,6,5,4,3,7,6,5,4,2]],[[1],[]],
      [[1,3],[1]],[[3,4],[3,1]],
      [[2,7],[7,6,5,4,3,1]],[[2,5],[2,4,3,1]],
      [[3,6],[6,5,4,2,7,6,5,4,3,1]],
      [[1,6],[1,3,4,2,5,4,3,1]],
      [[1,4],[4,2,1,5,4,3,6,5,4,2,7,6,5,4,3,1]],
      [[4],[4,3,1,5,4,3,6,5,4,2,7,6,5,4,3,1]],
      [[4,6],[4,3,2,1,4,3,6,5,4,2,7,6,5,4,3,1]],
      [[5,7],[5,4,3,2,1,4,3,5,4,2,7,6,5,4,3,1]],
      [[6],[6,5,4,3,2,1,4,3,5,4,2,6,5,4,3,1]],
      [[3],[3,4,2,5,4,3,6,5,4,2,7,6,5,4,3,1]] ];
               elif rr=8 then
                  todoL := [[[],[]],[[8],[]],[[7,8],[8]],[[6,7],[7,8]],[[5,6],[6,7,8]],
                            [[4,5],[5,6,7,8]],
                            [[2,3],[2,4,5,6,7,8]],[[1,8],[8,7,6,5,4,3,2,4,5,6,7,8]],
       [[1,2],[1,3,4,5,6,7,8]],[[3,5],[3,1,4,3,2,4,5,6,7,8]],
       [[2,7],[7,6,5,4,3,1,8,7,6,5,4,3,2,4,5,6,7,8]],
       [[2,6],[2,4,3,1,5,4,3,2,4,5,6,7,8]],
       [[3,6],[6,5,4,2,7,6,5,4,3,1,8,7,6,5,4,3,2,4,5,6,7,8]],
       [[1,7],[1,3,4,2,5,4,3,1,6,5,4,3,2,4,5,6,7,8]],
       [[1,4],[4,2,1,5,4,3,6,5,4,2,7,6,5,4,3,1,8,7,6,5,4,3,2,4,5,6,7,8]],
       [[4],[4,3,1,5,4,3,6,5,4,2,7,6,5,4,3,1,8,7,6,5,4,3,2,4,5,6,7,8]],
       [[4,6],[4,3,2,1,4,3,6,5,4,2,7,6,5,4,3,1,8,7,6,5,4,3,2,4,5,6,7,8]],
       [[5,7],[5,4,3,2,1,4,3,5,4,2,7,6,5,4,3,1,8,7,6,5,4,3,2,4,5,6,7,8]],
      [[6,8],[6,5,4,3,2,1,4,3,5,4,2,6,5,4,3,1,8,7,6,5,4,3,2,4,5,6,7,8]],
       [[7],[7,6,5,4,3,2,1,4,3,5,4,2,6,5,4,3,1,7,6,5,4,3,2,4,5,6,7,8]],
       [[3],[3,4,2,5,4,3,6,5,4,2,7,6,5,4,3,1,8,7,6,5,4,3,2,4,5,6,7,8]],
       [[1],[]],[[1,3],[1]],[[3,4],[3,1]],[[2,8],[8,7,6,5,4,3,1]],
       [[2,5],[2,4,3,1]],[[3,7],[7,6,5,4,2,8,7,6,5,4,3,1]],
       [[1,6],[1,3,4,2,5,4,3,1]],[[4,8],[4,3,1,5,4,3,6,5,4,2,7,6,5,4,3,1]],
       [[4,7],[4,3,2,1,4,3,7,6,5,4,2,8,7,6,5,4,3,1]],
       [[1,5],[5,4,2,1,6,5,4,3,7,6,5,4,2,8,7,6,5,4,3,1]]
       ,[[5],[5,4,3,1,6,5,4,3,7,6,5,4,2,8,7,6,5,4,3,1]
       ],[[5,8],[5,4,3,2,1,4,3,5,4,2,8,7,6,5,4,3,1]],
       [[6],[6,5,4,3,2,1,4,3,5,4,2,6,5,4,3,1]],
       [[3,8],[3,4,2,5,4,3,6,5,4,2,7,6,5,4,3,1]],
       [[2,4],[4,3,5,4,2,6,5,4,3,7,6,5,4,2,8,7,6,5,4,3,1]],
       [[2],[2,4,3,5,4,2,6,5,4,3,7,6,5,4,2,8,7,6,5,4,3,1]]];
               fi;
               todo := todoL[Position(List(todoL,x->x[1]),pos)][2];
            fi;

           #Print("this is new wh ",wh,"\n");
            for i in todo do 
              #Print("act with ",i,"\n");
               newcg := applyReflection(newcg,i,base);
               wh    := newcg.wh; 
               base  := newcg.base;
               newcg := newcg.cg;
               pos := PositionsProperty(wh,x->x="P");
              #Print("this is new wh ",wh,"\n");
            od; 
         fi;
                     

        #Print(CartanType(corelg.CartanMatrixOfCanonicalGeneratingSet(L,newcg)),"\n");
        #Print("this is new wh",wh,"\n");

         tmp := testCFs(newcg);
         cft := tmp.cft;
         cfs := tmp.cfs;

        
         tmp := corelg.VoganDiagramOfRealForm(L,
                    rec( cg   := newcg, 
                         base := base, 
                         mv   := mv,
                         signs:= wh,  
                         cfsigma:=cfs,
                         cftheta:=cft));


         SetVoganDiagram(L,tmp);
         
         if Length(tmp!.param)=1 then
            mv := IdRealForm(L);
            SetRealFormParameters(L,RealFormParameters(RealFormById(mv)));
         fi;

         Info(InfoCorelg,2,"   end Vogan Diagram for simple LA");   

         tmp := VoganDiagram(L);
         tmp!.sstypes := [IdRealForm(L)];
         return tmp;
        

     ###########################################
     #here consider form of OUTER TYPE
     ###########################################
      else

        #find h0 to define new root ordering; take CSA compatible with h

         tmp := Intersection(cd.K,h);
         hs  := ShallowCopy( CanonicalGenerators(RootsystemOfCartanSubalgebra(cd.K,tmp))[3]);
         
         if not ForAll(hs,x->x in h) then Error("ups..CSA"); fi;

         found := false;
         es    := PositiveRootVectors(R);
         while not found do 
            h0 := Sum( hs, h -> Random([-100..100])*h );
            if ForAll( es, x -> not IsZero( h0*x ) ) then found:= true; fi;
         od;

        #find new basis of simple roots (def by root ordering induced by h0)
         vals := List( es, x -> Coefficients( Basis( SubspaceNC( L, [x],"basis" ), [x] ), h0*x )[1] );
         pr   := PositiveRootsNF(R);
         posr := [ ];
         for i in [1..Length(pr)] do
            if vals[i] > vals[i]*0 then Add( posr, pr[i] ); else Add( posr, -pr[i] ); fi; ###^0
         od;
         sums := [];
         for r in posr do for s in posr do Add( sums, r+s ); od; od;
         base := Filtered( posr, x -> not x in sums );
         B    := BilinearFormMatNF(R);
         C    := List( base, x -> List( base, y -> 2*(x*B*y)/(y*B*y) ) );
         ct   := CartanType(C);
         en   := Concatenation( CartanType(C).enumeration );
         base := base{en};
       
        #now construct corresponding canonical generators
         newcg := corelg.makeCanGenByBase(pr,cb,base);
         es    := newcg[1];
         fs    := newcg[2];

        #adjust D_4 so that root 3 and 4 are swapped
         if ct.types[1] = ["D",4] then
            wh   := where(cd,newcg);
           #Print("this is 1st wh ",wh,"\n");
            pos  := Filtered([1..4],x->wh[x]="?");
            tmp  := Filtered([1..4],x->not x in pos and not x=2)[1];
            tmp  := [tmp,2,pos[1],pos[2]];
            if not IsDuplicateFreeList(tmp) then Error("ups..."); fi;
            base := base{tmp};
            newcg := corelg.makeCanGenByBase(pr,cb,base);
            es    := newcg[1];
            fs    := newcg[2];
         fi;


         sps := List( es, x -> Subspace( L, [x],"basis" ) );
         mv  := [];
         for i in [1..Length(es)] do
            j := PositionProperty( sps, U -> theta( es[i] ) in U );
            if j > i then
               Add(mv,[i,j]);
               es[j]:= theta( es[i] );
               fs[j]:= theta( fs[i] );
            fi;
        od;
        Sort(mv);
        notmv := Filtered([1..rank],x->not x in Flat(mv));
        newcg := [es,fs,List( [1..Length(es)], i -> es[i]*fs[i] ) ];

    
        #for roots not moved by theta, determine whether root space 
        #lies in K or in P
         wh := where(cd,newcg);  
    
        #Print("out, this is first wh ",wh,"\n");

        #now consider the Weyl group action to adjust it; the first case is E_6
         if rank=6 and Size(Filtered(wh,x->not x="?"))=2 and not (wh[2]=1 and wh[4]=1) then
            if wh[2]="P" and wh[4]="K" then
               newcg := applyReflection(newcg,2,base);
               wh    := newcg.wh; 
               base  := newcg.base;
               newcg := newcg.cg;
             
            fi;
            if wh[2]="P" and wh[4]="P" then     
--> --------------------

--> maximum size reached

--> --------------------

[ zur Elbe Produktseite wechseln0.69Quellennavigators  Analyse erneut starten  ]