C**********************************************************************C
C                                                                      C
C  Program CIF2SX  will take as input a legal CIF file and output      C
C  a legal SHELXL instruction file. A SHELX file for each data_        C
C  block may be obtained.                                              C
C                                                                      C
C  The following information in the CIF is required:                   C
C                                                                      C
C  1. unit cell parameters and wavelength: if latter is missing        C
C     MoKalpha is assumed.                                             C
C  2. chemical formula: preferably as sum or structural rather than    C
C     moieties (interpretation of latter may not be succesful)         C
C  3. number of formula units per cell.                                C
C  4. elemental types: as atom_type_symbol and atom_site_type_symbol   C
C  5. atomic positional, occupation (default 1.), thermal parameters   C
C  6. space group symbol: either H-M or Hall                           C
C  7. equivalent positions:  as xyz                                    C
C                                                                      C
C  If any of the above data items are missing the program will halt.   C
C                                                                      C
C  In addition, the CIF dictionary CIF_CORE.DIC should be present in   C
C  the specified directory "cifdir" if data items are to be            C
C  checked.                                                            C
C                                                                      C
C  For compilation purposes, the include files for  Syd Hall's CIF     C
C  utility CIFTBX (CIFTBX.SYS and CIFTBX.CMN) are also required        C
C                                                                      C
C  NB: NDIM is the maximum no. of atoms. It may be increased           C
C      without problem. Change all occurrences of the statement:       C
C                                                                      C
C   parameter (NDIM=1000)                                              C
C                                                                      C
C**********************************************************************C
C  Copyright June 1997: Louis J. Farrugia, University of Glasgow       C
C  Modified : 03-Jan-2001 (several bug fixs)                           C
C             09-Jul-2002 bug fix for R centered lattices and site     C
C                         multiplicity                                 C
C             01-May-2005 updated CIF dictionary                       C
C  NB. This program also produces files suitable for SHELX97           C
C**********************************************************************C
C
      program main
      common/logi/lcheck
      character fname*12,fname1*12,ans*1
      logical lexist,lcheck
      lcheck=.false.
      write(*,'('' Enable CIF dictionary check ? Y/N [N] :'',$)')
      read (*,'(a)')ans
      if(ans .eq. 'Y' .or. ans .eq. 'y') lcheck=.true.
2     write
     & (*,'('' Enter name of CIF (extension .CIF assumed) :'',$)')
      read (*,'(a)')fname1
      if (fname1 .eq. ' ') goto 1
      call lcase(fname1)
      if (index(fname1,'.') .ne. 0) then
         fname=fname1
      else
         ilen=leng(fname1)
