C**********************************************************************C
C                                                                      C
C  Program CIF2SX  will take as input a legal CIF file and output      C
C  a legal SHELXL93 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 CIFDIC.C91 should be present in     C
C  the specified directory "cif$dir" 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=300)                                               C
C                                                                      C
C**********************************************************************C
C  Copyright June 1997: Louis J. Farrugia, University of Glasgow       C
C                                                                      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
     1 (*,'('' Enter name of CIF (extension .CIF assumed) :'',$)')
      read (*,'(a)')fname1
      if (fname1 .eq. ' ') goto 1
      call locase(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: CIFDIC.C91 . 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=300)
      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,name1*32,sgname*32,title*80
      character chemfm*80,atwnt(3)*32,aniwnt(6)*32
      character cif$dir*80,cifdic*80
      real sdev,dum,uij2(6),fnamtp(30)
      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),
     1 uij(6,ndim),wavel,cell(6),ecell(6),r(96,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=' '
      name1=' '
      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. 

      cif$dir=' '

C   WARNING WARNING WARNING WARNING WARNING WARNING WARNING
C
      call sxinit
      f1=init_(21,22,23,6)
      if(.not.lcheck) goto 110
      write (*,'(/'' Loading the CIF dictionary. Please wait.....'')')
      ilen=leng(cif$dir)
      cifdic=cif$dir(1:ilen)//'cifdic.c91'
      call trim(cifdic)
      if (dict_(cifdic,'valid')) goto 110
      call prstr(' CIF dictionary CIFDIC.C91 not found. No checks.')
110   write (*,'(/'' Reading data from '',a,/)')fname
      f1=open_(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]:'',$)')
     1 bloc_(1:ilen)
      read (*,'(a)')ans
      call upcase(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 (*,
     1  '('' 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   '',i2,6x,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 (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 upcase(label2)
      call locase(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,'': ''))')
     1   (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
     1   (' :: 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 
     1will 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 upcase(label(iatom))
      call locase(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
      f1=numb_('_atom_site_occupancy',sof(iatom),sdev)
      if (f1) then
         sof(iatom)=10.0+sof(iatom)
      else
         sof(iatom)=11.0
      endif
      f1=numb_('_atom_site_U_iso_or_equiv',uij(1,iatom),sdev)
      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 upcase(label2)
      call locase(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))
     1   +abs(uij(6,i))
         if (sum .gt. 0.0) then
            write (25,'(a4,3x,i2,6f10.5,a2,/,5x,4f10.5)')
     1      label(i),nftype(i),p(1,i),p(2,i),p(3,i),sof(i),(uij(j,i),
     1       j=1,2),' =',(uij(j,i),j=3,6)
         else
            write (25,'(a4,3x,i2,5f10.5)')
     1      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 upcase(infile)
      write (*,'(/'' >> SHELX format file '',a,'' written.'')')
     1 infile
      goto 127
      end
C
C----------------------------------------------------------------------C
C
      integer function getltype(name)
C --- returns SHELXL lattice number from space group symbol 
      parameter (ndim=300)
      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),
     1 uij(6,ndim),wavel,cell(6),ecell(6),r(96,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 upcase(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
     1    .and. diffd .le. tol2 .and. diffe .le. tol2 .and. difff .le.
     1    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 upcase(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=300)
      character line(148)
      integer firstc(20),start
      logical semico,empty,fraction
      character*8 label,ftype
      common /cifmodc/label(ndim),ftype(30)
      common /cifmod/natom,nr,ntype,nftype(ndim),p(3,ndim),sof(ndim),
     1 uij(6,ndim),wavel,cell(6),ecell(6),r(96,3,4),contnt(30),iz
      ierr=0
      fraction=.false.
      tol=1.0e-10
      do i=2,73
         if (line(i) .eq. '/')fraction=.true.
      enddo
      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),
     1   semico,empty,fraction)
         if (.not. empty) goto 12
         nr=nr-1
         return
12       if (.not. ((semico .and. i .ne. 3) .or.
     1              (.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,fraction)
C
C ---- Interprets symmetry character string. Either decimal or
C ---- fractions may be used for translations.
C
      parameter (ndim=300)
      character line(148),chara,digit(11),charb(148),label*8,ftype*8
      integer sig
      real number
      logical first,termin,empty,fraction
      common /cifmodc/label(ndim),ftype(30)
      common /cifmod/natom,nr,ntype,nftype(ndim),p(3,ndim),sof(ndim),
     1 uij(6,ndim),wavel,cell(6),ecell(6),r(96,3,4),contnt(30),iz
      data digit/'1','2','3','4','5','6','7','8','9','0','.'/,
     1 charb/148*' '/
      idigit=11
c      if (fraction)idigit=10
      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
c      if (fraction .and. (chara .eq. '/')) goto 15
      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. ';') 
     1 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 upcase(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=300)
      character*8 label,ftype
      common /cifmodc/label(ndim),ftype(30)
      common /cifmod/natom,nr,ntype,nftype(ndim),p(3,ndim),sof(ndim),
     1 uij(6,ndim),wavel,cell(6),ecell(6),r(96,3,4),contnt(30),iz
      iz=1
      wavel=0.71073
      extnct=0.0
      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=300)
      character line(66)
      integer start,iset(96)
      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),
     1 uij(6,ndim),wavel,cell(6),ecell(6),r(96,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,96
         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
C ljffix - 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
      do i=1,3
         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
            goto 1
         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
     1 '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
     1 '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
     1 'GA','GD','GE','H ','HE','HF','HG','HO','I ','IN','IR',
C       35   36   37    38   39   40   41   42    43   44   45
     1 'K ','KR','KU','LA','LI','LU','LW','MD','MG','MN','MO',
C       46   47   48    49   50   51   52    53   54   55   56
     1 'N ','NA','NB','ND','NE','NI','NO','NP','O ','OS',
C       57   58   59   60   61   62   63   64    65   66
     1 '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
     1 '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
     1 'TA','TB','TC','TE','TH','TI','TL','TM','U ','V ','W ',
C       91   92   93   94   95   96   97   98    99   100    101
     1 '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)))
     1   goto 1
         if (chemfm(i:i) .eq. ' ' .and. chemfm(i+1:i+1) .eq. ' ')
     1   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))-
     1         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 upcase(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'))
     1   string(j:j)=char(ichar(string(j:j))-ichar('a')+ichar('A'))
1     continue
      end
C
C----------------------------------------------------------------------C
C
      subroutine locase(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'))
     1   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
     1 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
     1 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
     1 line:'/(1x,72a1))
      return
      end

C    -------------- LJF modified version of CIFTBX1 ------------------------
C
C
C                  CIFtbx README FIRST Information
C                  -------------------------------
C                    (Version July 17 1994)
C          
C    This file contains the complete set of source decks and test data
C       needed to implement and test the CIFtbx Tool Box routines.
C
C           
C       (a) compile 'CIFwrite.f' [note that provided the fortran "include" 
C           function is available to you, the files 'ciftbx.f', 'ciftbx.sys'
C           and 'ciftbx.cmn' will be automatically opened and processed by
C           this single operation]
C
C       (b) link 'tbx_ex.o' as the executable file 'tbx_ex.x'
C
C       (c) execute 'CIFwrite.x' so that the input file is connected
C           to device 5 (stdin) and the list file is connected to
C           device 6 (stdout). The input CIF and the output CIF
C           will be automatically opened.
C
C       (d) if you have any problems with this process please report them to
C           Syd Hall [em: syd@crystal.uwa.edu.au  fx: 61(9)3801118].
C 
C    4. You are now ready to implement CIFtbx for your software applications.
C       Note that it more efficient to compile 'ciftbx.f' separately and add
C       'ciftbx.o' at link time. Note that the line "include 'ciftbx.cmn'"
C       MUST appear at the start of any routine invoking the CIFtbx commands.
C
C
C-------------------------cut here------------------------------------------
C           
C
C    \ | /            /##|    @@@@  @   @@@@@    |      | 
C     \|/ STAR       /###|   @      @   @      __|__    |
C  ----*----        /####|  @       @   @@@@     |      |___  __  __   
C     /|\          /#####|   @      @   @        |      |   \   \/    
C    / | \         |#####|    @@@@  @   @        \___/  \___/ __/\__ 
C                  |#####|________________________________________________ 
C                 ||#####|                 ___________________            |
C        __/|_____||#####|________________|&&&&&&&&&&&&&&&&&&&||          | 
C<\\\\\\\\_ |_____________________________|&&&& Jul 17 94 &&&&||          |
C          \|     ||#####|________________|&&&&&&&&&&&&&&&&&&&||__________|  
C                  |#####|
C                  |#####|
C                  |#####|
C                 /#######\ 
C                |#########|
C                    ====
C                     ||
C           A tool box of fortran routines for manipulating CIF data.
C                     ||
C                     ||
C The latest program source and information is available from:
C                     ||
C Em: syd@crystal.uwa.edu.au       ,-_|\      Sydney R. Hall
C sendcif@crystal.uwa.edu.au      /     \     Crystallography Centre
C Fx: +61 9 380 1118  ||      --> *_,-._/     University of Western Australia
C Ph: +61 9 380 2725  ||               v      Nedlands 6009, AUSTRALIA
C                     ||
C_____________________||_____________________________________________________
C                     
C
C    GENERAL TOOLS
C
C
C    init_      Sets the device numbers of files.   (optional)
C               [logical function always returned .true.]
C
C               <input CIF dev number> Set input CIF device     (def=1)
C
C               <output CIF dev number>Set output CIF device    (def=2)
C
C               <diracc dev number>    Set direct access formatted
C                                      scratch device number    (def=3)
C
C               <error  dev number>    Set error message device (def=6)
C
C
C
C    dict_      Requests a CIF dictionary be used for various data checks.
C               [logical function returned as .true. is the name dictionary
C                was opened; and if the check codes are recognisable.]
C
C               <dictionary filename>  A CIF dictionary in DDL format
C
C               <check code string>    The codes specifying the types of 
C                                      checks to be applied to the CIF.
C
C                                      'valid'  data name validation check.
C                                      'dtype'  data item data type check.
C
C___________________________________________________________________________
C
C
C   CIF ACCESS TOOLS  ("the get_ing commands")
C
C
C
C    open_      Opens the CIF containing the required data.
C               [logical function returned .true. if CIF opened]
C
C               <CIF filename>
C
C
C
C    data_      Identifies the data block containing the data to be requested. 
C               [logical function returned .true. if block found]
C
C               <data block name>     A blank name signals that the next
C                                     encountered block is used (the block
C                                     name is stored in the variable bloc_).
C
C
C
C    test_      Identify the data attributes of the named data item.
C               [logical function returned as .true. if the item is present or
C               .false. if it is not. The data attributes are stored in the
C               the common variables type_ and list_. 
C
C               list_ is an integer variable containing the sequential number
C               of the loop block in the data block. If the item is not within
C               a loop structure this value will be zero.
C
C               type_ is a character*4 variable with the possible values:
C                      'numb'  for number data
C                      'char'  for character data
C                      'text'  for text data
C                      'null'  if data missing or '?']
C
C               <data name>           Name of the data item to be tested.
C
C
C
C    name_      Get the next data name in the current data block.
C               [logical function returned as .true. if a new data name exists
C               in the current data block, and .false. when the end of the data
C               block is reached.]
C
C               <data name>           Returned name of next data item in block.
C
C
C
C    numb_      Extracts the number and its standard deviation (if appended).
C               [logical function returned as .true. if number present. If
C                .false. arguments 2 and 3 are unaltered. If the esd is not
C                attached to the number argument 3 is unaltered.]
C
C               <data name>           Name of the number sought.
C
C               <real variable>       Returned number.
C
C               <real variable>       Returned standard deviation.
C
C
C
C    char_      Extracts character and text strings.
C               [logical function returned as .true. if the string is present.
C                Note that if the character string is text this function is 
C                called repeatedly until the logical variable text_ is .false.]
C
C               <data name>           Name of the string sought.
C
C               <character variable>  Returned string is of length long_.
C
C
C____________________________________________________________________________
C
C
C
C   CIF CREATION TOOLS ("the put_ing commands")
C
C
C
C    pfile_     Create a file with the specified file name.
C               [logical function returned as .true. if the file is opened.
C                The value will be .false. if the file already exists.]
C
C               <file name>
C
C
C
C    pdata_     Put a data block command into the created CIF. 
C               [logical function returned as .true. if the block is created.
C                The value will be .false. if the block name already exists.]
C
C               <block name>
C
C
C
C    ploop_     Put a loop_ data name into the created CIF.             
C               [logical function returned as .true. if the invocation 
C                conforms with the CIF logical structure.]
C
C               <data name>
C
C
C
C    pchar_     Put a character string into the created CIF.             
C               [logical function returned as .true. if the name is unique,
C                AND, if dict_ is invoked, is a name defined in the dictionary, 
C                AND, if the invocation conforms to the CIF logical structure.]
C
C               <data name>         If the name is blank, do not output name.
C
C               <character string>  A character string of 80 chars or less.
C
C
C
C    pnumb_     Put a number and its esd into the created CIF.             
C               [logical function returned as .true. if the name is unique,
C                AND, if dict_ is invoked, is a name defined in the dictionary, 
C                AND, if the invocation conforms to the CIF logical structure.]
C
C               <data name>         If the name is blank, do not output name.
C
C               <real variable>     Number to be inserted.
C
C               <real variable>     Esd number to be appended in parentheses.
C
C
C
C    ptext_     Put a character string into the created CIF.             
C               [logical function returned as .true. if the name is unique,
C                AND, if dict_ is invoked, is a name defined in the dictionary, 
C                AND, if the invocation conforms to the CIF logical structure.]
C                ptext_ is invoked repeatedly until the text is finished. Only
C                the first invocation will insert a data name.
C
C               <data name>         If the name is blank, do not output name.
C
C               <character string>  A character string of 80 chars or less.
C
C
C
C    close_     Close the creation CIF. MUST be used if pfile_ is used.
C               [subroutine call]
C
C
C____________________________________________________________________________
C
C
C
C....The CIF tool box also provides variables for data access control:
C 
C
C    text_       Logical variable signals if another text line is present.
C
C    loop_       Logical variable signals if another loop packet is present.
C
C    bloc_       Character*32 variable: the current block name.
C
C    strg_       Character*80 variable: the current data item.
C
C    type_       Character*4 variable: the data type code (see test_).
C
C    list_       Integer variable: the loop block number (see test_).       
C
C    long_       Integer variable: the length of the data string in strg_.
C
C    file_       Character*80 variable: the filename of the current file.
C
C    longf_      Integer variable: the length of the filename in file_.
C
C    align_      Logical variable signals alignment of loop_ lists during
C                the creation of a CIF. The default is .true.
C
C
C_____________________________________________________________________________
C
C
C >>>>>> Set the device numbers.
C
         function init_(devcif,devout,devdir,deverr)
C
         include   'ciftbx.sys'
         logical   init_
         integer   devcif,devout,devdir,deverr
C
         init_=.true.
         cifdev=devcif
         outdev=devout
         dirdev=devdir
         errdev=deverr
         return
         end
C
C
C
C
C
C >>>>>> Read a CIF dictionary and prepare for checks
C
         function dict_(fname,checks)
C
         include   'ciftbx.sys'
         logical   dict_,data_,open_,char_
         character locase1*80
         character fname*(*),checks*(*)
         character temp*24,codes(4)*5,name*80
         integer   idict,i,j
         data codes /'valid','dtype','     ','     '/
C
C....... Open and store the dictionary
C
         if(nname.gt.0) call err(' dict_ must precede open_')
         dict_=open_(fname)
         if(.not.dict_)              goto 500
         dictfl='yes'
C
C....... Are the codes OK
C
         temp=checks
         i=0         
120      i=i+1
         if(i.ge.24)                 goto 200
         if(temp(i:i).eq.' ')        goto 120
         do 150 j=1,4
         if(temp(i:i+4).eq.codes(j)) goto 170
150      continue
         dict_=.false.
         goto 500
170      i=i+4
         if(j.eq.1) vcheck='yes'
         if(j.eq.2) tcheck='yes'
         goto 120
C
C....... Loop over data blocks; extract _name's, _type etc.
C
200      if(.not.data_(' '))         goto 400
         idict=ndict+1
Cdbg     WRITE(6,*) ndict,bloc_
C
250      if(.not.char_('_name',name))goto 200
         ndict=ndict+1
         if(ndict.gt.1000) call err(' cifdic names > 1000')
         dicnam(ndict)=locase1(name(1:long_))
         if(loop_)                   goto 250
C
         if(tcheck.eq.'no ')         goto 200
         if(.not.char_('_type',name))call err(' _type line missing')
         do 270 i=idict,ndict
270      dictyp(i)=name(1:4)
         goto 200
C
400      close(dirdev)
         if(tcheck.eq.'yes') vcheck='yes'
         dictfl='no '
Cdbg     WRITE(6,'(i5,3x,a,2x,a)') (i,dicnam(i),dictyp(i),i=1,ndict)
500      return
         end
C
C
C
C
C
C >>>>>> Open a CIF and copy its contents into a direct access file.
C
         function open_(fname)
C
         include   'ciftbx.sys'
         logical   open_,test
         character fname*(*)
         integer   case,i
C
         jchar=80
         nrecd=0
         lrecd=0
         case=ichar('a')-ichar('A')
         tab=char(05)
         if(case.lt.0) goto 100
         tab=char(09)
C
C....... Make sure the CIF is available to open
C
100      file_=fname
         do 120 i=1,80
         if(file_(i:i).eq.' ') goto 140
120      continue
140      longf_=i-1
         inquire(file=file_(1:longf_),exist=test)
         open_=test
         if(.not.open_)         goto 200
C
C....... Open up the CIF and a direct access formatted file as scratch
C
         open(unit=cifdev,file=fname,status='old',access='sequential',
     *                    form='formatted')
         open(unit=dirdev,status='scratch',access='direct',
     *                    form='formatted',recl=80)
C
C....... Copy the CIF to the direct access file
C
160      read(cifdev,'(a)',end=180) buffer
         nrecd=nrecd+1
         write(dirdev,'(a)',rec=nrecd) buffer
Cdbg     WRITE(6,'(i5,1x,a)') nrecd,buffer(1:70)
         goto 160
C
180      lrecd=0
         close(cifdev)
200      return
         end
C
C
C
C
C
C >>>>>> Store the data names and pointers for the requested data block
C
         function data_(name) 
C
         include   'ciftbx.sys'
         logical   data_
         character name*(*),flag*4,temp*32,ltype*4
         character locase1*80
         integer   ndata,idata,nitem,npakt,i,j
C
         jchar=80
         jrecd=0
         nname=0
         ndata=0
         nitem=0
         idata=0
         iname=0
         loopct=0
         loopnl=0
         ltype=' '
         data_=.false.
         loop_=.false.
         text_=.false.
         irecd=lrecd
         lrecd=nrecd
         if(name(1:1).ne.' ') irecd=0
C
C....... Find the requested data block in the file
C
100      call getstr
         if(type_.eq.'fini')           goto 500
         if(type_.ne.'text')           goto 120
110      call getlin(flag)       
         if(buffer(1:1).ne.';')       goto 110
         call getlin(flag)
         goto 100
120      if(type_.ne.'data')           goto 100
         if(name.eq.' ')              goto 150
c ljffix
         if(long_ .lt. 6) call err('Error in data_ statement')
         
         if(strg_(6:long_).ne.name)   goto 100
150      data_=.true.
c ljffix
         if(long_ .lt. 6) call err('Error in data_ statement')

         bloc_=strg_(6:long_)
C
C....... Get the next token and identify
C
200      call getstr
Cdbg     WRITE(6,*) ltype,type_,loop_,nitem,ndata,idata,irecd,lrecd
C
         if(ltype.ne.'name')               goto 201
         if(type_.eq.'numb')                goto 203
         if(type_.eq.'char')                goto 203
         if(type_.eq.'text')                goto 203
         if(type_.eq.'name'.and.loop_)      goto 204
         call err(' Illegal tag/value construction')
201      if(ltype.ne.'valu')               goto 204
         if(type_.eq.'numb')                goto 202
         if(type_.eq.'char')                goto 202
         if(type_.eq.'text')                goto 202
         goto 204
202      if(nitem.gt.0)                    goto 205
         call err(' Illegal tag/value construction')
203      ltype='valu'
         goto 205
204      ltype=type_
C
205      if(type_.eq.'name')           goto 206
         if(type_.eq.'loop')           goto 210
         if(type_.eq.'data')           goto 210
         if(type_.ne.'fini')           goto 220
206      if(loop_)                    goto 270
210      if(nitem.eq.0)               goto 215
C
C....... End of loop detected; save pointers
C
         npakt=idata/nitem
         if(npakt*nitem.ne.idata) call err(' Item miscount in loop')
         loopni(loopct)=nitem
         loopnp(loopct)=npakt
         nitem=0
         idata=0
215      if(type_.eq.'name')           goto 270
         if(type_.eq.'data')           goto 300
         if(type_.eq.'fini')           goto 300
C
C....... Loop_ line detected; incr loop block counter
C
         loop_=.true.
         loopct=loopct+1
         if(loopct.gt.50) call err(' Number of loop_s > 50')
         goto 200
C
C....... This is the data item; store char position and length
C
220      loop_=.false.
         if(nitem.gt.0) idata=idata+1
         if(nname.eq.ndata)           goto 230
         ndata=ndata+1
         if(iloop(ndata).gt.1)        goto 225
         krecd=irecd
         kchar=jchar-long_-1
225      dtype(ndata)=type_
         drecd(ndata)=krecd
         dchar(ndata)=kchar
         if(nloop(ndata).gt.0)        goto 230
         nloop(ndata)=0
         iloop(ndata)=long_
C
C....... Skip text lines if present
C
230      if(type_.ne.'text')           goto 200
         dchar(ndata)=0
         if(nloop(ndata).eq.0) iloop(ndata)=80
250      call getlin(flag)
         if(buffer(1:1).eq.';')       goto 200
         if(flag.eq.'fini') call err(' Unexpected end of data')
         goto 250
C
C....... This is a data name; store name and loop parameters
C
270      nname=nname+1
         if(nname.gt.500) call err(' Number of data names > 500')
         dname(nname)=locase1(strg_(1:long_))
         lloop(nname)=0
         nloop(nname)=0
         iloop(nname)=0
         if(.not.loop_)               goto 200
         nitem=nitem+1
         if(nitem.gt.20) call err(' Items per loop packet > 20')
         nloop(nname)=loopct
         iloop(nname)=nitem
         goto 200
C
C....... Are names checked against dictionary?
C
300      if(dictfl.eq.'yes')          goto 500
         if(vcheck.eq.'no ')          goto 500
C
         do 350 i=1,nname
         temp=dname(i)
         do 330 j=1,ndict
         if(temp.ne.dicnam(j))        goto 330
         if(tcheck.eq.'no ')          goto 350
         if(dtype(i).eq.dictyp(j))    goto 350
         write(errdev,'(2a,1x,2a)') ' Warning: type ',dtype(i),temp,
     *                        ' different to dictionary!'
         goto 350
330      continue
         write(errdev,'(3a)') ' Warning: data name ',temp,
     *                        ' not in dictionary!'
350      continue
C
C....... End of data block; tidy up loop storage
C
500      lrecd=irecd-1
         loop_=.false.
         loopct=0
         if(ndata.ne.nname) call err(' Syntax construction error')
C
Cdbg     WRITE(6,'(a)')
Cdbg *   ' data name                       type recd char loop leng'
Cdbg     WRITE(6,'(a,1x,a,4i5)') (dname(i),dtype(i),drecd(i),dchar(i),
Cdbg *              nloop(i),iloop(i),i=1,nname)
Cdbg     WRITE(6,'(3i5)') (i,loopni(i),loopnp(i),i=1,loopct)
C
         return
         end
C
C
C
C
C
C
C >>>>>> Get the attributes of data item associated with data name
C
         function test_(temp)
C
         include   'ciftbx.sys'
         logical    test_
         character  temp*(*),name*32
         character  locase1*80
C
         testfl='yes'
         name=locase1(temp)
         test_=.true.   
         if(testfl.eq.'no ')  goto 100
         if(name.eq.nametb)   goto 200
100      call getitm(name)        
200      list_ =loopnl
         if(type_.eq.'null') test_=.false.
         return
         end
C
C
C
C
C
C
C >>>>>> Get the next data name in the data block
C
         function name_(temp)              
C
         include   'ciftbx.sys'
         logical    name_
         character  temp*(*)
C
         name_=.false.
         temp=' '
         iname=iname+1
         if(iname.gt.nname)  goto 100
         name_=.true.
         temp=dname(iname)
100      return
         end
C
C
C
C
C
C
C >>>>>> Extract a number data item and its standard deviation
C
         function numb_(temp,numb,sdev)
C
         include   'ciftbx.sys'
         logical    numb_
         character  temp*(*),name*32
         character  locase1*80
         real       numb,sdev
C
         name=locase1(temp)
         if(testfl.eq.'no ')  goto 100
         if(name.eq.nametb)   goto 150
C
100      call getitm(name)
C
150      numb_=.false.
         if(type_.ne.'numb') goto 200
         numb_=.true.
         numb =numbtb
         if(sdevtb.ge.0.0) sdev=sdevtb
C
200      testfl='no '
         return
         end
C
C
C
C
C
C
C >>>>>> Extract a character data item.               
C
         function char_(temp,strg)          
C
         include   'ciftbx.sys'
         logical    char_
         character  temp*(*),name*32
         character  strg*(*),flag*4
         character  locase1*80
C
         name=locase1(temp)
         if(testfl.eq.'yes')    goto 100
         if(.not.text_)         goto 120
100      if(name.eq.nametb)     goto 150
C
120      call getitm(name)
C
150      char_=.true.
         text_=.false.
         strg=strg_(1:long_)
         if(type_.eq.'char')   goto 200
         char_=.false.
         if(type_.ne.'text')   goto 200
         char_=.true.
         call getlin(flag)
         if(buffer(1:1).eq.';') goto 200
         text_=.true. 
         strg_=buffer
C
200      testfl='no '
         return
         end
C
C
C
C
C
C >>>>> Convert name string to lower case
C        
         function locase1(name)
C
         include     'ciftbx.sys'
         character    locase1*80
         character    temp*80,name*(*)
         character    low*26,cap*26,c*1
         data  cap /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
         data  low /'abcdefghijklmnopqrstuvwxyz'/
C
         temp=name
         do 100 i=1,80
         c=temp(i:i)
         if(c.eq.' ') goto 200
         j=index(cap,c)
         if(j.ne.0) temp(i:i)=low(j:j)        
100      continue
200      locase1=temp
         return
         end
C
C
C
C
C
C >>>>>> Get the data item associated with the tag.
C
         subroutine getitm(name)
C
         include   'ciftbx.sys'
         SAVE
         character name*(*),lname(20)*32
         character fhash*3,flag*4
         integer   phash(20),ihash
         integer   loopch(21),loopln(21),looprd(21)
         integer   iitem,nitem,npakt
         integer   kchar,loopi,i
         data fhash/'no '/
C
C....... Find requested dataname in hash list
C
         nametb=name
         if(name(1:1).eq.'_')       goto 100
         type_='null'
         long_=1
         goto 1000
100      if(.not.loop_)             goto 150
         fhash='no '
         do 120 ihash=1,nhash
         if(lname(ihash).eq.nametb) goto 170
120      continue
         if(nhash.eq.20)            goto 150
         fhash='yes'
C
C....... Else find requested dataname in full list
C
150      do 160 iname=1,nname
         if(dname(iname).eq.nametb)  goto 180
160      continue
         type_='null'
         long_=1
         goto 1000
C
C....... Update the hash table if need be
C
170      iname=phash(ihash)
180      if(fhash.eq.'no ')         goto 190
         nhash=nhash+1
         phash(nhash)=iname
         lname(nhash)=name
190      if(nloop(iname).le.0)      goto 500
C
C....... Process loop packet if first item request
C
         if(nloop(iname).ne.loopnl) goto 200
         if(lloop(iname).lt.loopct) goto 300
         if(loop_)                 goto 230
200      loop_=.true.
         nhash=0
         loopct=0
         loopnl=nloop(iname)
         nitem=loopni(loopnl)
         npakt=loopnp(loopnl)
         irecd=drecd(iname)-1
         call getlin(flag)
         jchar=max(0,dchar(iname)-1)
C error          jchar=dchar(iname)-1
Cdbg     if(jchar.lt.0) write(6,'(" dchar ",i5)') jchar
         do 220 i=1,nname
220      lloop(i)=0
         goto 240
C
C....... Read a packet of loop items
C
230      irecd=looprd(nitem+1)-1
         call getlin(flag)
         jchar=loopch(nitem+1)
Cdbg     if(jchar.lt.0) write(6,'(" loopch",i5)') jchar
240      iitem=0
250      iitem=iitem+1
         if(iitem.le.nitem)     goto 255
         loopch(iitem)=jchar
         looprd(iitem)=irecd
         goto 270
255      call getstr
         loopch(iitem)=jchar-long_
         loopln(iitem)=long_
         looprd(iitem)=irecd
         if(type_.ne.'text')     goto 250
260      call getlin(flag)
         if(buffer(1:1).ne.';') goto 260
         call getlin(flag)
         goto 250
270      loopct=loopct+1
         if(loopct.lt.npakt)    goto 300
         loop_=.false.
C
C....... Point to the loop data item
C
300      lloop(iname)=lloop(iname)+1
         loopi=iloop(iname)
         irecd=looprd(loopi)-1
         call getlin(flag)
         long_=loopln(loopi)
         kchar=loopch(loopi)
         goto 550
C
C....... Point to the non-loop data item
C
500      irecd=drecd(iname)-1
         call getlin(flag)
         kchar=dchar(iname)+1
         long_=iloop(iname)
         loop_=.false.
         loopct=0
         loopnl=0
C
C....... Place data item into variable string and make number
C
550      type_=dtype(iname)
         strg_(1:long_)=buffer(kchar:kchar+long_-1)
         if(type_.eq.'numb') call ctonum
         if(type_.eq.'text') strg_(1:1)=' '
         if(long_.eq.1.and.strg_(1:1).eq.'?') type_='null'
C
1000     return
         end
C
C
C
C
C
C
C
C >>>>>> Read the next string from the file
C
         subroutine getstr
C
         include   'ciftbx.sys'
         integer   i
         character c*1,num*13,flag*4
         data num/'0123456789+-.'/
C
100      jchar=jchar+1
         if(jchar.le.80)     goto 150
C
C....... Read a new line
C
110      call getlin(flag)
         type_='fini'
         if(flag.eq.'fini')  goto 500
C
C....... Test if the new line is the start of a text sequence
C
         if(buffer(1:1).ne.';') goto 150
         type_='text'
         jchar=81
         long_=80
         goto 500
C
C....... Process this character in the line
C
150      c=buffer(jchar:jchar)
         if(c.eq.' ')       goto 100
         if(c.eq.tab)       goto 100
         if(c.eq.'#')       goto 110
         if(c.eq.'''')      goto 300
         if(c.eq.'"')       goto 300
         if(c.ne.'_')       goto 200
         type_='name'
         goto 210
C
C....... Test if the start of a number or a character string
C
200      type_='numb'
         if(index(num,c).eq.0) type_='char'
210      do 250 i=jchar,80
         if(buffer(i:i).eq.' ')       goto 400
         if(buffer(i:i).eq.tab)       goto 400
250      continue
         i=81
         goto 400
C
C....... Span quoted character string
C
300      type_='char'
         jchar=jchar+1
         do 320 i=jchar,80
         if(buffer(i:i).eq.c)         goto 400
320      continue
         call err('Quoted string not closed')
C
C....... Store the string for the getter
C
400      long_=i-jchar
         strg_(1:long_)=buffer(jchar:i-1)
         jchar=i
Cdbg     if(jchar.lt.0) write(6,'(" i     ",i5)') jchar
         if(type_.ne.'char') goto 500
         if(strg_(1:5).eq.'data_') type_='data'
         if(strg_(1:5).eq.'loop_') type_='loop'
C
500      return
         end
C
C
C
C
C
C
C >>>>>> Convert a character string into a number and its esd
C
C           number string        -xxxx.xxxx+xxx(x)
C           component count CCNT 11111222223333444
C
         subroutine ctonum
C
         include   'ciftbx.sys'
         character test*15,c*1
         integer*4 m,nchar
         integer*4 ccnt,mant,expn,msin,esin,ndec
         real      numb,sdev
         data test /'0123456789+.-()'/
C
         numbtb=0.
         sdevtb=-1.
         numb=1.
         sdev=0. 
         ccnt=0
         mant=0
         expn=0.
         msin=+1
         esin=+1
         ndec=0
         type_='char'
C
C....... Loop over the string and identify components
C
         do 400 nchar=1,long_
C
         c=strg_(nchar:nchar)
         m=index(test,c)
         if(m.eq.0)     goto 500
         if(m.gt.10)    goto 300
C
C....... Process the digits
C
         if(ccnt.eq.0)  ccnt=1
         if(ccnt.eq.2)  ndec=ndec+1
         if(ccnt.gt.2)  goto 220
         mant=mant*10+m-1
         goto 400
220      if(ccnt.gt.3)  goto 240
         expn=expn*10+m-1
         goto 400
240      sdev=sdev*10.+float(m-1)
         sdevtb=1.
         goto 400
C
C....... Process the characters    . + - ( ) E D
C
300      if(c.ne.'.')  goto 320
         if(ccnt.gt.1) goto 500
         ccnt=2
         goto 400
C
320      if(c.ne.'(')  goto 340
         ccnt=4
         goto 400
C
340      if(c.eq.'E') m=10
         if(c.eq.'D') m=10
         if(ccnt.eq.3) goto 500
         if(ccnt.gt.0) goto 360
         ccnt=1
         msin=12-m
         goto 400
360      ccnt=3
         esin=12-m
C
400      continue
C
C....... String parsed; construct the numbers
C
         expn=expn*esin-ndec
         if(abs(expn).gt.21) expn=sign(21,expn)
         if(expn.lt.0) numb=1./10.**abs(expn)
         if(expn.gt.0) numb=10.**expn
         if(sdevtb.gt.0.0) sdevtb=numb*sdev
         numbtb=numb*float(mant*msin)
         type_='numb'
C
500      return
         end
C
C
C
C
C
C
C >>>>>> Read a new line from the direct access file
C
         subroutine getlin(flag)
C
         include   'ciftbx.sys'
         character flag*4
C
         irecd=irecd+1
         if(irecd.eq.jrecd)  goto 200
         if(irecd.le.lrecd)  goto 100
         flag='fini'
         goto 200
100      read(dirdev,'(a)',rec=irecd) buffer
         jchar=1
         jrecd=irecd
         flag=' '
200      return
         end
C
C
C
C
C
C
C >>>>>> Write error message and exit.
C
         subroutine err(mess)
C
         include   'ciftbx.sys'
         character mess*(*)
C
         ilen=leng(bloc_)
         write(errdev,'(5a,i5)') ' CIFTBX error in  ',
     *   file_(1:longf_),'  data_',bloc_(1:ilen),'    line',irecd
         write(errdev,'(1X,a)') mess  
         stop
         end
C
C
C
C
C >>>>>> Create a named file.
C
         function pfile_(fname)
C
         include   'ciftbx.sys'
         logical   pfile_,test
         integer   i
         character fname*(*)
C
C....... Test if a file by this name is already open.
C
         if(pfilef.eq.'yes') call close_
         pfilef='no '
         file_=fname
         do 120 i=1,80
         if(file_(i:i).eq.' ') goto 140
120      continue
140      inquire(file=file_(1:i-1),exist=test)
         pfile_=.false.
C
C  ljf change : open output cif as status "append" and remove line below
         if(test)              goto 200
C
C....... Open up a new CIF
C
         open(unit=outdev,file=fname,access='sequential'
     *                    ,form='formatted')
         pfile_=.true.  
         pfilef='yes'
         nbloc=0
200      return
         end
C
C
C
C
C
C >>>>>> Store a data block command in the CIF
C
         function pdata_(name) 
C
         include   'ciftbx.sys'
         logical   pdata_
         character name*(*),temp*32
         character dbloc(100)*32
         integer   i
C
         if(ploopn.gt.0)     call eoloop
         if(ptextf.eq.'yes') call eotext
C
C....... Check for duplicate data name
C
         temp=name
         pdata_=.false.
         do 120 i=1,nbloc
         if(temp.eq.dbloc(i))   goto 200
120      continue
C
C....... Save block name and put data_ statement
C
         nbloc=nbloc+1
         if(nbloc.le.100) dbloc(nbloc)=temp
         pchar=81
         temp='data_'//name
         call putstr(temp)         
         pchar=81
         call putstr(' ')          
         pdata_=.true.
C
200      return
         end
C
C
C
C
C
C
C >>>>>> Put a number into the CIF, perhaps with an esd appended
C
         function pnumb_(name,numb,sdev)
C
         include   'ciftbx.sys'
         logical    pnumb_,flag
         character  name*(*),temp*32
         real       numb,sdev
C
         pnumb_=.true.
         flag  =.true.
         temp=name
         if(ptextf.eq.'yes') call eotext
C
         if(name(1:1).eq.' ')   goto 120
         if(vcheck.eq.'no ')    goto 100
         call dcheck(temp,'numb',flag)
         pnumb_=flag
100      if(ploopn.gt.0)        call eoloop
         pchar=81
         call putstr(temp)
         pchar=35
C
120      ploopf='no '
         call putnum(numb,sdev)
         if(flag)               goto 150
         pchar=60
         call putstr('#< not in dictionary')
C
150      return
         end
C
C
C
C
C
C
C >>>>>> Put a character string into the CIF.
C
         function pchar_(name,string)      
C
         include   'ciftbx.sys'
         logical    pchar_,flag
         character  name*(*),temp*32,string*(*)
         character  line*80,strg*80
         integer    i,j
C
         pchar_=.true.
         flag  =.true.
         temp=name
         if(ptextf.eq.'yes') call eotext
C
         if(name(1:1).eq.' ')   goto 110
         if(vcheck.eq.'no ')    goto 100
         call dcheck(temp,'numb',flag)
         pchar_=flag
100      if(ploopn.gt.0)        call eoloop
         pchar=81
         call putstr(temp)
         pchar=35
C
110      ploopf='no '
         line=string
         do 120 i=80,2,-1
         if(line(i:i).ne.' ') goto 130
120      continue
130      do 140 j=i,1,-1
         if(line(j:j).eq.' ') goto 150
140      continue
         strg=line(1:i)
         goto 200
150      do 160 j=1,i
         if(line(j:j).eq.'''')goto 170
160      continue
         strg=''''//line(1:i)//''''
         goto 200
170      strg='"'//line(1:i)//'"'
C
200      call putstr(strg)   
         if(flag)               goto 250
         pchar=60
         call putstr('#< not in dictionary')
250      return
         end
C
C
C
C
C
C
C >>>>>> Put a text sequence into the CIF.
C
         function ptext_(name,string)      
C
         include   'ciftbx.sys'
         logical    ptext_,flag
         character  name*(*),temp*32,string*(*),store*32
         data store/'                                '/
C
         ptext_=.true.
         flag  =.true.
         ploopf='no '
         temp=name
         if(ptextf.eq.'no ')    goto 100
         if(temp.eq.store)      goto 150
         call eotext
C
100      if(name(1:1).ne.' ')   goto 110
         if(ptextf.eq.'yes')    goto 150
         goto 130
C
110      if(ploopn.gt.0)        call eoloop
         if(vcheck.eq.'no ')    goto 120
         call dcheck(name,'char',flag)
         ptext_=flag
120      pchar=81
         call putstr(temp)
         if(flag)               goto 130
         pchar=60
         call putstr('#< not in dictionary')
130      pchar=81
         call putstr(' ')
         ptextf='yes'
         store=temp
         write(outdev,'(a)') ';'
150      write(outdev,'(a)') string
         return
         end
C
C
C
C
C
C
C >>>>>> Put a loop_ data name into the CIF.
C
         function ploop_(name)      
C
         include   'ciftbx.sys'
         logical    ploop_,flag
C
C ljf change - increase size of temp by one to avoid truncation of
C              data name. Also only ONE leading blank added to temp
C
         character  name*(*),temp*33
C
         ploop_=.true.
         flag  =.true.
         if(ptextf.eq.'yes')    call eotext
         if(name(1:1).eq.' ')   goto 150
C
         temp=' '//name
         if(ploopf.eq.'no ')    call eoloop
         if(vcheck.eq.'no ')    goto 100
         call dcheck(name,'    ',flag)
         ploop_=flag
100      if(ploopn.gt.0)        goto 120
         ploopf='yes'
         pchar=81
         call putstr(' ')
         pchar=81
         call putstr('loop_')
         pchar=81
120      call putstr(temp)
         if(flag)               goto 130
         pchar=60
         call putstr('#< not in dictionary')
130      pchar=81
         ploopn=ploopn+1
C
150      return
         end
C
C
C
C
C
C
C >>>>>> Close the CIF
C
         subroutine close_
C
         include   'ciftbx.sys'
C
         if(ptextf.eq.'yes') call eotext
         if(ploopn.gt.0)     call eoloop
         pchar=81
         call putstr(' ')
         close(outdev)
         return
         end
C
C
C
C
C
C >>>>>> Put the string into the output CIF buffer 
C
         subroutine putstr(string)     
C
         include   'ciftbx.sys'
         SAVE
         character  string*(*),temp*80,obuf*80
         integer    ichar,i
         data       ichar /0/
C
         temp=string
         do 100 i=80,1,-1
         if(temp(i:i).ne.' ')   goto 110
100      continue
C
C....... Organise the output of loop_ items
C
110      if(i.eq.0)             goto 130
         if(ploopf.eq.'yes')    goto 130
         if(ploopn.eq.0)        goto 130
         ploopc=ploopc+1
         if(ploopc.le.ploopn)   goto 130
         ploopc=1
         if(.not.align_)        goto 130
         pchar=81
C
C....... Is the buffer full and needs flushing?
C
130      if(pchar.lt.ichar)     goto 140
         if(pchar+i.le.80)      goto 150
         pchar=1
140      if(ichar.gt.0) write(outdev,'(a)') obuf(1:ichar)
         obuf=' '
C
C....... Load the next item into the buffer
C
150      ichar=pchar+i
         if(i.eq.0)            goto 200
         obuf(pchar:ichar)=string(1:i)
         pchar=ichar+1
C
200      return
         end
C
C
C
C
C
C >>>>>> Convert the number and esd to string nnnn(m)
C
         subroutine putnum(numb,sdev)  
C
         include   'ciftbx.sys'
         character  string*60,digit*9,temp*20
         real       numb,sdev
         integer    i,j
         data       digit /'123456789'/
C
         write(string,'(2f30.10)') numb,sdev
         do 120 i=1,30
         if(string(i:i).ne.' ')            goto 140
120      continue
140      if(sdev.lt.0.0000001)             goto 240
C
C....... Numbers with standard deviations
C
         do 160 j=31,60
         if(index(digit,string(j:j)).gt.0) goto 200
160      continue
200      if(j.lt.50)              goto 220
         temp=string(i:j-30)//'('//string(j:j)//')'
         goto 300
220      temp=string(i:19)//'('//string(j:49)//')'
         goto 300
C
C....... Numbers without standard deviations
C
240      do 250 j=21,30
         if(string(j:j).ne.'0')            goto 260
250      continue
260      if(j.gt.26)                       goto 280
         temp=string(i:26)
         goto 300
280      temp=string(i:19)
C
C ljf change
300      call clean(temp)
         call putstr(temp)
         return
         end
C
C
C
C
C
C >>>>>> Check dictionary for data name validation    
C
         subroutine dcheck(name,type,flag)
C
         include   'ciftbx.sys'
         logical    flag
         character  name*(*),temp*32,type*4
         integer    i
C
         flag=.true.
         temp=name
         do 100 i=1,ndict
         if(temp.ne.dicnam(i))        goto 100
         if(tcheck.eq.'no ')          goto 200
         if(type.eq.dictyp(i))        goto 200
         goto 150
100      continue
150      flag=.false.
200      continue
         return
         end
C
C
C
C
C
C >>>>>> End of text string
C
         subroutine eotext
C
         include   'ciftbx.sys'
C
         ptextf='no '
         call putstr(';')
         pchar=80
         return
         end
C
C
C
C
C
C >>>>>> End of loop detected; check integrity and tidy up pointers
C
         subroutine eoloop
C
         include   'ciftbx.sys'
         integer   i
C
         if(ploopn.eq.0)          goto 200
         if(ploopn.eq.ploopc)     goto 200
         do 150 i=1,ploopc
150      call putstr('DUMMY')
         write(errdev,'(a)')    
     *         ' Missing: missing loop_ items set as DUMMY'
C
200      ploopc=0
         ploopn=0
         return
         end

C >>>>>> Set common default values

         block data ciftbx_init

         include   'ciftbx.sys'
C  ljf change - different default output units for IBM PC
         data cifdev /21/
         data outdev /22/
         data dirdev /23/
         data errdev /6/
         data loopct /0/
         data nhash  /0/
         data ndict  /0/
         data nname  /0/
         data nbloc  /0/
         data ploopn /0/
         data ploopc /0/
         data ploopf /'no '/
         data ptextf /'no '/
         data pfilef /'no '/
         data testfl /'no '/
         data vcheck /'no '/
         data tcheck /'no '/
         data align_ /.true./ 
         data text_  /.false./
         data loop_  /.false./
         end
C
C  ljf change
C
C ---- Extra routine (cosmetic) - removes trailing zeroes from real numbers
C ---- represented in character string.
         subroutine clean(string)
         character*20 string
         if(index(string,'.') .eq. 0) return 
         do 1 i=20,1,-1
         if(string(i:i) .ne. ' ' .and. string(i:i) .ne. '0') return
1        if(string(i:i) .eq. '0') string(i:i)=' '
         end

