C C----------------------------------------------------------------------------- c c P I C H A M - PICkett HAMiltonian: reformatting of .EGY output from C SPCAT produced with EGYFLG=5 option which dumps C the Hamiltonian with no diagonalization C c C ver. 24.V.2018 ----- Zbigniew KISIEL ----- C C----------------------------------------------------------------------------- C C PICHAM output is in two forms: C C 1/ standard numerical square array output for H sizes C up to (MAXCOL x MAXCOL) C C 2/ compressed graphical output for H sizes above C (MAXCOL x MAXCOL) and up to (MAXDIM x MAXDIM) C C C __________________________________________________ C | Institute of Physics, Polish Academy of Sciences | C | Al.Lotnikow 32/46, 02-668 Warszawa, POLAND | C | kisiel@ifpan.edu.pl | C | http://info.ifpan.edu.pl/~kisiel/prospe.htm | C_________________________/-------------------------------------------------- c c C Modification history: C c 28.12.07: creation c 24.05.18: graphical output for arrays larger than MAXCOL x MAXCOL c C----------------------------------------------------------------------------- c implicit real*8(a-h,o-z) parameter (maxdim=500,maxcol=20) parameter (hlev1=0.00001d0,hlev2=0.0001d0,hlev3=0.001d0) c character*150 line,filinp,filin,filout,filvar character*12 qns(maxdim),qnout(maxdim) character*500 veclin real*8 h(maxdim,maxdim),hmax c WRITE(*,3344) 3344 FORMAT(1X//' ',76(1H_)/' |',T79,'|'/ * ' | PICHAM - PICkett HAMiltonian: reformatting of .EGY output', * ' from',T79,'|'/ * ' | SPCAT produced with EGYFLG=5 option, which dumps', * T79,'|'/ * ' | the Hamiltonian with no diagonalization',T79,'|'/ * ' |',76(1H_),'|'/' version 24.V.2018',T64,'Zbigniew KISIEL'/) c c...open .EGY file c 2 write(*,1)' Name of input .EGY file (without extension):' 1 format(1x//1x,a,' ',$) read(*,'(a)',err=2)filin do 100 n=30,1,-1 if(filin(n:n).ne.' '.and.ichar(filin(n:n)).ne.0)then filinp=filin(1:n)//'.egy' filout=filin(1:n)//'.ham' filvar=filin(1:n)//'.var' goto 101 endif 100 continue 101 write(*,'(1x/'' R E A D I N G: '',a)')filinp open(3,file=filinp,status='OLD',err=2) c open(4,file=filout,status='unknown',err=6) c c...echo the constants in .VAR c open(2,file=filvar,status='OLD',err=20) c 21 read(2,'(a)',err=22,end=22)line if(line(3:3).eq.'.'.and.line(13:13).eq.'.')goto 22 write(4,'(a)')line(1:len_trim(line)) OUTPUT .var goto 21 c 22 close(2) write(4,'(1x)') c c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...Main loop for dealing with a Hamiltonian block c c 5 2 2.798493 0.000000 0.000000 5: 2 2 0 c 2 8.38967E+004 3 0.00000E+000 4 0.00000E+000 5 0.00000E+000 6 -3.17983E+003 7 -1.76288E-002 c 8 0.00000E+000 c c NQNS - number of quantum numbers (established on the first eigenvalue line) c NVECT - current number of vectors in the current block c LASTBL - number of currently read Hamiltonian block c c lastbl=1 nvect=0 nqns=0 c numblk=0 igrblk=0 c c...read eigenvalue line c 3 read(3,'(a)',end=5,err=7)line c c...is this block header? c read(line,'(i6,i5)')nbl,neval c c...write out the previously completed Hamiltonian block c if(nbl.ne.lastbl)then c c__simplified diagrammatic output for large matrices above (MAXCOL x MAXCOL) c if(nvect.gt.maxdim)goto 9 if(nvect.gt.maxcol)then igrblk=igrblk+1 c hmax=0.d0 do 33 n=1,nvect do 33 nn=1,nvect if(dabs(h(n,nn)).gt.hmax)hmax=dabs(h(n,nn)) 33 continue c write(4,40)lastbl,nvect,nvect,' MaxH(i,j) =',hmax, OUTPUT block header * 0.0d0, 0.0d0,hlev1, hlev1,hlev2, and legend * hlev2,hlev3, * hlev3 40 format(/80(1H-)/' Block number:',i3,3x, * '(',i4,' x',i4,')',a,f15.2, * 5x,'space = ' ,f8.5,11x,' * maxH'/ * 65x,' . = >' ,F8.5,' to',f8.5,' * maxH'/ * 65x,' , = >' ,F8.5,' to',f8.5,' * maxH'/ * 65x,' o = >' ,F8.5,' to',f8.5,' * maxH'/ * 65x,' X = >' ,F8.5,11x,' * maxH'/) c veclin=' ' write(veclin,39)(nn*10,nn=1,nvect/10) 39 format(100i10) veclin(1:1)='1' write(4,38)veclin(1:nvect) c do 37 n=1,nvect veclin(n:n)='_' if((n/10)*10.eq.n)veclin(n:n)='|' 37 continue write(4,38)veclin(1:nvect) 38 format(18x,a) c do 34 n=1,nvect do 34 nn=1,nvect h(n,nn)=dabs(h(n,nn))/hmax 34 continue c do 31 n=1,nvect do 32 nn=1,nvect veclin(nn:nn)=' ' if(n.eq.nn)veclin(nn:nn)='\' if(H(n,nn).gt.0.d0 .and.H(n,nn).lt.hlev1 ) to 0.00001 * veclin(nn:nn)='.' if(H(n,nn).ge.hlev1 .and.H(n,nn).lt.hlev2 ) to 0.0001 * veclin(nn:nn)=',' if(H(n,nn).ge.hlev2 .and.H(n,nn).lt.hlev3 ) to 0.001 * veclin(nn:nn)='o' if(H(n,nn).ge.hlev3 )veclin(nn:nn)='X' above 0.001 32 continue if((n/10)*10.eq.n)then write(4,30)n,qns(n),'-',veclin(1:nvect) OUTPUT vector else write(4,30)n,qns(n),'|',veclin(1:nvect) OUTPUT vector endif 31 continue c goto 19 endif 30 format(i3,':',a,1x,2a) c c___standard numerical output with unbroken arrays up to (MAXCOL x MAXCOL) size c write(4,'(80(1H-)/'' Block number:'',i3/)')lastbl OUTPUT block header numblk=numblk+1 c nlast=len_trim(qns(1)) nfirst=12-nlast+1 do 18 n=1,nvect qnout(n)='' qnout(n)(nfirst:12)=qns(n)(1:nlast) 18 continue write(4,'(12x,20(a12))')(qnout(n),n=1,nvect) write(4,'(1x)') c do 15 n=1,nvect write(4,'(a,20f12.3)')qns(n),(h(n,nn),nn=1,nvect) OUTPUT vector 15 continue write(4,'(1x)') nprint=lastbl c 19 do 17 n=1,maxdim do 17 nn=1,maxdim h(n,nn)=0.d0 17 continue c lastbl=nbl backspace(3) nvect=0 goto 3 endif c c...determine the number of quantum numbers (if not yet done so) c if(nqns.eq.0)then nqns=(len_trim(line)-64)/3 write(*,'(i3,'' quantum numbers''/)')nqns endif c c...process the quantum number field c nvect=nvect+1 if(nvect.gt.maxdim-1)goto 36 c qns(nvect)='' nst=65 do 110 n=1,2*nqns,2 qns(nvect)(n:n+1)=line(nst+1:nst+2) nst=nst+3 110 continue c write(*,'('' Block:'',i3,'' Eigenvalue:'',i3, * '' Vector_vals:'',$)')lastbl,neval c c...read an eigenvector line c nelmax=0 c 10 read(3,'(a)',end=16,err=16)line 14 nterms=(len_trim(line)-8)/20 write(*,'(1h+,i3,$)')nterms c nst=8 do 11 n=1,nterms read(line(nst+1:nst+6),'(i6)')nel if(nel.gt.nelmax)nelmax=nel nst=nst+6 read(line(nst+1:nst+14),'(e14.5)')hval h(nel,nvect)=hval h(nvect,nel)=hval if(nel.gt.maxdim-1)goto 36 c if((nel/140)*140.eq.nel)write(*,'(1x)') nst=nst+14 11 continue c c...check for a continuation line c if(nterms.eq.6)then read(3,'(a)',end=16,err=16)line if(line(6:6).eq.' ')then goto 14 else backspace(3) endif endif c goto 3 jump to input c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...Exit 5 write(*,8)numblk,igrblk 8 format(1x/i9, *' Hamiltonian blocks up to MAXCOL limit processed numerically'/i9, *' Hamiltonian blocks above MAXCOL limit processed graphically'/) goto 9 c c...Error conditions c c 6 write(*,'(1x//'' **** ERROR: Cannot open the output file''//)') goto 9 c 7 write(*,'(1x//'' **** ERROR: Cannot read a line of input''//)') goto 9 c 16 write(*,'(1x//'' **** ERROR: Cannot read a line of input''//)') goto 9 c 36 write(*, * '(1x//'' **** WARNING: input reached MAXDIM='',i5/)')maxdim goto 5 c 20 write(*,25)filvar(1:len_trim(filvar)) 25 format(1x//' **** ERROR: Cannot open the VAR file:'//7x,a//) goto 9 c 9 close(3) close(4) stop end C_____________________________________________________________________________ C_____________________________________________________________________________