program makefterachem
      character*80 fn
      character*3 sy
      integer symboltoatnumber
      integer,allocatable::ty(:)
      real*8,allocatable::r(:)
      ii=0
      ig=0
      nat=0
      open(2,file='STRUCT.LST')
      open(3,file='FILE.X')
1     read(2,200,end=500,err=500)fn
200   format(a80)
      ii=ii+1

      open(4,file=fn)
3     read(4,*,err=600,end=600)nat
      ig=ig+1
      read(4,200)fn
      write(3,200)fn
      write(3,*)nat
      if(ig.eq.1)allocate(r(3*nat),ty(nat))
      do 21 ia=1,nat
      read(4,400)sy,(r(ix+3*(ia-1)),ix=1,3)
400   format(1x,a3,3x,3f16.10)
21    ty(ia)=symboltoatnumber(sy)
      do 22 ia=1,nat
22    write(3,300)ty(ia),(r(ix+3*(ia-1)),ix=1,3)
300   format(i3,3f12.6)
      goto 3
600   close(4)

      goto 1
500   close(2)
      close(3)
      write(6,*)ii,' files,',ig,' geometries ',nat,' atoms'
      write(6,*)' FILE.X made.'
      stop
      end

      function symboltoatnumber(s)
      implicit none
      character*(*)s
      integer symboltoatnumber,jstart,jend,iend,istart,i
      character*2 atsy(89)
      DATA ATSy/'H ','HE','LI','BE','B ','C ','N ','O ','F ','NE',
     3'NA','MG','AL','SI','P ','S ','CL','AR',
     4'K ','CA','SC','TI','V ','CR','MN','FE','CO','NI','CU','ZN',
     4          'GA','GE','AS','SE','BR','KR',
     5'RB','SR','Y ','ZR','NB','MO','TC','RU','RH','PD','AG','CD',
     5          'IN','SN','SB','TE','I ','XE',
     6'CS','BA','LA',
     6               'CE','PR','ND','PM','SM','EU','GD','TB','DY','HO',
     6               'ER','TM','YB','LU',
     6'HF','TA','W ','RE','OS','IR','PT','AU','HG',
     6          'TL','PB','BI','PO','AT','RN',
     7'FR','RA','AC'/
      jstart=1
      do 1 istart=1,len(s)
1     if(s(istart:istart).ne.' ')goto 2
2     do 3 iend=len(s),1,-1
3     if(s(iend:iend).ne.' ')goto 4
4     do 6 i=istart,iend
6     if(ichar(s(i:i)).gt.96)s(i:i)=char(ichar(s(i:i))-32)

c     capture water and some other idiotic Tinker definitions:
      i=0
      if(s(istart:iend).EQ.'HW')i=1
      if(s(istart:iend).EQ.'H1')i=1
      if(s(istart:iend).EQ.'HC')i=1
      if(s(istart:iend).EQ.'OW')i=8
      if(s(istart:iend).EQ.'CT')i=6
      if(s(istart:iend).EQ.'K+')i=19
      if(i.ne.0)then
       symboltoatnumber=i
       return
      endif

      do 5 i=1,89
      if(atsy(i)(2:2).eq.' ')then
       jend=1
      else
       jend=2
      endif
      if(atsy(i)(jstart:jend).eq.s(istart:iend))then
       symboltoatnumber=i
       return
      endif
5     continue

c     last resort - consider first letter only:
      i=0
      if(s(istart:istart).eq.'H')i=1
      if(s(istart:istart).eq.'N')i=7
      if(s(istart:istart).eq.'O')i=8
      if(s(istart:istart).eq.'C')i=6
      if(i.ne.0)then
       symboltoatnumber=i
       return
      endif

      write(6,*)s,' symbol not found'
      symboltoatnumber=0
      return
      end