program scaletab
      implicit none
      integer*4 nt,nsn,i,iargc,np
      real*8,allocatable::sf(:,:),x(:)
      character*80 fn
      character*160,allocatable::sy(:)
      character*160 h(3)
      write(6,6000)
6000  format(/,'  X-scaling of a tab file ',/,/,
     1'      Input: STABLE.TXT',/,
     1'     Output: s.<tab>',/)
      if(iargc().ne.1)then
       write(6,*)'Usage: scalespec <tab>'
       stop
      else
       call getarg(1,fn)
      endif

      nt=nsn('STABLE.TXT')
      allocate(sf(2,nt))
      call lstab(nt,sf)

      np=nsn(fn)-4
      write(6,*)np,' frequencies'
      allocate(x(np),sy(np))
      x=0.0d0
      call lt(x,fn,np,sy,h)
      call lst(x,np,nt,sf)
      do 1 i=1,len(fn)
1     if(fn(i:i).ne.' ')goto 2
2     call wrt('s.'//fn(i:len(fn)),x,np,sy,h)
      end

      subroutine lst(x,np,nt,sf)
      implicit none
      integer*4 np,i,nt
      real*8 x(*),sf(2,nt),xjf,xx
      do 1 i=1,np
      xx=x(i)
  1   x(i)=xjf(xx,nt,sf)
      return
      end

      function nsn(fn)
      implicit none
      integer*4 nsn,ns
      character*(*) fn
      open(9,file=fn,status='old')
      ns=0
101   read(9,*,end=99,err=99)
      ns=ns+1
      goto 101
99    close(9)
      nsn=ns
      return
      end

      subroutine lstab(ns,sf)
      implicit none
      integer*4 j,ns
      real*8 sf(2,ns)
      open(9,file='STABLE.TXT')
      do 1 j=1,ns
1     read(9,*,end=99,err=99)sf(1,j),sf(2,j)
99    close(9)
      write(6,*)ns,' assignments loaded'
      return
      end

      subroutine lt(x,name,np,sy,h)
c     loads in the table
      implicit none
      integer*4 i,np
      real*8 x(*)
      character*(*) name
      character*160 sy(np),h(3)
      open(9,file=name)
      read(9,90)h(1)
      read(9,90)h(2)
      read(9,90)h(3)
      do 1 i=1,np
      read(9,90)sy(i)
  90  format(a160)
 1    read(sy(i),*)x(i),x(i)
      close(9)
      return
      end

      function xjf(xj,nt,sf)
      implicit none
      integer*4 nt,i
      real*8 xjf,xj,sf(2,nt),xe1,xe2,xc1,xc2
      do 1 i=1,nt-1
      xe1=sf(1,i )
      xe2=sf(1,i+1)
      xc1=sf(2,i )
      xc2=sf(2,i+1)
c     xe1,xe2 ... experimental values, xc1,xc2 ... corresponding calc.
      if((xj.ge.xc1.and.xj.le.xc2).or.
     1   (xj.le.xc1.and.xj.ge.xc2))then
       xjf=xe1+(xj-xc1)*(xe2-xe1)/(xc2-xc1)
       return
      endif
 1    continue
      if(dabs(xj-sf(2,nt)).lt.dabs(xj-sf(2,1)))then
       xjf=sf(1,nt)+xj-sf(2,nt)
      else
       xjf=sf(1,1)+xj-sf(2,1)
      endif
      return
      end

      subroutine wrt(s,x,np,sy,h)
      implicit none
      integer*4 i,np,is1,is2,is3,is4
      real*8 x(np)
      character*(*) s
      character*160 h(3),sy(np)
      open(9,file=s)
      call wh(h(1))
      call wh(h(2))
      call wh(h(3))
      do 1 i=1,np
      do 2 is1=1,len(sy(i))
2     if(sy(i)(is1:is1).ne.' ')goto 3
3     do 4 is2=is1,len(sy(i))
4     if(sy(i)(is2:is2).eq.' ')goto 5
5     do 6 is3=is2,len(sy(i))
6     if(sy(i)(is3:is3).ne.' ')goto 7
7     do 8 is4=is3,len(sy(i))
8     if(sy(i)(is4:is4).eq.' ')goto 9
9     call wh_(sy(i)(1:is3-1))
      write(9,900)x(i)
900   format(f9.2,$)
1     call wh(sy(i)(is4:len(sy(i))))
      write(9,901)
901   format(60(1h-))
      close(9)
      write(6,*)s//' written'
      return
      end

      subroutine wh(h)
      character*(*) h
      call wh_(h)
      write(9,*)
      return
      end

      subroutine wh_(h)
      character*(*) h
      do 1 ie=len(h),1,-1
 1    if(h(ie:ie).ne.' ')goto 2
 2    do 3 i=1,ie
 3    write(9,90)h(i:i)
 90   format(a1,$)
      return
      end