c---------------------------------------------------------------------------- c c L I N A S F - Converter from Pickett's .LIN standard for SPFIT C to .ASF standard of ASFIT c c---------------------------------------------------------------------------- c c C ver. 12.IV.2008 ----- Zbigniew KISIEL ----- C __________________________________________________ C | Institute of Physics, Polish Academy of Sciences | C | Al.Lotnikow 32/46, Warszawa, POLAND | C | kisiel@ifpan.edu.pl | C | http://info.ifpan.edu.pl/~kisiel/prospe.htm | C_________________________/-------------------------------------------------- c c MODIFICATION HISTORY: c c 6.08.2003: creation c 20.11.2006: transfer of annotations c 12.04.2008: three digit quantum numbers and filtering c c---------------------------------------------------------------------------- c implicit real*8 (a-h,o-z) parameter (maxlin=5000) c character filin*30,filout*30,line*600,annot*8,nqbuf*36 character lines(maxlin)*600 real*8 freq(maxlin),error(maxlin),weight(maxlin) integer nq(maxlin,6),ifit(maxlin),nqin(12) c c WRITE(*,10) 10 FORMAT(1X//' ',76(1H_)/' |',T79,'|'/ * ' | LINASF - Converter from Pickett''s .LIN standard for ', * 'SPFIT',T79,'|'/ * ' | to .ASF standard for ', * 'ASFIT',T79,'|'/' |',76(1H_),'|'/ * ' version 12.IV.2008',T64,'Zbigniew KISIEL'//) c c c...open the .LIN input file c 11 write(*,2)' Name of input .LIN file (without extension):' 2 format(1x/1x,a,' ',$) read(*,'(a)',err=11)filin do 200 n=30,1,-1 if(filin(n:n).ne.' '.and.ichar(filin(n:n)).ne.0)then filin= filin(1:n)//'.lin' goto 201 endif 200 continue 201 open(2,file=filin,status='old',err=11) c c...open the output file c 7 write(*,2)' Name of output file: ' read(*,'(a)',err=7)filout open(3,file=filout,status='unknown') c c...ask for number of quantum numbers per level c 80 write(*,2)'No of qns per energy level: ' read(*,*,err=80)nqns if(nqns.lt.3.or.nqns.gt.6)goto 80 c 81 write(*,2)' Filtering (1/0) ? ' read(*,'(i5)',err=81)ifilt if(ifilt.lt.0.or.ifilt.gt.1)goto 81 if(ifilt.eq.1)then 82 write(*,2)' Number of qn, value: ' read(*,*,err=81)ifqn,ifval if(ifqn.gt.2*nqns)goto 82 endif c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...Read a line of input and take appropriate action, control comes back c to statement 4 until EOF c c nlines=0 c 4 read(2,'(a)',end=1)line read(line(1:36),'(12i3)',err=4)(nqin(n),n=1,12) read(line(37:),*,err=4,end=1)fr,err,wt if(ifilt.eq.1)then if(nqin(ifqn).ne.ifval)goto 4 endif jup=nqin(1) kaup=nqin(2) kcup=nqin(3) jlow=nqin(nqns+1) kalow=nqin(nqns+2) kclow=nqin(nqns+3) c c read(2,*,err=4,end=1)jup,kaup,kcup,jlow,kalow,kclow,i,i,i,i,i,i, c * fr,err,wt c nlines=nlines+1 nq(nlines,1)=jup nq(nlines,2)=kaup nq(nlines,3)=kcup nq(nlines,4)=jlow nq(nlines,5)=kalow nq(nlines,6)=kclow freq(nlines)=fr error(nlines)=err weight(nlines)=wt lines(nlines)=line c if((nlines/100)*100.eq.nlines)write(*,*)nlines c goto 4 c 1 close(2) c c...assign IFIT values c do 20 n=1,nlines if(error(n).eq.0.d0)then ifit(n)=0 weight(n)=0.d0 goto 20 endif c if(n.eq.1)then if(freq(1).eq.freq(2))then ifit(n)=2 else ifit(n)=1 endif goto 20 endif c if(n.eq.nlines)then if(freq(n-1).eq.freq(n))then ifit(n)=2 else ifit(n)=1 endif goto 20 endif c if((freq(n-1).eq.freq(n)).or.(freq(n+1).eq.freq(n)))then ifit(n)=2 else ifit(n)=1 endif c 20 continue c c...deal with weights of blend blocks: these are scaled into the region 1-10 by c multiplication by appropriate powers of 10 c wtsum=0.d0 ndeg=0 c do 31 n=2,nlines-1 if( (ifit(n).eq.2) .and. * (ifit(n-1).eq.2) .and. * (freq(n).eq.freq(n-1)) .and. * (ndeg.eq.0) )then ndeg=n-1 wtsum=wtsum+weight(n-1) nwt=1 endif c if( ndeg.ne.0 .and. (freq(n).ne.freq(n+1)) )then wtsum=wtsum+weight(n) nwt=nwt+1 wtav=wtsum/real(nwt) c mult=0 22 if(wtav.le.10.d0.and.wtav.ge.1.d0)goto 21 if(wtav.gt.10.d0)then wtav=wtav/10.d0 mult=mult-1 goto 22 endif if(wtav.lt.1.d0)then wtav=wtav*10.d0 mult=mult+1 goto 22 endif c 21 if(mult.eq.0)then wtmult=1.d0 else wtmult=10.0d0**(mult) endif c do 25 nn=ndeg,n weight(nn)=weight(nn)*wtmult 25 continue c ndeg=0 wtsum=0.d0 goto 31 endif c 31 continue c if(ifit(nlines).eq.2)then do 35 n=nlines,1,-1 if(freq(n).eq.freq(nlines).and.ifit(n).eq.2)then ndeg=n else goto 36 endif 35 continue 36 wtsum=0.d0 nwt=0 do 37 n=ndeg,nlines wtsum=wtsum+weight(n) nwt=nwt+1 37 continue wtav=wtsum/real(nwt) c mult=0 32 if(wtav.le.10.d0.and.wtav.ge.1.d0)goto 39 if(wtav.gt.10.d0)then wtav=wtav/10.d0 mult=mult-1 goto 32 endif if(wtav.lt.1.d0)then wtav=wtav*10.d0 mult=mult+1 goto 32 endif c 39 if(mult.eq.0)then wtmult=1.d0 else wtmult=10.0d0**(mult) endif c do 38 nn=ndeg,nlines weight(nn)=weight(nn)*wtmult 38 continue endif c c write(*,'(1x/1x,2a/)')'Writing output to ', c * filout(1:len_trim(filout)) c c c...output c do 3 n=1,nlines 57 line=lines(n) nlc=len_trim(line) if(nlc.lt.24)goto 57 annot='' 51 do 50 nnn=1,nlc if(line(nnn:nnn).eq.'!')goto 52 if(line(nnn:nnn).eq.'#')then nsanot=nnn+1 nfanot=nlc if(nfanot.lt.nsanot)goto 53 annot=line(nsanot:nfanot) goto 53 endif 50 continue goto 53 c 52 nstrt=nnn if(nnn.eq.nlc)then nfin=nlc goto 55 endif do 54 nnn=nstrt+1,nlc if(line(nnn:nnn).eq.'!')goto 56 if(line(nnn:nnn).eq.'#')then nsanot=nnn+1 nfanot=nlc if(nfanot.lt.nsanot)goto 53 annot=line(nsanot:nfanot) goto 53 endif 54 continue nfin=nlc goto 55 56 nfin=nnn-1 c 55 write(3,'(a)')line(nstrt:nfin) if(nfin.ne.nlc)then nnn=nfin+1 goto 52 endif c 53 if(ifit(n).ne.2)then write(3,5)(nq(n,i),i=1,6),freq(n),error(n),ifit(n),annot else write(3,6)(nq(n,i),i=1,6),freq(n),error(n),ifit(n),weight(n), * annot endif 5 format(6i5,f20.6,f15.6,i5,10x, a) 6 format(6i5,f20.6,f15.6,i5,f10.4,a) 3 continue c write(*,'(1x/i6,'' lines written to file '',a//)')nlines,filout c close(3) c stop end C C_____________________________________________________________________________ C_____________________________________________________________________________