C ---- comment out following line if not using IBM-PC (Win95 is OK!)
         if (ilen .gt. 8)ilen=8
         fname=fname1(1:ilen)//'.cif'
      endif
      inquire (file=fname,exist=lexist)
      if (.not. lexist) then
         ilen=leng(fname)
         call prstr(' CIF file '//fname(1:ilen)//' does not exist')
         write (*,'(/'' Try another file? Y/N [Y]:'',$)')
         read (*,'(a)')ans
         if (ans .eq. 'N' .or. ans .eq. 'n') goto 1
         goto 2
      endif
      call readcif(fname)
1     end
C
C----------------------------------------------------------------------C
C
      subroutine readcif(fname)
C
C ---- Input   : a legal CIF file
C      Output  : a legal SHELXL93 .INS file (if all necessary information
C                is present)
C      Requires: CIF_CORE.DOC . The directory containing this file is given
C                in character string cif_dir (implementation dependent)
C      Compilation : requires Syd Hall's CIFTBX.CMN and CIFTBX.SYS
C
      parameter (NDIM=1000)
      include 'ciftbx.cmn'
      logical f1,allint,integ,lcheck,lexist
      character fname*12,label2*8,ans*1,clwnt(6)*32,chferr(6)*27
      character name*32,sgname*32,title*80
      character chemfm*80,atwnt(3)*32,aniwnt(6)*32
      character cifdic*80
      real sdev,dum,uij2(6),fnamtp(30),xin(3),mult,SpaceGroupMult
      integer i,j,ilatt,getltype,cklab
      character*8 label,ftype
      character*12 infile
      common /logi/lcheck
      common /cifmodc/label(NDIM),ftype(30)
      common /cifmod/natom,nr,ntype,nftype(NDIM),p(3,NDIM),sof(NDIM),
     & uij(6,NDIM),wavel,cell(6),ecell(6),r(192,3,4),contnt(30),iz
      external getltype,cklab
      clwnt(1)='_cell_length_a'
      clwnt(2)='_cell_length_b'
      clwnt(3)='_cell_length_c'
      clwnt(4)='_cell_angle_alpha'
      clwnt(5)='_cell_angle_beta'
      clwnt(6)='_cell_angle_gamma'
      atwnt(1)='_atom_site_fract_x'
      atwnt(2)='_atom_site_fract_y'
      atwnt(3)='_atom_site_fract_z'
      aniwnt(1)='_atom_site_aniso_U_11'
      aniwnt(2)='_atom_site_aniso_U_22'
      aniwnt(3)='_atom_site_aniso_U_33'
      aniwnt(4)='_atom_site_aniso_U_23'
      aniwnt(5)='_atom_site_aniso_U_13'
      aniwnt(6)='_atom_site_aniso_U_12'
      chferr(1)=' Syntax error in formula:  '
      chferr(2)=' Illegal special symbol in '
      chferr(3)=' Unrecognised element in   '
      chferr(4)=' Brackets not matched in   '
      chferr(5)=' Conversion error in       '
      chferr(6)=' Too many different atoms  '
      dum=0.0
      sdev=0.0
      name=' '
      sgname=' '
C
C   WARNING WARNING WARNING WARNING WARNING WARNING WARNING
C ---- The following variable is implementation-specific. The default
C      value ' ' given here indicates that the CIF dictionary is to be
C      found in the current directory. 

      call getenv('CIF2SXDIC',cifdic)
      if(cifdic .eq. ' ') cifdic='cif_core.dic'

C   WARNING WARNING WARNING WARNING WARNING WARNING WARNING
C
      call sxinit
      call ctbxinit
      f1=init_(21,22,23,6)
      if(.not.lcheck) goto 110
      write (*,'(/'' Loading the CIF dictionary. Please wait.....'')')
      call trim(cifdic)
      write(*,*) cifdic
      if (dict_(cifdic,'valid')) goto 110
      call prstr(' CIF dictionary CIF_CORE.DIC not found. No checks.')
110   write (*,'(/'' Reading data from '',a,/)')fname
      f1=ocif_(fname)
C
C ---- start of loop for each data_ block
C
127   if (data_(' ')) goto 128
      call prstr(' No (more) data_ statement(s) found')
      return
128   ilen=leng(bloc_)
      write (*,'(/'' Use the data in block '',a,'' ? Y/N [Y]:'',$)')
     & bloc_(1:ilen)
      read (*,'(a)')ans
      call ucase(ans)
      if (ans .eq. 'N') goto 127
C
C ---- now open .INS file
      ilen1=ilen
      if(ilen1 .gt. 8) ilen1=8
      infile=bloc_(1:ilen1)//'.ins'
      inquire (file=infile,exist=lexist)
      if (lexist) then
         write (*,
     &  '('' Target .INS file already exists. Overwrite? Y/N [Y]:'',$)')
         read (*,'(a)')ans
         if (ans .eq. 'N' .or. ans .eq. 'n') return
      endif
      open (25,file=infile,status='unknown')

      f1=char_('_symmetry_space_group_name_H-M',sgname)
      if (.not. f1) then
         f1=char_('_symmetry_space_group_name_Hall',sgname)
         if (.not. f1) then
            call prstr(' No suitable space group information.')
            close (25,status='delete')
            goto 127
         endif
      endif
C
      ilen=leng(bloc_)
      title='TITL    '//bloc_(1:ilen)//' in space group '//sgname
      write (25,'(a)')title
C
C ---- Now get unit cell information
C
      do i=1,6
         f1=numb_(clwnt(i),cell(i),ecell(i))
         if (.not. f1) then
            call prstr(' '//clwnt(i)//' not found')
            close (25,status='delete')
            goto 127
         endif
      enddo
C
      f1=numb_('_diffrn_radiation_wavelength',wavel,sdev)
      if (.not. f1) then
         call prstr(' Wavelength not found. Assumed to be 0.71073 A')
      endif
C
      dum=0.0
      sdev=0.0
      f1=numb_('_cell_formula_units_Z',dum,sdev)
      if (.not. f1) then
         call prstr(' data item _cell_formula_units_Z not found')
         close (25,status='delete')
         goto 127
      endif
      iz=nint(dum)
C
      write (25,'(''CELL   '',f8.5,3f9.4,3f9.3)')wavel,(cell(i),i=1,6)
      write (25,'(''ZERR   '',i3,5x,3f9.4,3f9.3)')iz,(ecell(i),i=1,6)
C
C ---- Now check centricity, write LATT and SYMM cards
130   f1=char_('_symmetry_equiv_pos_as_xyz',name)
      if (.not. f1) then
         call prstr(' No equivalent position information')
         close (25,status='delete')
         goto 127
      endif
      call readep(name,ierr)
      if(ierr.eq.1) then
      close(25,status='delete')
      goto 127
      endif
      if (loop_) goto 130
C
      ilatt=getltype(sgname)
      if (ilatt .eq. 0) return
      write (25,'(''LATT   '',i2)')ilatt
C
C ---- routine SYMOUT writes symmetry operations with translations as
C      fractions rather than decimal. This is neater, less of a problem
C      with 1/3, 2/3 translations and is legal in SHELXL93/7 (but not in
C      SHELXS86 or SHELX76).
C
      if (nr .gt. 1) call symout(25,ilatt)
C
C ---- Safest method for obtaining SFAC and UNIT information
C
      ntype=0
132   f1=char_('_atom_type_symbol',label2)
      if (.not. f1) goto 135
      f1=numb_('_atom_type_number_in_cell',dum,sdev)
      if (.not. f1) goto 135
      ntype=ntype+1
      call ucase(label2)
      call lcase(label2(2:2))
      label2(3:8)=' '
      if (cklab(label2) .eq. 1) then
         call prstr(' Unacceptable atomic symbol '//label2)
         close (25,status='delete')
         goto 127
      endif
      ftype(ntype)=label2
      contnt(ntype)=dum
      if (loop_) goto 132
      goto 139
C
C ---- Second method for SFAC and UNIT information based on chemical
C ---- formula. NOTE: interpretation of "_chemical_formula_moiety"  by
C ---- routine CHFORM may not always be successful.
135   chemfm=' '
      f1=char_('_chemical_formula_sum',chemfm)
      if (f1) goto 137
      chemfm=' '
      f1=char_('_chemical_formula_structural',chemfm)
      if (f1) goto 137
      chemfm=' '
      f1=char_('_chemical_formula_moiety',chemfm)
      if (.not. f1) then
C ---- fail to get required information - abort
         call prstr(' No chemical formula information found')
         close (25,status='delete')
         goto 127
      endif
C
C ---- Only one character*80 line allowed for formula
137   if (text_) then
         call prstr(' Chemical formula string too long. One line only')
         close (25,status='delete')
         goto 127
      endif
      call chform(chemfm,ftype,fnamtp,ntype)
      if (ntype .ge. 1) then
         write (*,'('' Chemical formula::''/,24(1x,a2,f6.2,'': ''))')
     &   (ftype(i),fnamtp(i),i=1,ntype)
      elseif (ntype .eq. -1) then
C ---- error messages
         call prstr(' ')
         call prstr(chferr(1)//chemfm)
         call prstr(' :: Blanks must separate element fields,')
         call prstr
     &   (' :: no blanks between element and index, eg P (C H3)3')
         close (25,status='delete')
         goto 127
      endif
C
      do i=2,6
         if (ntype .eq. -i) then
            call prstr(' ')
            call prstr(chferr(i)//chemfm)
            close (25,status='delete')
            goto 127
         endif
      enddo
C
      do i=1,ntype
         contnt(i)=iz*fnamtp(i)
      enddo
C
139   continue
C
C ---- Now check whether all cell contents are integral.
C ---- If so write out as integer fields, otherwise as real fields
C
      allint=.true.
      do i=1,ntype
         if (mod(contnt(i),1.0) .ge. 1.e-6)allint=.false.
      enddo
C
      write (25,'(''SFAC  '',30(3x,a2))')(ftype(k),k=1,ntype)
      if (allint) then
         write (25,'(''UNIT   '',30i5)')(nint(contnt(k)),k=1,ntype)
      else
         write (25,'(''UNIT   '',30f7.1)')(contnt(k),k=1,ntype)
      endif
C
C ---- Now get the atom information
C
      iatom=0
140   iatom=iatom+1
C ---- Only NDIM atoms are allowed
      if (iatom .gt. NDIM) then
         write (*,'(/'' More than '',i5,'' atoms found. Remaining atoms 
     &will be ignored'')') NDIM
         iatom=NDIM
         goto 150
      endif
C
      f1=char_('_atom_site_label',label(iatom))
      if (.not. f1) then
         call prstr(' data item _atom_site_label not found')
         close (25,status='delete')
         goto 127
      endif
C ---- Adjust label for normal chemical symbol  e.g. "Ru"
      call ucase(label(iatom))
      call lcase(label(iatom)(2:2))
C
      f1=char_('_atom_site_type_symbol',label2)
C
      if (.not. f1) then
C ---- get ftype from label - assumes sensible atomic labelling!!
         nftype(iatom)=1
         if (.not. integ(label(iatom)(2:2))) then
            do i=1,ntype
               if (label(iatom)(1:2) .eq. ftype(i))nftype(iatom)=i
            enddo
         else
            do i=1,ntype
               if (label(iatom)(1:1) .eq. ftype(i))nftype(iatom)=i
            enddo
         endif
C
      else
C ---- get it from atom_site_type_symbol
         label2(3:8)=' '
         if (cklab(label2) .eq. 1) then
            call prstr(' Unacceptable atom_site_type_symbol '//label2)
            close (25,status='delete')
            goto 127
         endif
         do i=1,ntype
            if (label2 .eq. ftype(i))nftype(iatom)=i
         enddo
      endif
C
      do i=1,3
         f1=numb_(atwnt(i),p(i,iatom),sdev)
         if (.not. f1) then
            call prstr(atwnt(i)//' not found')
            close (25,status='delete')
            goto 127
         endif
      enddo
C
Cljf 09/07/02 - fix from WinGX incorporated - new routines SpaceGroupMult &
C               rnormx added
      dum = 1.0
      f1=numb_('_atom_site_occupancy',dum,sdev)
      sof(iatom)=dum
      xin(1) = p(1,iatom)
      xin(2) = p(2,iatom)
      xin(3) = p(3,iatom)
      mult=SpaceGroupMult(xin,r,nr)
      if (f1) then
         sof(iatom)=10.0 + (sof(iatom)/mult)
      else
         sof(iatom)=10.0 + (1.0/mult)
      endif
      dum = 0.05
      f1=numb_('_atom_site_U_iso_or_equiv',dum,sdev)
      uij(1,iatom)=dum
      if (loop_) goto 140
C
150   natom=iatom
      iloop=0
155   iloop=iloop+1
      if (iloop .gt. NDIM) goto 160
      f1=char_('_atom_site_aniso_label',label2)
      if (.not. f1) goto 160
      call ucase(label2)
      call lcase(label2(2:2))
      do k=1,6
         f1=numb_(aniwnt(k),uij2(k),dum)
      enddo
      do i=1,natom
         if (label2 .eq. label(i)) then
            do k=1,6
               uij(k,i)=uij2(k)
            enddo
         endif
      enddo
      if (loop_) goto 155
C
160   continue
      do i=1,natom
C ----- Check for isotropic thermal parameter: if so write out Uiso/Ueq
         sum=abs(uij(2,i))+abs(uij(3,i))+abs(uij(4,i))+abs(uij(5,i))
     &   +abs(uij(6,i))
         if (sum .gt. 0.0) then
            write (25,'(a4,3x,i2,6f10.5,a2,/,5x,4f10.5)')
     &      label(i),nftype(i),p(1,i),p(2,i),p(3,i),sof(i),(uij(j,i),
     &       j=1,2),' =',(uij(j,i),j=3,6)
         else
            write (25,'(a4,3x,i2,5f10.5)')
     &      label(i),nftype(i),p(1,i),p(2,i),p(3,i),sof(i),uij(1,i)
         endif
      enddo
C
      write (25,'(''HKLF    4''/''END'')')
      close (25)
      call ucase(infile)
      write (*,'(/'' >> SHELX format file '',a,'' written.'')')
     & infile
      goto 127
      end
C
C----------------------------------------------------------------------C
C
      real function SpaceGroupMult(xin,r,nr)
C ---- returns the space group multiplicity of the site with fractional
C      coordinates in vector x(3) - specific for CIF which has ALL
C      symmetry operators including centre of symmetry
C      x and z are normalised to 0.0000 =< x,z < 0.9999
C
C   NOTE: the multiplicity given here is NOT the same as that defined
C   in International Tables A, nor for _atom_site_symmetry_multiplicity
C   as defined in CIF_CORE.DIC. Here the multiplicity is defined as :
C
C       multiplicity of general position/multiplicity of the site in x
C
C       possible values range from 1.0 (for a general position) to 48.0
C
C       SHELXL97-2 gives the WRONG value for multiplicity (i.e. the same
C       as defined here)
C
      real     x(3),xin(3),z(3),rnormx,r(192,3,4),tol,sum
      integer  nr
 
      tol=1.0e-3
      sum=0.0
      SpaceGroupMult = 0.0
      do i=1,3
       x(i)=rnormx(xin(i))
      enddo
      x1=x(1)
      x2=x(2)
      x3=x(3)
      do i=1,nr
        z(1)=(r(i,1,1)*x1)+(r(i,1,2)*x2)+(r(i,1,3)*x3)+r(i,1,4)
        z(2)=(r(i,2,1)*x1)+(r(i,2,2)*x2)+(r(i,2,3)*x3)+r(i,2,4)
        z(3)=(r(i,3,1)*x1)+(r(i,3,2)*x2)+(r(i,3,3)*x3)+r(i,3,4)
        do j=1,3
          z(j)=rnormx(z(j))
        enddo
        if(abs(x(1)-z(1)) .le. tol .and. abs(x(2)-z(2)) .le. tol .and.
     &     abs(x(3)-z(3)) .le. tol) sum = sum + 1.0
      enddo
      SpaceGroupMult=sum
      end
C
C----------------------------------------------------------------------C
C
      real function rnormx(z)
C ---- normalises x so that 0.0 =< x < 1.0
      x=z
1     if(x .lt. 0.0) then
        x = x + 1.0
      goto 1
      endif
2     if(x .ge. 1.0) then
        x = x - 1.0
        goto 2
      endif
      rnormx=x
      end
C
C----------------------------------------------------------------------C
C
      integer function getltype(name)
C --- returns SHELXL lattice number from space group symbol 
      parameter (NDIM=1000)
      logical centro,meq
      real r1(3,3),rneg(3,3)
      character label*8,ftype*8,name*32,name1*32,clatt(7)
      common /cifmodc/label(NDIM),ftype(30)
      common /cifmod/natom,nr,ntype,nftype(NDIM),p(3,NDIM),sof(NDIM),
     & uij(6,NDIM),wavel,cell(6),ecell(6),r(192,3,4),contnt(30),iz
      external meq
      data rneg/-1.0,0.0,0.0,0.0,-1.0,0.0,0.0,0.0,-1.0/
      data clatt/'P','I','R','F','A','B','C'/,tol1/1.e-2/,tol2/1.e-1/
C ---- tol1 and tol2 are allowed tolerances for axes and angles resp.
C ---- in a rhombohedral cell. Default values given here are generous.
      name1=' '
      getltype=0
      diffa=abs(cell(1)-cell(2))
      diffb=abs(cell(1)-cell(3))
      diffc=abs(cell(2)-cell(3))
      diffd=abs(cell(4)-cell(5))
      diffe=abs(cell(4)-cell(6))
      difff=abs(cell(5)-cell(6))
      name1=name
      call ucase(name1)
      call trim(name1)
C  ---- check if Hall space group symbol used
      if (name1(1:1) .eq. '-') then
         name1(1:1)=' '
         call trim(name1)
      endif
C
      do i=1,7
      if (name1(1:1) .eq. clatt(i)) getltype=i
      enddo
C
      if(getltype.eq.3) then
C ---- test for rhombohedral cell: if so, then lattice is primitive
       if (diffa .le. tol1 .and. diffb .le. tol1 .and. diffc .le. tol1
     &    .and. diffd .le. tol2 .and. diffe .le. tol2 .and. difff .le.
     &    tol2) getltype=1
      endif
C
      if (getltype .eq. 0) then
         call prstr(' Error in space group symbol: '//name1)
         close (25,status='delete')
         return
      endif
C
      centro=.false.
      do i=1,nr
         do j=1,3
            do k=1,3
               r1(j,k)=r(i,j,k)
            enddo
         enddo
         if (meq(r1,rneg)) centro=.true.
      enddo
      if (.not. centro) getltype=-getltype
      end
C
C----------------------------------------------------------------------C
C
      subroutine readep(name,ierr)
      character*(*)name
      character line(148),buf*148
      integer fch(20),fwd(20)
      ierr=0
      do i=1,148
         line(i)=' '
      enddo
      call ucase(name)
      write (buf,'(''SYMM  '',a)')name
      read (buf,'(72a1)')(line(i),i=2,73)
      call parse(line,nfields,fch,fwd)
      call symin(line,fch,ierr)
      end
C
C----------------------------------------------------------------------C
C
      subroutine symin(line,firstc,ierr)
      parameter (NDIM=1000)
      character line(148)
      integer firstc(20),start
      logical semico,empty
      character*8 label,ftype
      common /cifmodc/label(NDIM),ftype(30)
      common /cifmod/natom,nr,ntype,nftype(NDIM),p(3,NDIM),sof(NDIM),
     & uij(6,NDIM),wavel,cell(6),ecell(6),r(192,3,4),contnt(30),iz
      ierr=0
      tol=1.0e-10
      start=firstc(2)-1
11    nr=nr+1
      do 10 i=1,3
         call cdin(line,start,r(nr,i,1),r(nr,i,2),r(nr,i,3),r(nr,i,4),
     &   semico,empty)
         if (.not. empty) goto 12
         nr=nr-1
         return
12       if (.not. ((semico .and. i .ne. 3) .or.
     &              (.not. semico .and. i .eq. 3))) goto 10
         call prstr(' FATAL: Equivalent position sequence is incorrect')
         ierr=1
         return
10    continue
C
C ---- ignore identity operation
      do 102 i=1,3
         if (abs(r(nr,i,i) -1.0) .gt. tol) goto 13
         do 101 j=1,4
            if (i .eq. j) goto 101
            if (abs(r(nr,i,j)) .gt. tol) goto 13
101      continue
102   continue
      nr=nr-1
13    if (start .lt. 145) goto 11
      return
      end
C
C----------------------------------------------------------------------C
C
      subroutine cdin(line,j,a1,a2,a3,t,termin,empty)
C
C ---- Interprets symmetry character string. Either decimal or
C ---- fractions may be used for translations.
C
      parameter (NDIM=1000)
      character line(148),chara,digit(11),charb(148),label*8,ftype*8
      integer sig
      real number
      logical first,termin,empty
      common /cifmodc/label(NDIM),ftype(30)
      common /cifmod/natom,nr,ntype,nftype(NDIM),p(3,NDIM),sof(NDIM),
     & uij(6,NDIM),wavel,cell(6),ecell(6),r(192,3,4),contnt(30),iz
      data digit/'1','2','3','4','5','6','7','8','9','0','.'/,
     & charb/148*' '/

      empty=.true.
      a1=0.0
      a2=0.0
      a3=0.0
      t=0.0
C ---- set sig
10    sig=1
      num=0
      first=.true.
C ---- clear b
11    k=1
C ---- next
12    j=j+1
      if (j .le. 145) goto 36
      chara=';'
      goto 18
36    chara=line(j)
      if (chara .eq. ' ') goto 12
      empty=.false.
      if (chara .eq. '+' .or. chara .eq. '-') goto 13
      if (chara .eq. 'X' .or. chara .eq. 'Y' .or. chara .eq. 'Z')goto 14
      if(chara.eq.'/') goto 15
      do 16 i=1,11
         if (chara .eq. digit(i)) goto 17
16    continue
      goto 18
C ---- digits
17    k=k+1
      charb(k)=chara
      first=.false.
      goto 12
C ---- slash
15    if (k .eq. 1) goto 19
      call iformt(charb,2,k-1,num)
      goto 11
19    num=0
      goto 11
C ---- xyz
14    if (k .eq. 1) goto 24
      call fformt(charb,2,k-1,number)
      if (num .eq. 0) goto 21
      number=sig*num/number
      goto 23
21    number=sig*number
      goto 23
24    number=sig
23    if (chara .ne. 'X') goto 25
      a1=number
      goto 10
25    if (chara .ne. 'Y') goto 26
      a2=number
      goto 10
26    a3=number
      goto 10
C ---- signs
13    if (.not. first) goto 27
      if (chara .ne. '+') goto 28
      sig=1
      goto 29
28    sig=-1
29    first=.false.
27    if (k .eq. 1) goto 30
      call fformt(charb,2,k-1,t)
      if (num .eq. 0) goto 32
      t=sig*num/t
      goto 33
32    t=sig*t
33    if (chara .ne. '+') goto 31
      sig=1
      goto 30
31    sig=-1
30    num=0
      goto 11
C ---- terminator
18    if (chara .ne. ',' .and. chara .ne. ';') 
     & call prstr(' Wrong equivalent position delimiter: '//chara)
      termin=chara .eq. ';'
      if (num .eq. 0 .and. k .eq. 1) return
      if (k .eq. 1) goto 35
      call fformt(charb,2,k-1,t)
      goto 22
35    t=0.0
22    if (num .eq. 0) goto 34
      t=sig*num/t
      return
34    t=sig*t
      return
      end
C
C----------------------------------------------------------------------C
C
      integer function cklab(label2)
C  ---- tests whether label gives sensible atomic symbol i.e. two 
C  ---- alphabetics or one alphabetic plus blank. CIF specification
C  ---- is too general in this respect.
      character*8 label,label2
      character alpha*26
      data alpha/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
      label=label2
      call ucase(label)
      do i=1,2
         do j=1,26
            if (label(i:i) .eq. alpha(j:j)) goto 1
         enddo
         if (i .eq. 2 .and. label(2:2) .eq. ' ') goto 1
         cklab=1
         return
1        continue
      enddo
      cklab=0
      end
C
C----------------------------------------------------------------------C
C
      subroutine sxinit
C ---- initialises model arrays
      parameter (NDIM=1000)
      character*8 label,ftype
      common /cifmodc/label(NDIM),ftype(30)
      common /cifmod/natom,nr,ntype,nftype(NDIM),p(3,NDIM),sof(NDIM),
     & uij(6,NDIM),wavel,cell(6),ecell(6),r(192,3,4),contnt(30),iz
      iz=1
      wavel=0.71073
      natom=0
      nr=1
      ntype=0
C
      do i=1,30
         contnt(i)=0
         ftype(i)=' '
      enddo
C
      do i=1,3
         cell(i)=1.0
         cell(i+3)=90.0
         ecell(i)=0.0
         ecell(i+3)=0.0
      enddo
C
      do i=1,NDIM
         nftype(i)=0
         sof(i)=0.0
         uij(1,i)=0.05
         label(i)=' '
         do j=2,6
            uij(j,i)=0.0
         enddo
      enddo
C
      do i=1,3
         do j=1,4
            r(1,i,j)=0.0
         enddo
      enddo
C
      r(1,1,1)=1.0
      r(1,2,2)=1.0
      r(1,3,3)=1.0
C
      end
C
C----------------------------------------------------------------------C
C
      subroutine symout(lfc,ilatt)
C ---- selects the unique set of symmetry operators required by SHELXL
      parameter (NDIM=1000)
      character line(66)
      integer start,iset(192)
      real r1(3,3),rneg(3,3),rident(3,3),t1(3),r2(3,3),t2(3)
      logical meq,meq1,veq,modt1
      external meq,meq1,veq,modt1
      character*8 label,ftype
      common /cifmodc/label(NDIM),ftype(30)
      common /cifmod/natom,nr,ntype,nftype(NDIM),p(3,NDIM),sof(NDIM),
     & uij(6,NDIM),wavel,cell(6),ecell(6),r(192,3,4),contnt(30),iz
      data rneg/-1.0,0.0,0.0,0.0,-1.0,0.0,0.0,0.0,-1.0/
      data rident/1.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,1.0/
      ilatt1=abs(ilatt)
C
      do i=1,192
         iset(i)=1
      enddo
C
C ---- outer loop
      do i1=1,nr
         do j1=1,3
            t1(j1)=r(i1,j1,4)
            do k1=1,3
               r1(j1,k1)=r(i1,j1,k1)
            enddo
         enddo
C
C ---- inner loop
         do i2=i1+1,nr
            do j2=1,3
               t2(j2)=r(i2,j2,4)
               do k2=1,3
                  r2(j2,k2)=r(i2,j2,k2)
               enddo
            enddo
C
C ---- check for identity and inverse identity operators
            if (meq(r2,rident)) iset(i2)=0
            if (meq(r2,rneg))   iset(i2)=0
C
C ---- check for centrosymmetric equivalents
            if (meq1(r1,r2) .and. modt1(t1,t2)) iset(i2)=0
C
C ---- check for lattice centering equivalents
            if (ilatt1 .ne. 1) then
               if (meq(r1,r2) .and. veq(t1,t2,ilatt1)) iset(i2)=0
            endif
C
C ---- end loops
         enddo
      enddo
C
C ---- now write out unique symmetry operations
C
      do 10 i=2,nr
         if (iset(i) .ne. 1) goto 10
         start=1
         do 11 j=1,3
            call scout(line,start,r(i,j,1),r(i,j,2),r(i,j,3),r(i,j,4))
            if (j .eq. 3) goto 11
            line(start)=','
            start=start+1
11       continue
         start=start-1
         write (lfc,100)(line(j),j=1,start)
10    continue
100   format ('SYMM    ',66a1)
      return
      end
C
C----------------------------------------------------------------------C
C
      subroutine scout(line,i,a1,a2,a3,t)
C ---- writes out the symmetry operators (as fractions)
      character line(66),tag(3),buf(4)
      character*4 cbuf
      dimension out(3)
      equivalence (buf(1),cbuf)
      data tag/'X','Y','Z'/
      tol=1.0e-10
      out(1)=a1
      out(2)=a2
      out(3)=a3
Cljf fix - write out translations as > 0.0
1     if (t .lt. 0.0)t=1.0+t
      if (t .lt. 0.0) goto 1
C
      if (abs(t) .le. tol) goto 10
      k=int(12*t+0.5)
      do 11 l=1,6
         if (l .eq. 3) goto 11
         j=l
         if (j .eq. 2)j=3
         j=7-j
         if (mod(k,j) .ne. 0) goto 11
         k=k/j
         j=12/j
         write (cbuf,100)k,j
100      format (i2,'/',i1)
         do 200 ind=i,i+3
200         line(ind)=buf(ind-i+1)
         i=i+4
         goto 10
11    continue
10    do 12 j=1,3
         if (abs(out(j)) .le. tol) goto 12
         if (out(j) .gt. 0.0) goto 13
         write (cbuf,101)
101      format (' - ')
         goto 14
13       write (cbuf,102)
102      format (' + ')
14       do 201 ind=i,i+2
201         line(ind)=buf(ind-i+1)
         i=i+3
         a=abs(out(j))
         if (abs(a-1.0) .le. tol) goto 15
         write (cbuf,103)a
103      format (f3.1)
         do 202 ind=i,i+2
202         line(ind)=buf(ind-i+1)
         i=i+3
15       line(i)=tag(j)
         i=i+1
12    continue
      return
      end
C
C----------------------------------------------------------------------C
C
      logical function meq(r1,r2)
C ----- tests whether two rotation matrices are identical
      real r1(3,3),r2(3,3),tol
      tol=1.e-6
      meq=.true.
      do i=1,3
         do j=1,3
            if (abs(r1(i,j)-r2(i,j)) .ge. tol) meq=.false.
         enddo
      enddo
      end
C
C----------------------------------------------------------------------C
C
      logical function meq1(r1,r2)
C ---- tests whether one rotation matrix is inverse of other
      real r1(3,3),r2(3,3),tol

      tol=1.e-6
      meq1=.true.
      do i=1,3
         do j=1,3
            if (abs(r1(i,j)+r2(i,j)) .ge. tol) meq1=.false.
         enddo
      enddo
      end
C
C----------------------------------------------------------------------C
C
      logical function modt1(t1,t2)
C  ---- tests whether two vectors sum to zero (modulo 1)
      real t1(3),t2(3),tol

      tol=1.e-6
      modt1=.true.
      do i=1,3
         if (abs(mod((t1(i)+t2(i)),1.0)) .ge. tol)modt1=.false.
      enddo
      end
C
C----------------------------------------------------------------------C
C
      logical function veq(t1,t2,ilatt1)
C  ---- tests whether two translation vectors differ by an allowable
C  ---- lattice translation
      logical test(3)
      real t1(3),t2(3),tol,x(3)

      tol=1.e-6
      ilatt=ilatt1
      icount=1
1     veq=.true.
      if (ilatt .eq. 2) then
         x(1)=0.5
         x(2)=0.5
         x(3)=0.5
      elseif (ilatt .eq. 3) then
         x(1)=2.0/3.0
         x(2)=1.0/3.0
         x(3)=1.0/3.0
      elseif (ilatt .eq. 4 .or. ilatt .eq. 5) then
         x(1)=0.0
         x(2)=0.5
         x(3)=0.5
      elseif (ilatt .eq. 6) then
         x(1)=0.5
         x(2)=0.0
         x(3)=0.5
      elseif (ilatt .eq. 7) then
         x(1)=0.5
         x(2)=0.5
         x(3)=0.0
      endif
C
Cljf 09/07/02 - extra statement label
2     do i=1,3
         arg = abs(t1(i)-t2(i))
         if (abs(mod((arg-x(i)),1.0)) .ge. tol)veq=.false.
C         if (abs(mod((t1(i)-t2(i)-x(i)),1.0)) .ge. tol)veq=.false.
      enddo
      test(icount)=veq
C
      if (ilatt1 .eq. 4) then
C ---- for F-lattice check all three possible lattice translations
         icount=icount+1
C ----- return value of veq is logical .or.
         if(icount .eq. 4 ) veq=(test(1) .or. test(2) .or. test(3))
         if (icount .eq. 2) then
            ilatt=6
            goto 1
         endif
         if (icount .eq. 3) then
            ilatt=7
            goto 1
         endif
      endif
C
      if (ilatt1 .eq. 3) then
C ----- for R centering check two possible lattice translations
         icount=icount+1
C ----- return value of veq is logical .or.
         if(icount .eq. 3 ) veq=(test(1) .or. test(2))
         if (icount .eq. 2) then
            x(1)=1.0/3.0
            x(2)=2.0/3.0
            x(3)=2.0/3.0
Cljf 09/07/02 - bug fix
            veq=.true.
            goto 2
         endif
      endif
C
      end
C
C----------------------------------------------------------------------C
C
      logical function integ(char1)
C ----- tests whether char1 is a numeric character
      character char1,number(11)
      data number/'0','1','2','3','4','5','6','7','8','9','.'/
      integ=.false.
      do i=1,11
         if (char1 .eq. number(i))integ=.true.
      enddo
      end
C
C----------------------------------------------------------------------C
C
      subroutine chform(chemfm,namtyp,fnamtp,natmtp)
C
C===== Conversion of a string record of the chemical formula into the
C     component sums of elements. Adapted from a subroutine by B.Kilger
C===== 07/83 modified by R.Sievers 9.85 and 7.88 and L.J. Farrugia 5.96
C
C    definition of arguments:
C    chemfm:  input string (character*(32)) with the structural
C     formula
C    namtyp:  character*2-array (length: 30) with natmtp found
C     element symbols
C    nelist:  return of element numbers, alphabetical
C    fnamtp:  return of corresponding indices
C    30:      maximum length of arrays namtyp, nelist and fnamtp
C    natmtp:    > 0 - number of found elements
C               < 0 - Error. :  -1 : syntax error
C                               -2 : illegal special symbol
C                               -3 : unrecognised element
C                               -4 : unmatched brackets
C                               -5 : conversion error
C                               -6 : too many different elements
C
      character*80 buf,chemfm
      character*8 namtyp(30)
      character*1 idmxx
      character*1 nb,flank,nc2,nz
      character*2 nel4
      character*2 nele(106)
      logical integ
C
      real f,ftot,fsav
      real fak(20),fnamtp(30)
C
      integer iendfl,ilpar,irpar,idig,iele,idezpt,istp,ipnt
      integer izifer,nv,nh,nr,i,jbeg,jl,ja,nesav,jend,klein
      integer ji,kleinp,j,ibuf
      integer nelist(30)
C
C----Listing order for the elements. The following 6 elements
C    appear in the indicated order, all other elements will
C    appear in alphabetical order : C H O N S P
C
      integer ielord(6)
      data ielord/15,38,65,57,82,67/
C
      data nele/'AC','AG','AL','AM','AR','AS','AT','AU','B ','BA',
C                1    2    3    4    5    6    7    8     9    10
     & 'BE','BI','BK','BR','C ','CA','CD','CE','CF','CL','CM','CO',
C       11   12   13   15    15   16   17   18   19   20   21   22
     & 'CR','CS','CU','D ','DY','ER','ES','EU','F ','FE','FM','FR',
C       23   24   25    26   27    28   29   30    31   32   33   34
     & 'GA','GD','GE','H ','HE','HF','HG','HO','I ','IN','IR',
C       35   36   37    38   39   40   41   42    43   44   45
     & 'K ','KR','KU','LA','LI','LU','LW','MD','MG','MN','MO',
C       46   47   48    49   50   51   52    53   54   55   56
     & 'N ','NA','NB','ND','NE','NI','NO','NP','O ','OS',
C       57   58   59   60   61   62   63   64    65   66
     & 'P ','PA','PB','PD','PM','PO','PR','PT','PU','RA','RB','RE',
C       67   68   69   70   71   72   73   74   75    76   77   78
     & 'RH','RN','RU','S ','SB','SC','SE','SI','SM','SN','SR','T',
C       79   80   81    82   83   84   85   86   87   88   89   90
     & 'TA','TB','TC','TE','TH','TI','TL','TM','U ','V ','W ',
C       91   92   93   94   95   96   97   98    99   100    101
     & 'XE','Y ','YB','ZN','ZR'/
C       102   103  104   105  106
C
      data nb/' '/
      data flank/' '/
      data nel4/' '/
      data nc2/' '/
      data idmxx/' '/
C
      natmtp=0
      f=1.0
      iendfl=0
      ilpar=0
      irpar=0
      idig=0
      iele=0
      idezpt=0
      istp=0
      ipnt=81
      nc2='0'
C
C --- first remove unecessary blanks from string
C
      call trim(chemfm)
      ibuf=0
      buf=' '
      do i=1,80
         if (i .eq. 80 .and. chemfm(i:i) .ne. ' ') then
            ibuf=ibuf+1
            buf(ibuf:ibuf)=chemfm(i:i)
            goto 1
         endif
         if (i .eq. 80) goto 1
         if (chemfm(i:i) .eq. ' ' .and. integ(chemfm(i+1:i+1)))
     &   goto 1
         if (chemfm(i:i) .eq. ' ' .and. chemfm(i+1:i+1) .eq. ' ')
     &   goto 1
         ibuf=ibuf+1
         buf(ibuf:ibuf)=chemfm(i:i)
1        continue
      enddo
      chemfm=buf
C
C
C     ***  read input string from right to left  ***
100   ipnt=ipnt-1
      if (ipnt .lt. 1) goto 7000
      nb(1:1)=chemfm(ipnt:ipnt)
      nz(1:1)=chemfm(ipnt:ipnt)
C
C             A...Z     a...z     0...9   blank  special char.
C    -----------------------------------------------------
C    EBCDIC 193..233  129...169 240..249    64    65..128
C    ASCII   65...90   97...122  48...57    32    33...47
C
C----lower- or uppercase character or integer?
      if (lge(nz,'0')) goto 200
C
C----special character ?
      if (nz .eq. ' ') goto 5000
      if (nz .eq. '(') goto 3000
      if (nz .eq. ')') goto 4000
      if (nz .eq. '.') goto 4500
      goto 9902
C
C---- lower- or uppercase character or integer
C     (uppercase character ...)
200   if (lle(nz,'Z') .and. lge(nz,'A')) goto 2000
      if (lle(nz,'9') .and. lge(nz,'0')) goto 1000
C     (lowercase character ...)
      if (lgt(nz,'z') .or. llt(nz,'a')) goto 9902
C     lower -> upper case conversion
      if (lge(nb,'a') .and. lle(nb,'z')) then
         nb=char(ichar(nb)-ichar('a')+ichar('A'))
      endif
      goto 2000
C
C     ***  integer  ***
1000  if (idig .gt. 0) goto 1100
      if (iele .gt. 0 .or. ilpar .gt. 0) goto 9901
      if (idezpt .le. 0)f=0.0
C
1100  izifer=ichar(nz)-ichar('0')
      f=f+float(izifer)*10.0**(idig-idezpt)
      idig=idig+1
      irpar=0
      goto 100
C
C     ***  character  ***
2000  if (ilpar .gt. 0) goto 9901
      irpar=0
      idig=0
      idezpt=0
      iele=iele+1
      goto (2020,2030,9903),iele
2020  nel4(1:1)=nb
      nel4(2:2)=flank
      goto 100
2030  idmxx=nel4(1:1)
      nel4(2:2)=idmxx
      nel4(1:1)=nb
      goto 100
C
C     ***  left bracket  ***
3000  if (idig .gt. 0 .or. irpar .gt. 0) goto 9901
      ilpar=1
      if (iele .gt. 0) goto 6000
3010  istp=istp-1
      if (istp .lt. 0) goto 9904
      goto 100
C
C     ***  right bracket  ***
4000  if (iele .gt. 0 .or. ilpar .gt. 0) goto 9901
      idig=0
      idezpt=0
      irpar=1
      istp=istp+1
      if (istp .gt. 24) goto 9904
      fak(istp)=f
      f=1.0
      goto 100
C
C     ***  decimal point  ***
4500  if (idezpt .gt. 0) goto 9905
      f=f*10.0**(-idig)
      idig=idig+1
      idezpt=idig
      goto 100
C
C     ***  blank  ***
5000  if (idig .gt. 0) goto 9901
      ilpar=0
      if (iele .lt. 1) goto 100
C
C **********************************************************************
6000  continue
C
      nv=1
      nh=106
      nr=65
      goto 25
10    nv=nr+1
20    if (nv .gt. nh) goto 30
      nr=(nv+nh)/2
25    if (nel4 .eq. nele(nr)) goto 40
      if (lgt(nel4,nele(nr))) goto 10
      nh=nr-1
      goto 20
C
30    nr=0
40    continue
C **********************************************************************
C
      if (nr .le. 0) goto 9903
      ftot=f
      if (istp .le. 0) goto 6050
      do 6020 i=1,istp
6020     ftot=ftot*fak(i)
6050  if (natmtp .le. 0) goto 6100
      do 6070 i=1,natmtp
         if (nr .ne. nelist(i)) goto 6070
         fnamtp(i)=fnamtp(i)+ftot
         goto 6150
6070  continue
6100  natmtp=natmtp+1
      if (natmtp .gt. 30) goto 9906
      fnamtp(natmtp)=ftot
      nelist(natmtp)=nr
6150  f=1.0
      iele=0
      if (ilpar .gt. 0) goto 3010
      if (iendfl .le. 0) goto 100
C
C     ***  end of scan from right to left  ***
7000  iendfl=1
      if (istp .ne. 0) goto 9904
      if (iele .gt. 0) goto 6000
C
C     *** ordering of elements  ***
      if (natmtp .le. 0) goto 9999
      jbeg=1
C
C----The specified elements are placed first.
      do 7030 jl=1,6
C----search for element ielord(jl) in the formula:
         do 7010 ja=jbeg,natmtp
            if (nelist(ja) .eq. ielord(jl)) goto 7020
7010     continue
C---- not in the formula
         goto 7030
C
7020     nesav=nelist(ja)
         nelist(ja)=nelist(jbeg)
         nelist(jbeg)=nesav
         fsav=fnamtp(ja)
         fnamtp(ja)=fnamtp(jbeg)
         fnamtp(jbeg)=fsav
C
         jbeg=jbeg+1
         if (jbeg .eq. natmtp) goto 9000
7030  continue
C
      jend=natmtp-1
      do 7100 ja=jbeg,jend
         klein=999
         do 7060 ji=ja,natmtp
            if (nelist(ji) .ge. klein) goto 7060
            klein=nelist(ji)
            kleinp=ji
7060     continue
         fsav=fnamtp(kleinp)
         fnamtp(kleinp)=fnamtp(ja)
         fnamtp(ja)=fsav
         nesav=nelist(kleinp)
         nelist(kleinp)=nelist(ja)
         nelist(ja)=nesav
7100  continue
C
9000  if (natmtp .gt. 0) then
         do 9020 j=1,natmtp
            namtyp(j)=nele(nelist(j))
C
C           2. convert to lowercase character
            if (namtyp(j)(2:2) .ne. ' ') then
               namtyp(j)(2:2)=char(ichar(namtyp(j)(2:2))-
     &         ichar('A')+ichar('a'))
            endif
9020     continue
      endif
C
      goto 9999
C
C     ***  general syntax error  ***
9901  natmtp=-1
      goto 9999
C     ***  illegal special symbol  ***
9902  natmtp=-2
      goto 9999
C     ***  illegal element symbol  ***
9903  natmtp=-3
      goto 9999
C     ***  brackets not matched  ***
9904  natmtp=-4
      goto 9999
C     ***  convertion error  ***
9905  natmtp=-5
      goto 9999
C     ***  too many elements in formula  ***
9906  natmtp=-6
C
9999  continue
      return
      end
C
C----------------------------------------------------------------------C
C
      subroutine prstr(message)
C ---- prints message
      character*(*)message

      write (*,'(a)')message
      end
C
C----------------------------------------------------------------------C
C
      subroutine ucase(string)
C ---- sets 'string' to upper case
      character*(*)string

      ilen=len(string)
      do 1 j=1,ilen
         if (lge(string(j:j),'a') .and. lle(string(j:j),'z'))
     &   string(j:j)=char(ichar(string(j:j))-ichar('a')+ichar('A'))
1     continue
      end
C
C----------------------------------------------------------------------C
C
      subroutine lcase(string)
C ---- sets 'string' to lower case
      character*(*)string

      ilen=len(string)
      do 1 j=1,ilen
         if (lge(string(j:j),'A') .and. lle(string(j:j),'Z'))
     &   string(j:j)=char(ichar(string(j:j))-ichar('A')+ichar('a'))
1     continue
      end
C
C----------------------------------------------------------------------C
C
      subroutine trim(string)
C ---- remove leading blanks from 'string' 
      character*(*)string
      integer i,ilen,iblank

      ilen=len(string)
      iblank=0
      do 1 i=1,ilen
         if (string(i:i) .ne. ' ') goto 2
1        if (string(i:i) .eq. ' ')iblank=iblank+1
2     if (iblank .ne. 0) then
         do 3 i=1,ilen-iblank
3           string(i:i)=string(i+iblank:i+iblank)
         string(ilen-iblank+1:ilen)=' '
      endif
      end
C
C----------------------------------------------------------------------
C
      integer function leng(string)
C     returns significant length of  'string'
      character*(*)string

      do 1 leng=len(string),0,-1
1        if (string(leng:leng) .ne. ' ') goto 2
2     end
C
C----------------------------------------------------------------------C
C
      subroutine parse(line,j,npos,length)
C ---- given a line of input, returns number of fields,
C ---- beginning and length of each field
      character line(148)
      dimension npos(20),length(20)

      j=0
      i=1
1     i=i+1
      if (i .gt. 145) return
      if (line(i) .eq. ' ') goto 1
      j=j+1
      if (j .gt. 20) then
         j=20
         return
      endif
      npos(j)=i
      if (line(i) .eq. ',') goto 3
2     i=i+1
      if (i .gt. 145) goto 3
      if (line(i) .ne. ' ' .and. line(i) .ne. ',') goto 2
3     length(j)=min(20,i-npos(j))
      goto 1
      end
C
C----------------------------------------------------------------------C
C
      subroutine aformt(line,istart,length,value)
C ---- packs a character string of given field-position & width
      character*8 value
      character*20 vbuf
      character*80 spec
      character buf(20),line(148)
      equivalence (buf(1),vbuf)

      if (length .eq. 0) return
      if (length .gt. 8) goto 2
      do 1 i=istart,istart+length-1
1        buf(i-istart+1)=line(i)
      write (spec,10)length
10    format ('(a',        i1,')')
      read (vbuf,spec,err=2)value
      return
2     write (*,11)istart-1,(line(i),i=2,145)
11    format (' I can''t read field starting at character',i4,' in this
     & line:'/(1x,72a1))
      value=' '
      return
      end
C
C----------------------------------------------------------------------C
C
      subroutine fformt(line,istart,length,value)
C ---- decodes a floating-point number of given field-position & width
      character line(148),buf(20)
      character*20 vbuf
      character*80 spec
      equivalence (buf(1),vbuf)

      if (length .eq. 0) return
      do 1 i=istart,istart+length-1
1        buf(i-istart+1)=line(i)
      width=length
      write (spec,10)width
10    format ('(f',        f4.1,')')
      read (vbuf,spec,err=2)value
      return
2     write (*,11)istart-1,(line(i),i=2,145)
11    format (' I can''t read field starting at character',i4,' in this
     & line:'/(1x,72a1))
      return
      end
C
C----------------------------------------------------------------------C
C
      subroutine iformt(line,istart,length,ivalue)
C -----  decodes an integer of given field-position & width
      character line(148),buf(20)
      character*20 vbuf
      character*80 spec
      equivalence (buf(1),vbuf)

      if (length .eq. 0) return
      do 1 i=istart,istart+length-1
1        buf(i-istart+1)=line(i)
      write (spec,10)length
10    format ('(i',        i2,  ')')
      read (vbuf,spec,err=2)ivalue
      return
2     write (*,11)istart-1,(line(i),i=2,145)
11    format (' I can''t read field starting at character',i4,' in this
     & line:'/(1x,72a1))
      return
      end
C
C----------------------------------------------------------------------C
C
      subroutine ctbxinit()
      include 'ciftbx.sys'

      do i=1,NUMDICT
        dcindex(i)=0
      enddo
      end

C
C COMPILER SPECIFIC - comment out if compiling on a Unix system
C
C      subroutine getenv(stringa,stringb)
C      character*(*) stringa, stringb
C
C      stringb = ' '
C      call dosparam@(stringa,stringb)
C      end
        
      include 'ciftbx.f'
