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

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

      np=nsn(fn)
      write(6,*)np,' points'
      allocate(x(np),y(np))
      x=0.0d0
      y=0.0d0
      call ls(x,y,fn,np)
      call lsr(x,np,nt,sf)
      do 1 i=1,len(fn)
1     if(fn(i:i).ne.' ')goto 2
2     call wrs('s.'//fn(i:len(fn)),y,x,np)
      end

      subroutine lsr(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 ls(x,y,name,np)
c     loads in the spectrum  within wmin wmax    
      implicit none
      integer*4 i,np
      real*8 x(*),y(*)
      character*(*) name
      open(9,file=name)
      do 1 i=1,np
 1    read(9,*)x(i),y(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 wrs(s,s1,x,np)
      implicit none
      integer*4 i,np
      real*8 s1(np),x(np)
      character*(*) s
      open(9,file=s)
      do 1 i=1,np
1     write(9,900)x(i),s1(i)
900   format(f12.2,e12.4)
      close(9)
      write(6,*)s//' written'
      return
      end