Gvm/0040700000175200004540000000000010062375000011120 5ustar brianfacultyGvm/Makefile0100600000175200004540000000023410062363437012571 0ustar brianfacultyFC = g77 FFLAGS = -C OBJ = main.o add.o bruhat.o cartan.o hasse.o klpolys.o output1.o output2.o \ wtfilt.o gvm: $(OBJ) g77 $(FFLAGS) $(OBJ) -o gvm Gvm/add.f0100600000175200004540000000325704241617211012032 0ustar brianfaculty subroutine add(a,b,c,da,db,dc,la,lb,lc,amax,qmax,err) c c Adds two polynomials, with non-zero coefficients given c in arrays a and b, and corresponding degrees given c in arrays da and db, in increasing order. Returns c coefficients of result in c, with corresponding degrees c in dc. Also returns number of non-zero coefficients of c a, b, and c in la, lb, lc. c Routine assumes that non-zero coefficients in a and b c all occur at the beginning, and that the remaining c entries of a and b are packed with 0's out to qmax. c integer amax, qmax, err, sum integer*2 a(amax),b(amax),c(amax),da(amax),db(amax),dc(amax) err=0 do 10 k=1,amax c(k)=0 10 continue i=1 j=1 k=1 20 if(a(i).eq.0) then 30 if(b(j).eq.0) goto 60 if(k.gt.qmax) goto 70 c(k)=b(j) dc(k)=db(j) k=k+1 j=j+1 goto 30 endif if(b(j).eq.0) then 50 if(a(i).eq.0) goto 60 if(k.gt.qmax) goto 70 c(k)=a(i) dc(k)=da(i) k=k+1 i=i+1 goto 50 endif if(da(i).lt.db(j)) then if(k.gt.qmax) goto 70 c(k)=a(i) dc(k)=da(i) k=k+1 i=i+1 else if (da(i).gt.db(j)) then if(k.gt.qmax) goto 70 c(k)=b(j) dc(k)=db(j) k=k+1 j=j+1 else sum=a(i)+b(j) if(sum.ne.0) then if(k.gt.qmax) goto 70 c(k)=sum dc(k)=da(i) k=k+1 endif i=i+1 j=j+1 endif goto 20 60 la=i-1 lb=j-1 lc=k-1 return 70 err=1 return end Gvm/bruhat.f0100600000175200004540000000377604245342530012600 0ustar brianfaculty subroutine bruhat(n,nmax,wmax,maxlen,maxdn,len,lend,tau, $ last,dn,err) c c Computes non-simple bruhat arrows in hasse diagram computed c by the subroutine hasse. c integer wmax,err,dni,r,s integer*2 len(wmax), tau(wmax,nmax), dn(wmax,maxdn),lend(maxlen) c c initialization section c do 20 i=1,wmax do 20 j=1,maxdn 20 dn(i,j)=0 c c now compute non-simple arrows c do 270 ix=lend(2)+1,last ndn=0 c number of new arrows down for this x so far s=1 190 ixs=tau(ix,s) if((ixs.gt.ix).or.(ixs.eq.-1))then s=s+1 if(s.gt.n) goto 280 c error! goto 190 endif do 260 iw=lend(len(ix)-1)+1,lend(len(ix)) c (previous level) iws=tau(iw,s) if((iws.lt.iw).and.(iws.gt.0)) then c s goes down from w c check that x and w are not related by a simple arrow c r=1 200 if(tau(iw,r).eq.ix) goto 260 if(r.lt.n) then r=r+1 goto 200 endif c c check whether xs and ws are related by any arrows (simple c or not); x and w are related iff xs and ws are (cf. BGG) c c first check simples c r=1 210 if(tau(ixs,r).eq.iws) goto 230 if (r.lt.n) then r=r+1 goto 210 endif c c now check other arrows down from xs c i=1 220 dni=dn(ixs,i) if (dni.ne.0) then if (dni.eq.iws) goto 230 i=i+1 goto 220 else c no arrow from xs to ws goto 260 endif c c add w to list of down arrows from x c 230 ndn=ndn+1 dn(ix,ndn)=iw i=1 endif 260 continue 270 continue return c c error - apparently no s goes down from x c 280 write(6,282) ix 282 format(" Error in bruhat - no simples down from ",i3) err=1 return end Gvm/cartan.f0100600000175200004540000000510504276424015012552 0ustar brianfaculty subroutine cartan(n,a,nmax,gtype) c c Prompts user for a type (A-H) and rank, then computes c the corresponding Cartan matrix in a. Uses indexing of c Humphreys' book (cf. pp. 58-59) (Hiller's book for type H) c Calling program should check for value of n=0, which c indicates subroutine cartan was unsuccessful--abort! c real a(nmax,nmax),m2alph character*1 gtype c c initialization c do 2 i=1,nmax do 2 j=1,nmax 2 a(i,j)=0 c c input section c 4 write(6,'(" Enter type of g (A-H): ",$)') read(5,'(a1)') gtype itype=ichar(gtype) if((itype.ge.65).and.(itype.le.72)) then itype=itype-64 else if((itype.ge.97).and.(itype.le.104)) then itype=itype-96 gtype=char(itype+64) else write(6,'("Invalid type - enter a character between A and H")') goto 4 endif 6 write(6,'(" Enter the rank (0 to abort run): ",$)') read(5,*) n if(n.eq.0) return if(n.gt.nmax) then write(6,'("Rank too high - current max is",i3)') nmax goto 6 endif c c generate matrix c goto (10,20,30,40,50,60,70,75) itype write(6,'("Error in cartan - itype not between 1 and 8")') n=0 return 8 write(6,'("Invalid rank for type",a2," - try again")') gtype goto 6 c type A 10 if(n.lt.1) goto 8 do 15 i=1,n-1 a(i,i+1)=-1 15 a(i+1,i)=-1 goto 80 c type B 20 if(n.lt.2) goto 8 do 25 i=1,n-2 a(i,i+1)=-1 25 a(i+1,i)=-1 a(n-1,n)=-2 a(n,n-1)=-1 goto 80 c type C 30 if(n.lt.2) goto 8 do 35 i=1,n-2 a(i,i+1)=-1 35 a(i+1,i)=-1 a(n-1,n)=-1 a(n,n-1)=-2 goto 80 c type D 40 if(n.lt.4) goto 8 do 45 i=1,n-2 a(i,i+1)=-1 45 a(i+1,i)=-1 a(n-2,n)=-1 a(n,n-2)=-1 goto 80 c type E 50 if((n.lt.6).or.(n.gt.8)) goto 8 do 55 i=3,n-1 a(i,i+1)=-1 55 a(i+1,i)=-1 a(1,3)=-1 a(3,1)=-1 a(2,4)=-1 a(4,2)=-1 goto 80 c type F 60 if(n.ne.4) goto 8 do 65 i=1,3 a(i,i+1)=-1 65 a(i+1,i)=-1 a(2,3)=-2 goto 80 c type G 70 if(n.ne.2) goto 8 a(1,2)=-1 a(2,1)=-3 goto 80 c type H - icosahedral 75 if((n.ne.3).and.(n.ne.4)) goto 8 m2alph=-0.5*(1.+sqrt(5.)) a(1,2)=m2alph a(2,1)=m2alph do 77 i=2,n-1 a(i,i+1)=-1 77 a(i+1,i)=-1 c now do diagonal elements (all types) 80 do 90 i=1,n 90 a(i,i)=2 return end Gvm/hasse.f0100600000175200004540000001021604276424015012404 0ustar brianfaculty subroutine hasse(n,a,nm,msimp,nmax,wmax,maxlen,len,lend,tau, $ cutoff,last,simple,roots,x,err,io) c c Computes the hasse diagram for the Lie algebra having Cartan c matrix a and parabolic subalgebra whose Levi factor's simple c roots are listed in msimp. Stores the length of each element c in len, its tau invariant information in tau, the total number c of elements in last, and the index of the last element of each c "level" (length) in lend. Only the simple root arrows are c determined; to compute all arrows, follow this subroutine with a c call to the subroutine bruhat. c Computes at most cutoff elements, to allow for partial diagrams. c (cutoff should be set to wmax+1 in main program for full c diagram) c integer wmax,err,r,s,cutoff integer*2 len(wmax),tau(wmax,nmax),lend(maxlen),msimp(nmax) real a(nmax,nmax),simple(nmax,nmax,nmax),roots(wmax,nmax,nmax), $ x(nmax,nmax),eps logical agree c c initialization section c eps=0.001 err=0 do 10 i=1,n do 10 j=1,n do 10 k=1,n 10 simple(i,j,k)=0 do 20 i=1,wmax do 20 j=1,n 20 tau(i,j)=0 do 30 i=1,n do 30 j=1,n simple(i,j,j)=1 30 simple(i,j,i)=simple(i,j,i)-a(j,i) len(1)=0 do 40 j=1,n 40 roots(1,j,j)=1 do 50 i=1,nm 50 tau(1,msimp(i))=-1 last=1 lend(1)=1 c lend(i) is the last index for level i (i.e. length i-1) nlevel=1 c number of levels (so far) l1=2 c first index of next level iw=1 c c main loop c 60 do 180 s=1,n if (tau(iw,s).eq.0) then c c s goes up from w c compute effect of x=ws on simples c (actually, the arrays x and roots give the effect of c the *inverse* of the corresponding element on the simples) c do 70 jx=1,n do 70 kx=1,n x(jx,kx)=0 do 70 k=1,n c (in fact not all k need to be checked) 70 x(jx,kx)=x(jx,kx)+roots(iw,jx,k)*simple(s,k,kx) c c look for x already on list c ix=l1 80 if (ix.gt.last) goto 110 agree=.true. do 90 jx=1,n do 90 kx=1,n if (abs(x(jx,kx)-roots(ix,jx,kx)).gt.eps) then agree=.false. goto 100 endif 90 continue 100 if (.not.agree) then ix=ix+1 goto 80 else goto 170 endif c c add x to list c 110 last=last+1 if(last.gt.wmax) goto 210 len(ix)=len(iw)+1 do 120 jx=1,n do 120 kx=1,n 120 roots(ix,jx,kx)=x(jx,kx) c c find simples not attached to x c these are the simple roots which occur as c x(some simple root in m). c do 160 i=1,nm j=msimp(i) c c decide whether x(j,*) is multiple of a simple, and if so, which c r=0 do 130 k=1,n if(abs(x(j,k)).gt.eps) then if(r.eq.0) then r=k else goto 140 endif endif 130 continue c here, x(j,*) is a multiple of simple root r tau(ix,r)=-1 140 continue 160 continue c c update tau info relating x, w, and s c 170 tau(iw,s)=ix tau(ix,s)=iw if(last.ge.cutoff) goto 185 endif 180 continue iw=iw+1 if (iw.lt.l1) goto 60 c c done all reflections up from current level c 185 if (last.ge.l1) then c something was generated on this level nlevel=nlevel+1 if(nlevel.gt.maxlen) goto 220 lend(nlevel)=last if(last.ge.cutoff) return l1=last+1 goto 60 endif return c c error section c 210 write(io,211) 211 format("Error in subroutine hasse") write(io,'("Overflow in array len (etc.) for wmax=",i4)') wmax err=1 return 220 write(io,211) write(io,'("Overflow in array lend for maxlen=",i4)') maxlen err=1 return end Gvm/klpolys.f0100600000175200004540000001036004206771173013001 0ustar brianfaculty subroutine klpolys(n,last,len,lend,tau,nmax,wmax,maxlen, $ pmax,p,mu,deg,err,io) c c Computes Kazhdan-Lusztig polynomials for the hasse diagram c computed by the subroutine hasse. Stores the results in c lower half of the matrix p. Also stores the "degree" of c p(y,w,*) (i.e. the largest k for which p(y,w,k).ne.0) in c deg(w,y,1), where deg and p are equivalenced in the main c program. c Uses the recursion relations of [Deodhar, J. Alg. 111 (1987), c 483-506]. c Note: For correct functioning, ptmax (below) must be set to c *at least* pmax + 1 (from main program). c integer ptmax parameter (ptmax=21) integer wmax,err,pmax,first,shift,s integer*2 len(wmax),lend(maxlen),tau(wmax,nmax),p(wmax,wmax,pmax), $ mu(wmax,wmax),deg(wmax,wmax,pmax) integer*2 ptild(ptmax) c c initialization section c if((pmax+1).gt.ptmax) goto 320 err=0 do 10 iw=1,last do 10 iy=1,last mu(iy,iw)=0 do 10 k=1,pmax 10 p(iy,iw,k)=0 p(1,1,1)=1 c c main loop c do 110 iw=2,last lw=len(iw) s=1 20 ix=tau(iw,s) if((ix.gt.iw).or.(ix.le.0))then s=s+1 if(s.gt.n) goto 280 c error! goto 20 endif p(iw,iw,1)=1 do 100 iy=lend(lw),1,-1 do 25 k=1,ptmax 25 ptild(k)=0 ly=len(iy) iys=tau(iy,s) if (iys.eq.-1) then ptild(1)=p(iy,ix,1) do 30 k=2,pmax 30 ptild(k)=p(iy,ix,k)+p(iy,ix,k-1) ptild(pmax+1)=p(iy,ix,pmax) else if (iys.lt.iy) then ptild(1)=p(iys,ix,1) do 40 k=2,pmax 40 ptild(k)=p(iys,ix,k)+p(iy,ix,k-1) ptild(pmax+1)=p(iy,ix,pmax) else ptild(1)=p(iy,ix,1) do 50 k=2,pmax 50 ptild(k)=p(iy,ix,k)+p(iys,ix,k-1) ptild(pmax+1)=p(iys,ix,pmax) endif if (ptild(1).eq.0) goto 100 do 80 lz=lw-2,ly,-2 shift=(lw-lz)/2 if (lz.eq.0) then first=1 else first=lend(lz)+1 endif do 70 iz=first,lend(lz+1) muzx=mu(iz,ix) if (muzx.eq.0) goto 70 if (tau(iz,s).gt.iz) goto 70 if (p(iy,iz,1).eq.0) goto 70 kmax=min0(pmax+shift,ptmax, $ 1+int(0.5*(lz-ly-1)+0.001)+shift) do 60 k=1+shift,kmax ptild(k)=ptild(k)-muzx*p(iy,iz,k-shift) 60 continue if(kmax.eq.ptmax) then c check for non-zero terms of p(y,z) beyond kmax-shift do 65 k=max0(1,kmax-shift+1),pmax if(p(iy,iz,k).ne.0) goto 310 65 continue endif 70 continue 80 continue if (ptild(pmax+1).ne.0) goto 290 c error! guess for pmax was too small do 85 k=pmax+2,ptmax if(ptild(k).ne.0) goto 300 85 continue kmax=0 do 90 k=1,pmax if(ptild(k).ne.0) kmax=k p(iy,iw,k)=ptild(k) 90 continue deg(iw,iy,1)=kmax mudeg= 1+int(0.5*(lw-ly-1)+0.001) if(mudeg.le.pmax) then if (mod(lw-ly,2).eq.1) mu(iy,iw)=p(iy,iw,mudeg) if(mu(iy,iw).gt.1) write(io,'("Big mu ! ",2i4,4x,i3)') $ iw,iy,mu(iy,iw) endif 100 continue 110 continue return c c error section c 280 write(io,282) iw 282 format(" Error in klpolys - no simples down from ",i3) return 290 write(io,'(" Error in klpolys - size of p matrix too small")') write(io,292) iw,iy,pmax 292 format("for w=",i4,", y=",i4,", pmax=",i3) err=1 return 300 write(io,'(" Error in klpolys - non-zero coefficient in ptild")') write(io,'("found beyond pmax+1. In particular, pmax too small")') write(io,292) iw,iy,pmax err=1 return 310 write(io,'(" Error in klpolys - size of ptild too small")') write(io,'("for w=",i4,", y=",i4,", z=",i4,", ptild=",i3)') iw, $ iy,iz err=1 return 320 write(io,'(" Error in klpolys - ptild must be at least equal")') write(io,'("to pmax+1")') err=1 return end Gvm/output1.f0100600000175200004540000000777310062365334012736 0ustar brianfaculty subroutine output1(outopt,n,gtype,mtype,outfile,last,len,tau, $ dn,mu,p,deg,cutoff,nmax,wmax,maxdn,pmax,io) c c writes to the file outfile (unit 1) the following information: c a heading consisting of the type of g and the type of p; c the number of elements generated in the poset W^S; c the indexing, lengths, and tau invariant information for the c elements in the poset; c the "non-simple" Bruhat relations; c the non-zero mu(y,w) values; c the non-zero non-one Kazhdan-Lusztig polynomials, in Goresky's c "non-redundant" format (explained below) c parameter (maxprint=50) integer outopt,wmax,pmax,cutoff integer*2 len(wmax),tau(wmax,nmax),dn(wmax,maxdn),mu(wmax,wmax), $ p(wmax,wmax,pmax),deg(wmax,wmax,pmax) integer*2 yprt(maxprint) character* (*) gtype,mtype,outfile write(1,992) gtype,n,mtype 992 format(" (",a1,i1,",",a5,")") write(1,994) last 994 format(/," Cardinality of W^S = ",i4," ",$) if(last.eq.cutoff) then write(1,'("(partial diagram)")') else write(1,'(/)') endif c c output hasse diagram c if(mod(outopt,2).eq.0) then write(1,'(/," Index Length Simple Root Arrows" $ ,$)') nofull=mod(outopt,3) if(nofull.eq.0) then write(1,'(6x,"Others Down")') else write(1,'(" ")') endif write(1,'(/,15x,8i4)') (j, j=1,n) do 820 i=1,last write(1,801) i, len(i) do 790 j=1,n write(1,803) tau(i,j) 790 continue write(1,'(8x," ",$)') if (nofull.eq.0) then do 800 j=1,maxdn if (dn(i,j).eq.0) goto 820 write(1,803) dn(i,j) 800 continue endif 820 continue write(1,'(/)') endif 801 format(/,i4,3x,i4,3x,' ',$) 803 format(i4,$) 804 format(' ',$) c c output mu values c c (checking for mu(y,w) > 1 is now done in klpolys) c if(mod(outopt,7).eq.0) then write(1,'(/,"Non-zero mu values")') write(1,'(/," w y mu(y,w)",/)') do 150 iw=4,last lwm3=len(iw)-3 do 140 iy=1,iw if(len(iy).gt.lwm3) goto 150 if(mu(iy,iw).ne.0) write(1,'(2i4,4x,i3)') iw,iy,mu(iy,iw) 140 continue 150 continue endif c c output K-L polys c if(mod(outopt,11).eq.0) then write(1,'(/,"Kazhdan-Lusztig Polynomials")') write(1,'(" (where a b c ... represents a + bu + cu^2 + ...)" $ )') write(1,'(/," w y",6x,"KL polynomial",/)') do 250 iw=1,last nprint=0 do 240 iy=iw-1,1,-1 c only print polynomials which are not identically 1 or 0 kmax=deg(iw,iy,1) if(kmax.le.1) goto 240 c follow Goresky's convention of only printing "highest" c occurance of each singularity of w; so if y does not appear, c P(y,w) is equal to P(z,w) where z is the lowest entry on the c list such that y < z in the Bruhat order j=nprint 210 if(j.eq.0) goto 230 iz=yprt(j) if(p(iy,iz,1).eq.0) then j=j-1 goto 210 endif c at this point, z is the most recently printed element with y < z c check that p(y,w)=p(z,w)--if not, print p(y,w) if(kmax.ne.deg(iw,iz,1)) goto 230 do 220 k=1,kmax if(p(iy,iw,k).ne.p(iz,iw,k)) goto 230 220 continue goto 240 c print y, p(y,w) 230 if(nprint.eq.0) write(1,'(i4)') iw write(1,'(4x,i4,3x,25i3)') iy, (p(iy,iw,k),k=1,kmax) nprint=nprint+1 if(nprint.gt.maxprint) goto 300 yprt(nprint)=iy 240 continue 250 continue endif return c c error section c 300 write(io,'("Error in subroutine output1")') write(io,'("Dimension of array yprt is too small for")') write(io,'(" w=",i4,", y=",i4,", maxprint=",i3)') iw,iy,maxprint return end Gvm/output2.f0100600000175200004540000000632710062365507012733 0ustar brianfaculty subroutine output2(outopt,n,last,len,tau,mu,q,deg,nmax,wmax, $ qmax,levct,level,maxlev,maxct,lend,maxlen,less,io) c c appends to the file outfile (unit 1) the following information: c the non-zero weight filtration polynomials; c the weight filtrations of the relative Verma modules c integer outopt,wmax,qmax,botlyr,err integer*2 len(wmax),tau(wmax,nmax),mu(wmax,wmax), $ q(wmax,wmax,qmax),deg(wmax,wmax,qmax),less(wmax,wmax), $ level(maxlev,maxct),levct(maxlev),lend(maxlen) c c level(i,.) contains the composition factors in the i'th level c of the current w. levct(i) is the number of composition factors c in the i'th level. c err=0 c c output weight polynomials c if(mod(outopt,13).eq.0) then write(1,'(/,"Weight Polynomials")') write(1,'(" (where c^i stands for cu^i)")') write(1,'(/," w y",6x,"Weight polynomial",/)') do 270 iw=1,last write(1,'(i4)') iw do 260 iy=1,iw c only print non-zero poly's if(q(iy,iw,1).eq.0) goto 260 write(1,'(4x,i4,"",$)') iy do 250 k=1,qmax if(q(iy,iw,k).eq.0) goto 255 write(1,'(3x,i3,"^",$)') q(iy,iw,k) write(1,'(i2,$)') deg(iw,iy,k)-1 250 continue 255 write(1,'(" ")') 260 continue 270 continue endif c c output weight filtrations of gvm's c if(mod(outopt,17).eq.0) then write(1,'(/,"Weight Filtrations")') do 360 iw=1,last do 310 lev=1,maxlev levct(lev)=0 310 continue botlyr=1 lw=len(iw) write(1,'(" ")') do 340 iy=iw,1,-1 ly=len(iy) c flag multiplicities greater than 1 c f77 may need iabs instead of abs in next line if((abs(q(iy,iw,1)).gt.1).or.(q(iy,iw,2).ne.0)) then write(1,'("mult(",i4,",",i4,") > 1")') iy, iw c "un-comment" the line below if you want multiplicities > 1 c to be flagged on the terminal screen (as well as in file) c write(6,'("mult(",i4,",",i4,") > 1")') iy, iw endif do 330 k=1,qmax if(q(iy,iw,k).eq.0) goto 340 lev=lw-ly-2*(deg(iw,iy,k)-1)+1 if(lev.gt.maxlev) goto 510 if(lev.gt.botlyr) botlyr=lev c f77 may need iabs instead of abs in next line do 320 j=1,abs(q(iy,iw,k)) levct(lev)=levct(lev)+1 if(levct(lev).gt.maxct) goto 520 level(lev,levct(lev))=iy 320 continue 330 continue 340 continue do 355 lev=1,botlyr write(1,'(19i4,100(/,2x,18i4))') (level(lev,j), $ j=1,levct(lev)) 355 continue 360 continue endif return c c error section c 510 write(io,511) 511 format("Error in subroutine output2") write(io,'("Maximum # of weight filtration levels exceeded")') write(io,'("for w=",i3," maxlev=",i3)') iw,maxlev goto 999 520 write(io,511) write(io,'("Maximum number of composition factors per level")') write(io,'("exceeded for w=",i3," maxct=",i3)') iw,maxct 999 return end Gvm/wtfilt.f0100600000175200004540000001207704245343231012615 0ustar brianfaculty subroutine wtfilt(n,last,len,lend,tau,nmax,wmax,maxlev,mu, $ q,deg,qmax,err,io) c c Computes weight filtration polynomials for relative Verma c modules in hasse diagram computed by subroutine hasse; c returns polynomials in array q. c By definition, the matrix of weight polynomials is the inverse c of the matrix of Kazhdan-Lusztig polynomials. However, an c alternate algorithm is used here, based on results in [Casian- c Collingwood, Math. Z. 195 (1987), 581-600] and [Lusztig-Vogan, c Inv. Math. 71 (1983), 365-379]. It uses only the Bruhat order c (contained in the constant terms of the KL polys) and the c mu(y,w)'s. Write V(w) = \sum_{y \le w} Q_{y,w}(u) L(y) in c the Hecke module. Find s such that w > ws in W^S. Then c V(w) = (T_s + 1) V(ws) - V(ws), with V(ws) known by induction c (start from V(e) = L(e) ). And (T_s + 1) L(y) is equal c to (u + 1) L(y) if s is in tau(L(y)), otherwise it equals c L(ys) + \sum mu(z,y) u^{(l(y)-l(z)+1)/2} L(z), where the sum c is over all z with z < y and s in tau(L(z)). c c Note that to save space, the arrays q and deg are assumed to c be the same (via an equivalence statement in the main program). c The degree (+1) of the term whose coefficient is q(iy,iw,k) c is stored in deg(iw,iy,k). (On the diagonal, the weight c polynomial q(w,w) is identically 1, so q(iw,iw,1)=deg(iw,iw,1)=1.) c integer qmax,wmax,amax,err,s,shift,first parameter (amax=20) integer*2 len(wmax),tau(wmax,nmax),mu(wmax,wmax), $ q(wmax,wmax,qmax),deg(wmax,wmax,qmax),lend(maxlev) integer*2 a(amax),b(amax),c(amax),da(amax),db(amax),dc(amax) c c initialization c err=0 do 10 iw=1,last do 10 iy=1,last do 10 k=1,qmax 10 q(iy,iw,k)=0 c Note that q and deg are actually the same matrix, so there's c no need to zero deg as well. q(1,1,1)=1 c c main loop c do 190 iw=2,last s=1 20 ix=tau(iw,s) if((ix.gt.iw).or.(ix.le.0))then s=s+1 if(s.gt.n) goto 300 c error! goto 20 endif do 180 iy=ix,1,-1 if(q(iy,ix,1).eq.0) goto 180 ly=len(iy) iys=tau(iy,s) if(iys.lt.iy) then c c Q(y,w)=Q(y,w)+u*Q(y,x) do 30 k=1,qmax a(k)=q(iy,iw,k) da(k)=deg(iw,iy,k) b(k)=q(iy,ix,k) 30 db(k)=deg(ix,iy,k)+1 call add(a,b,c,da,db,dc,la,lb,lc,amax,qmax,err) if(err.eq.1) goto 400 do 40 k=1,lc q(iy,iw,k)=c(k) 40 deg(iw,iy,k)=dc(k) do 50 k=lc+1,la q(iy,iw,k)=0 50 deg(iw,iy,k)=0 else c c Q(y,w)=Q(y,w)-Q(y,x) do 60 k=1,qmax a(k)=q(iy,iw,k) da(k)=deg(iw,iy,k) b(k)=-q(iy,ix,k) 60 db(k)=deg(ix,iy,k) call add(a,b,c,da,db,dc,la,lb,lc,amax,qmax,err) if(err.eq.1) goto 400 do 70 k=1,lc q(iy,iw,k)=c(k) 70 deg(iw,iy,k)=dc(k) do 80 k=lc+1,la q(iy,iw,k)=0 80 deg(iw,iy,k)=0 c c Q(ys,w)=Q(ys,w)+Q(y,x) do 90 k=1,qmax a(k)=q(iys,iw,k) da(k)=deg(iw,iys,k) b(k)=q(iy,ix,k) 90 db(k)=deg(ix,iy,k) call add(a,b,c,da,db,dc,la,lb,lc,amax,qmax,err) if(err.eq.1) goto 400 do 100 k=1,lc q(iys,iw,k)=c(k) 100 deg(iw,iys,k)=dc(k) do 110 k=lc+1,la q(iys,iw,k)=0 110 deg(iw,iys,k)=0 c c recursion terms c do 170 lz=ly-1,0,-2 shift=(ly-lz+1)/2 if(lz.eq.0) then first=1 else first=lend(lz)+1 endif do 160 iz=first,lend(lz+1) muzy=mu(iz,iy) if(muzy.eq.0) goto 160 if(tau(iz,s).gt.iz) goto 160 c c Q(z,w)=Q(z,w)+mu(z,y)*u^(shift)*Q(y,x) do 120 k=1,qmax a(k)=q(iz,iw,k) da(k)=deg(iw,iz,k) b(k)=muzy*q(iy,ix,k) 120 db(k)=deg(ix,iy,k)+shift call add(a,b,c,da,db,dc,la,lb,lc,amax,qmax,err) if(err.eq.1) goto 500 do 130 k=1,lc q(iz,iw,k)=c(k) 130 deg(iw,iz,k)=dc(k) do 140 k=lc+1,la q(iz,iw,k)=0 140 deg(iw,iz,k)=0 160 continue 170 continue endif 180 continue 190 continue return c c error section c 300 write(io,310) 310 format("Error in subroutine wtfilt") write(io,'("No simples down from w=",i3)') iw err=2 return 400 write(io,310) write(io,410) 410 format("Array q is dimensioned too small") write(io,'("w=",i3," y=",i3," qmax=",i3)') iw,iy,qmax return 500 write(io,310) write(io,410) write(io,'("w=",i3," y=",i3," z=",i3," qmax=",i3)') iw,iy,iz,qmax return end Gvm/main.f0100600000175200004540000003353610062374772012243 0ustar brianfaculty program gvm c----------------------------------------------------------------------- c c Copyright Brian D. Boe 1987, 1988. c c May be modified, provided the copyright information is c preserved intact. Modified versions may not be redistributed c without clearly indicating where and by whom changes have c been made. c c Uses Fortran77 (f77 or g77) -- edit Makefile accordingly. c Compile by typing "make gvm" (without the quotes). c c Program to compute weight filtrations of relative Verma modules c in any regular block O(g,p,reg). Also computes Kazhdan-Lusztig c polynomials associated to the block, and related data. c c----------------------------------------------------------------------- c c INPUT c c The input is interactive, via the terminal, and is for the most c part self-explanatory. c c type of g: Classification type of the simple Lie algebra g (A-G), c or, more generally, of a finite Coxeter group W of c type A-H c rank: (Complex) rank of g (or W); entering 0 at this point c terminates the program c type of Levi factor: Classification type of the Levi factor of a c parabolic subalgebra p (or again, more generally, a c parabolic subgroup of W); character string used only c in output heading c rank of Levi factor: (Complex) rank of p (or the parabolic c subgroup) c simple roots in Levi factor: Enter the indices of the simple c roots defining the parabolic, separated by spaces and c terminated by a . Use the indexing of c Humphreys' book for the crystallographic case, and c Hiller's book for the non-crystallographic case. c size of partial diagram: c If one is simply looking for a multiplicity in some c relative Verma module, one can compute the first N c columns of the matrix of KL polynomials, and use c elementary row operations to obtain the first N c columns of the inverse matrix. Enter such an N c here. To work with the full matrix (the usual c situation), enter 0 here. c output file: Character string denoting the file where the c program output will be written c device for diagnostics: Descriptive information concerning c progress of the run, error messages, etc., can c be directed either to the output file (enter 1) c or to the terminal screen (enter 6) c c----------------------------------------------------------------------- c c OUTPUT c c For each option presented, enter Y (or y) to have the c corresponding information output, otherwise N (or n). c c Hasse diagram and tau info: c The elements of W^S are enumerated c beginning at 1 for the identity element. c A row of data is provided for c each element w, beginning with its length. Then c for each simple reflection s, an entry of -1 if c ws is not in W^S, otherwise the index of the element c ws is given. c Full Bruhat order: c The above information determines the "strong Bruhat c order," given by *simple* reflections (on the right). c If this option is selected, then the following c additional information will be reported in the above c table: all x in W^S such that x < w, l(x) = l(w)-1, c but x is not of the form ws for some simple s. c Non-zero mu(y,w)'s: c Recall that mu(y,w) is the coefficient of c u^{(l(w)-l(y)-1)/2} in P_{y,w} c Non-zero non-one KL polys: c The Kazhdan-Lusztig polynomials are printed in the c form a b c ..., which denotes a + bu + cu^2 + ... c Recall that P_{y,w} = 0 iff y is not less than or c equal to w in the full Bruhat order. The non-zero c non-one polynomials are printed following Goresky's c scheme: if y < w but y does not appear in the list, c then P_{y,w} = P_{z,w} where z is the lowest entry c on the list such that y < z in the Bruhat order. c Non-zero weight filtration polynomials: c These polynomials are the entries of the inverse c of the matrix of KL polynomials. Only the non-zero c ones are given. Because these typically have only c one or two non-zero terms, they are written different- c ly from the KL polynomials. The notation a^i b^j ... c stands for au^i + bu^j + ... c Weight filtrations: c The actual weight filtrations of the relative Verma c modules are listed. The irreducibles are indexed as c described under "Hasse diagram..." above. Each row c represents a semisimple subquotient of successive c modules in the weight filtration. c c----------------------------------------------------------------------- c c DESCRIPTION OF "GLOBAL" VARIABLES c c General conventions: c If w is an element of W^M, then iw denotes the c index of W, as described under "Hasse diagram..." c above. c r, s, t denote simple reflections c c a(,): the Cartan matrix of g, following the indexing of c Humphreys' book (Hiller's book for the non- c crystallographic cases) c cutoff: the last element to generate if only partial diagram c is needed; otherwise set to wmax + 1 c deg(,,): during subroutine klpolys and before subroutine c wtfilt, deg(iw,iy,1) is the degree + 1 of the KL c polynomial P_{y,w}; during and after wtfilt, c deg(iw,iy,j) is one more than the degree of the term c whose coefficient is contained in q(iy,iw,j); note c that p, q, and deg are equivalenced matrices: c p and q use the upper half, while deg uses the lower c half c dn(,): dn(iw,*) is the vector of elements immediately c below w in the full Bruhat order but not in the c strong Bruhat order c err: if non-zero on return from a subroutine, indicates c an error occurred in the subroutine c gtype: classification type of g (A-H) c io: device number (1 or 6) for diagnostics c last: index of the longest element of W^S c len(): len(iw) is the length of w c lend(): lend(j) is the index of the last element in row j c (i.e. length j-1) of the Hasse diagram c less(,): less(iy,iw)=1 if y < w in the full Bruhat order; c otherwise 0 c levct(): levct(i) is the number of composition factors (so c far) in level i of the weight filtration of w; see c "level" below c level(,): level(i,*) contains the indices of the irreducible c composition factors in level i (counting from 1 at c the top) of the weight filtration of the current w c maxct: maximum number of irreducibles (counting multipli- c cities) in a single level of a weight filtration c maxdn: maximum number of elements immediately below an c element in the full Bruhat order but not in the c strong Bruhat order c maxlen: maximum number of "levels" in the Hasse diagram c maxlev: maximum number of levels in a weight filtration c msimp(): vector of the simple roots in p c mtype: classification type of the semisimple part of p c mu(,): mu(iy,iw) = mu(y,w) (see output section above) c n: rank of g c nm: rank of the parabolic c nmax: maximum value of n c outfile: name of output file c outopt: integer whose prime factors determine the output c options selected c p(,,): matrix of KL polynomials: p(iy,iw,j) is the c coefficient of u^{j-1} in P_{y,w} c pmax: maximum degree + 1 of any KL polynomial; sometimes c called qmax c q(,,): matrix of weight polynomials: q(iy,iw,j) is the j-th c non-zero coefficient of the weight polynomial c associated to the pair (y,w); the degree (+1) of this c term is contained in deg(iw,iy,j); notice that the c matrices p, q, and deg share the same storage c locations in memory c qmax: same as pmax c roots(,,): roots(iw,j,k) is the coefficient of alpha_k in c (w^{-1})(alpha_j) c simple(,,): simple(i,j,k) is the coefficient of alpha_k in c (s_i)(alpha_j) c tau(,): tau(iw,s) is -1 if ws is not in W^S, otherwise it is c the index of ws c wmax: maximum size of W^S c x(,): x(j,k) is the coefficient of alpha_k in c (x^{-1})(alpha_j), where x is the element of W^S c currently being generated integer wmax, pmax, outopt, err, wt, cutoff parameter (nmax=8,wmax=300,maxlen=58,maxdn=5,pmax=20, $ maxlev=24,maxct=100) c c Warning: if pmax is changed, also check ptmax in sub. klpolys c and amax in sub. wtfilt; note that ptmax must be at least pmax+1. c integer*2 len(wmax),tau(wmax,nmax),msimp(nmax), $ dn(wmax,maxdn),p(wmax,wmax,pmax),lend(maxlen),level(maxlev, $ maxct),mu(wmax,wmax),q(wmax,wmax,pmax),deg(wmax,wmax,pmax), $ levct(maxlev),less(wmax,wmax) real a(nmax,nmax),simple(nmax,nmax,nmax),roots(wmax,nmax,nmax), $ x(nmax,nmax) equivalence (p,q,deg) character outfile*10, mtype*5, gtype*1, resp*1 write(6,'("Program gvm. Copyright Brian D. Boe 1987, 1988")') write(6,'("Please send an e-mail to brian at math.uga.edu", $ " if you use this program.")') c c input section c call cartan(n,a,nmax,gtype) if(n.eq.0) then write(6,'("No Cartan matrix generated - run aborted")') goto 999 endif write(6,'(" Enter type of levi factor (for output heading): "$)') read(5,'(a5)') mtype write(6,'(" Enter rank of levi factor: ",$)') read(5,*) nm if (nm.gt.0) then write(6,'(" Enter simple roots in levi factor, separated by", $ " spaces:")') read(5,*) (msimp(i), i=1,nm) endif write(6,'(" Enter size of ''partial diagram'' (0 for all ", $ "elts; current max =",i4,"): ",$)') wmax read(5,*) cutoff if((cutoff.le.0).or.(cutoff.gt.wmax)) cutoff=wmax+1 write(6,'(" Enter name of output file: ",$)') read(5,'(a10)') outfile write(6,'(" Enter device for diagnostics (1=file,6=screen): "$)') read(5,*) io outopt=1 kl=0 wt=0 write(6,'(" Choose desired output options by responding Y or N." $ )') write(6,'(" 1. Hasse diagram and tau info? ",$)') read(5,'(a1)')resp if((resp.eq.'y').or.(resp.eq.'Y')) outopt=2 write(6,'(" 2. Full Bruhat order? ",$)') read(5,'(a1)')resp if((resp.eq.'y').or.(resp.eq.'Y')) outopt=6 write(6,'(" 3. Non-zero mu(y,w)''s? ",$)') read(5,'(a1)')resp if((resp.eq.'y').or.(resp.eq.'Y')) then outopt=outopt*7 kl=1 endif write(6,'(" 4. Non-zero non-one K-L polys? ",$)') read(5,'(a1)')resp if((resp.eq.'y').or.(resp.eq.'Y')) then outopt=outopt*11 kl=1 endif write(6,'(" 5. Non-zero weight filtration polys? ",$)') read(5,'(a1)')resp if((resp.eq.'y').or.(resp.eq.'Y')) then outopt=outopt*13 kl=1 wt=1 endif write(6,'(" 6. Weight filtrations of gen. Verma modules? ",$)') read(5,'(a1)')resp if((resp.eq.'y').or.(resp.eq.'Y')) then outopt=outopt*17 kl=1 wt=1 endif c c subroutine calls c open(1,file=outfile) rewind 1 call hasse(n,a,nm,msimp,nmax,wmax,maxlen,len,lend,tau, $ cutoff,last,simple,roots,x,err,io) if(err.ne.0) goto 999 write(io,'("Subroutine hasse complete")') if(mod(outopt,3).eq.0) then call bruhat(n,nmax,wmax,maxlen,maxdn,len,lend,tau, $ last,dn,err) if(err.ne.0) goto 999 write(io,'("Subroutine bruhat complete")') endif if(kl.eq.1) then call klpolys(n,last,len,lend,tau,nmax,wmax,maxlen,pmax,p, $ mu,deg,err,io) if(err.ne.0) goto 999 write(io,'("Subroutine klpolys complete")') endif call output1(outopt,n,gtype,mtype,outfile,last,len,tau, $ dn,mu,p,deg,cutoff,nmax,wmax,maxdn,pmax,io) write(io,'("Subroutine output1 complete")') if(wt.eq.1) then c first, save full bruhat order in array "less" c beware that the upper half of p( , ,1) now contains degree c information, so must be zeroed do 120 iw=1,last do 110 iy=1,iw less(iy,iw)=p(iy,iw,1) 110 continue do 115 iy=iw+1,last less(iy,iw)=0 115 continue 120 continue call wtfilt(n,last,len,lend,tau,nmax,wmax,maxlen,mu,q, $ deg,pmax,err,io) if(err.ne.0) goto 999 write(io,'("Subroutine wtfilt complete")') endif call output2(outopt,n,last,len,tau,mu,q,deg,nmax,wmax, $ pmax,levct,level,maxlev,maxct,lend,maxlen,less,io) write(io,'("Subroutine output2 complete")') 999 close (1) end Gvm/README0100600000175200004540000000033210062374667012017 0ustar brianfacultyProgram gvm by Brian D. Boe. I would appreciate your sending an e-mail to "brian at math.uga.edu" if you use this program, telling me your name and affiliation, for my records. See the file main.f for instructions.