C
C                  CIFtbx README FIRST Information
C                  -------------------------------
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    Here is the recommended procedure for implementing and testing CIFtbx.
C
C
C    1. Use your editor to separate the different parts of the file into
C       individual files in your workspace. Each part is partitioned by
C       a line containing "---cut here---". Use your editor to search for
C       these lines. Each part is carefully labelled and indicates the  
C       recommended filename for the separated file. On some machines
C       these filenames may need to be altered to suit the OS or compiler.
C
C       The partitions are as follows:
C
C       part    filename       description
C
C         1     ciftbx.f       CIFtbx fortran source
C         2     ciftbx.sys     CIFtbx common for inclusion into ciftbx.f
C         3     ciftbx.cmn     CIFtbx common for inclusion into applications
C         4     tbx_ex.f       example application used to test ciftbx.f
C         5     test.cif       example CIF used by tbx_ex.f
C         6     test.req       example request file used by tbx_ex.f
C         7     test.prt       print file output from tbx_ex.f run
C         8     test.out       CIF output by the tbx_ex.f run
C
C
C    2. Once you have separated out these files, list 'ciftbx.f' and 'tbx_ex.f'
C       in particular (all if possible!) and carefully read the descriptions
C       in the front of these files. Remember that 'tbx_ex.f' is only an
C       example of a CIF application -- it shows how some basic CIF operations
C       can be performed, but it is not necessarily sensible or typical of what 
C       an actual application would look like!
C
C
C    3. You are now ready to implement the tool box and the test application.
C       Here are the recommended steps for a unix system. Vary this according
C       to the requirements of your OS and compiler. ***Note*** to execute
C       the supplied example application 'tbx_ex.f' identically to the test
C       outputs supplied, a copy of the CIF Core Dictionary 'cifdic.C91' must
C       be present in your work area. If it is not the tests will proceed with
C       a warning message but no validations checks will occur. A copy of the
C       dictionary 'cifdic.C91' can be obtained from 'syd@crystal.uwa.edu.au'.
C
C
C       (a) compile 'tbx_ex.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 'tbx_ex.x' so that the input file is 'test.req' connected
C           to device 5 (stdin) and the list file 'test.lst' is connected to
C           device 6 (stdout). The input CIF 'test.cif' and the output CIF
C           'test.new' will be automatically opened. For a unix OS the command
C           will look like this: 'tbx_ex.x < test.req  > test.lst'
C
C       (d) to check that the test has been successful, compare the files that
C           you have generated 'test.lst' with the supplied 'test.prt', and 
C           'test.new' with 'test.out'. They should be identical.
C
C       (e) 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    \ | /            /##|    @@@@  @   @@@@@    |      | 
C     \|/ STAR       /###|   @      @   @      __|__    |
C  ----*----        /####|  @       @   @@@@     |      |___  __  __   
C     /|\          /#####|   @      @   @        |      |   \   \/    
C    / | \         |#####|    @@@@  @   @        \___/  \___/ __/\__ 
C                  |#####|________________________________________________ 
C                 ||#####|                 ___________________            |
C        __/|_____||#####|________________|&&&&&&&&&&&&&&&&&&&||          | 
C<\\\\\\\\_ |_____________________________|&&&& Sep 10 92 &&&&||          |
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 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)=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
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
         integer   ndata,idata,nitem,npakt
C
         jchar=80
         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
         if(strg_(6:long_).ne.name)   goto 100
150      data_=.true.
         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)=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
C
         testfl='yes'
         name=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
         real       numb,sdev
C
         name=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
C
         name=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 >>>>>> 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
         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=dchar(iname)-1
         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)
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'
         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
         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   m,nchar
         integer   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
         integer   jrecd
         data      jrecd/0/
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
         write(errdev,'(5a,i5)') ' ciftbx error in  ',
     *   file_(1:longf_),'  data_',bloc_,'  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
         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.
         if(test)              goto 200
C
C....... Open up a new CIF
C
         open(unit=outdev,file=fname,status='NEW',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
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
         character  name*(*),temp*32
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
300      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'
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
C
C
C
C
C
C >>>>>> Set common default values
C
         block data
C
         include   'ciftbx.sys'
         data cifdev /1/
         data outdev /2/
         data dirdev /3/
         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
C--------cut here------------------------------------------------------------
C           
C
C >>>>>> Common declararations 'ciftbx.sys'
C               
C        For inclusion in 'ciftbx.f'
C
C
C                                 Flag if test_ last called (yes/no )
         character testfl*3
C                                 Name of current data item
         character nametb*32
C                                 Tab character for this machine
         character tab*1
C                                 Character buffer for reading lines
         character buffer*80
C                                 Dictionary validation check
         character vcheck*3
C                                 Dictionary data type check
         character tcheck*3
C                                 Dictionary being processed flag
         character dictfl*3
C                                 Dictionary data names
         character dicnam(1000)*32
C                                 Dictionary data types
         character dictyp(1000)*4
C                                 Data names in data block
         character dname(500)*32
C                                 Data type of data item 
         character dtype(500)*4
C                                 Flag signalling output CIF open
         character pfilef*3
C                                 Flag signalling loop_ being loaded
         character ploopf*3
C                                 Flag signalling text being loaded
         character ptextf*3
C                                 Record number containing data item
         integer   drecd(500)
C                                 Character position of item in record
         integer   dchar(500)
C                                 Loop block number (0 for non-loop)
         integer   nloop(500)
C                                 Item count in loop packet
         integer   iloop(500)
C                                 Loop line counter; initially zero
         integer   lloop(500)
C                                 Number of items per packet in each loop
         integer   loopni(50)
C                                 Number of packets per loop    
         integer   loopnp(50)
C                                 Number of of items in current loop packet
         integer   ploopc
C                                 Number of of items in output loop packet
         integer   ploopn
C                                 Number of current loop block
         integer   loopnl
C                                 Count of packets in current loop
         integer   loopct
C                                 Number of data names in hash table 
         integer   nhash 
C                                 Number of data names in data block
         integer   nname
C                                 Current number of data name in block
         integer   iname
C                                 Number of dictionary names
         integer   ndict 
C                                 Number of records in CIF
         integer   nrecd
C                                 Record number of current line
         integer   irecd
C                                 Last record number of current block
         integer   lrecd
C                                 Character pointer of current input line
         integer   jchar
C                                 Character pointer of output CIF line
         integer   pchar
C                                 Number of data block names stored
         integer   nbloc
C                                 Device number of input CIF 
         integer   cifdev
C                                 Device number of direct access file
         integer   dirdev
C                                 Device number of error message file
         integer   errdev
C                                 Device number of output CIF
         integer   outdev
C                                 Returned number
         real      numbtb
C                                 Returned standard deviation
         real      sdevtb
C
         common/tbxc/ buffer,dname,dtype,tab,dicnam,dictyp,dictfl,
     *                nametb,testfl,vcheck,tcheck,
     *                pfilef,ploopf,ptextf
C
         common/tbxi/ nrecd,drecd,irecd,lrecd,dchar,ndict,outdev,
     *                nloop,iloop,lloop,loopct,loopni,loopnp,loopnl,
     *                nname,nhash,cifdev,dirdev,errdev,jchar,pchar,
     *                iname,ploopn,ploopc,nbloc
C
         common/tbxr/ numbtb,sdevtb
C
C
C
C                                 Align loop active flag (true/false)
         logical   align_
C                                 Text active flag (true/false)
         logical   text_
C                                 Loop active flag (true/false)
         logical   loop_
C                                 Length of current data item in strg_
         integer   long_
C                                 Loop block number of current item
         integer   list_
C                                 Length of current filename in file_
         integer   longf_
C                                 Name of current data block
         character bloc_*32
C                                 Character image of current data item
         character strg_*80
C                                 File name of current CIF
         character file_*80
C                                 Character function type_
         character type_*4
C
         common/tbuc/ strg_,bloc_,file_,type_
C
         common/tbui/ list_,long_,longf_
C
         common/tbul/ loop_,text_,align_
C
C
C--------cut here------------------------------------------------------------
C           
C
C >>>>>> Common declararations 'ciftbx.cmn'
C
C        For inclusion in user applications
C
C
C                                 Logical function init_
         logical   init_
C                                 Logical function dict_
         logical   dict_
C                                 Logical function open_
         logical   open_
C                                 Logical function data_
         logical   data_
C                                 Logical function name_
         logical   name_
C                                 Logical function numb_
         logical   numb_
C                                 Logical function char_
         logical   char_
C                                 Logical function pfile_
         logical   pfile_
C                                 Logical function pdata_
         logical   pdata_
C                                 Logical function pchar_
         logical   pchar_
C                                 Logical function pnumb_
         logical   pnumb_
C                                 Logical function ptext_
         logical   ptext_
C                                 Logical function ploop_
         logical   ploop_
C                                 Align loop active flag (true/false)
         logical   align_
C                                 Text active flag (true/false)
         logical   text_
C                                 Loop active flag (true/false)
         logical   loop_
C                                 Length of current data item in strg_
         integer   long_
C                                 Loop block number of current item    
         integer   list_
C                                 Length of current filename in file_
         integer   longf_
C                                 Name of current data block
         character bloc_*32
C                                 Character image of current data item
         character strg_*80
C                                 File name of current CIF
         character file_*80
C                                 Character function type_
         character type_*4
C
         common/tbuc/ strg_,bloc_,file_,type_
C
         common/tbui/ list_,long_,longf_
C
         common/tbul/ loop_,text_,align_
C
C
C--------cut here-------------------------------------------------------------
C           
C
C
C                     CIF Tool Box Application 'tbx_ex.f'
C                     ------------------------
C                       Version: Sept 10 1992
C
C
C     This file contains four separate examples of how to apply the
C     the CIF tool box 'CIFtbx'. These are simple software tools for 
C     accessing and creating data in CIF format. A description of the 
C     CIFtbx functions and user-accessible system variables is given 
C     at the start of the tool box source file 'ciftbx.f'.
C
C     A full description of a CIF is given in the paper Hall, Allen 
C     and Brown (1991) Acta Cryst. A47 pp655-685.
C
C     Communications about the application of the CIF tool box may be
C     directed to: Syd Hall fx:61(9)3801118 em:syd@crystal.uwa.edu.au
C
C     The examples shown below extract data from the supplied CIF 
C     'test.cif'. The third example reads a list of data requests from 
C     a supplied file 'test.req'. As distributed, 'tbx_ex.f' attaches
C     'test.cif' to device 1, a scratch direct access file to device 3
C     and the error message file to device 6 (i.e. stdout). The fourth
C     example creates a new CIF called 'test.new'. This output file is
C     attached to device 2. On some machines these may not be suitable
C     device numbers and they may be changed within the application 
C     with the init_ call. 
C
C     The print file for this application is assumed to be stdout (i.e.
C     device number 6). The dictionary checking option dict_ has been 
C     invoked in these examples. In this case the standard Core 
C     dictionary file 'cifdic.C91' has been used [note that other
C     dictionaries may be added by repetitive invocation of dict_]. If
C     it is not present a warning message will be issued and the run
C     will proceed without data name validation.
C
C
C     The user should note that most CIFtbx tools are logical functions.
C     If their invocation succeeds they are returned with value .true.
C     otherwise .false. This means that for each invocation the program
C     can take appropriate action. For example if a request to open_ a
C     specific CIF fails, the program can exit, or try another CIF. The
C     same philosophy applies to data_ and all CIFtbx functions. However,
C     if a function discovers a logical construction error in the CIF,   
C     the whole process will stop with an error message.
C
C
C
C     Note the following requirements for any CIFtbx application.
C
C....... The tool box fortran source file 'ciftbx.f' must be included
C        once in the application source (as shown below), OR the object 
C        file 'ciftbx.o' must be included in the link process.
C
         include       'ciftbx.f'
C
C
C....... The tool box common variable file 'ciftbx.cmn' must be present 
C        at the start of EACH routine using the CIFtbx functions.
C
         include       'ciftbx.cmn'
C
C
C
         logical       f1,f2,f3
         character*32  name
         character*80  line
         character*4   label(6)
         character*26  alpha
         real          cela,celb,celc,siga,sigb,sigc
         real          x,y,z,u,sx,sy,sz,su
         real          numb,sdev,dum
         real          xf(6),yf(6),zf(6),uij(6,6)
         integer       i,j,nsite
         data alpha    /'abcdefghijklmnopqrstuvwxyz'/
         data          cela,celb,celc,siga,sigb,sigc/6*0./
         data          x,y,z,u,sx,sy,sz,su/8*0./
         data          xf,yf,zf,uij/54*0./
C
C
C
C........................... Example 1 .......................................
C
C
C   This example illustrates how to extract non-loop and loop items.
C   Note carefully how the logical functions numb_ and char_ signal if
C   the request has been successful or not. Note how the logical variables
C   text_ and loop_ are used to control the text lines and the data loops.
C
C
C
C....... Assign the CIFtbx files 
C
         f1 = init_( 1, 2, 3, 6 )
C
C....... Request dictionary validation check
C
         if(dict_('cifdic.C91','valid'))  goto 100
         write(6,'(/a/)') ' Requested Core dictionary not present'
C
C....... Open the CIF to be accessed
C
100      name='test.cif'
         write(6,'(/2a/)')  ' Read data from CIF  ',name
         if(open_(name))      goto 120
         write(6,'(a///)')  ' >>>>>>>>> CIF cannot be opened'
         stop
C
C....... Assign the data block to be accessed
C
120      if(data_(' '))       goto 130
         write(6,'(/a/)')   ' >>>>>>> No data_ statement found'
         stop
130      write(6,'(/a,a/)') ' Access items in data block  ',bloc_
C
C
C....... Extract some cell dimensions; test all is OK
C
         f1 = numb_('_cell_length_a', cela, siga)
         f2 = numb_('_cell_length_b', celb, sigb)
         f3 = numb_('_cell_length_c', celc, sigc)
         if(.not.(f1.and.f2.and.f3)) 
     *   write(6,'(a)') ' Cell dimension(s) missing!'
         write(6,'(/a,3f10.4)') ' Cell ',cela,celb,celc
         write(6,'(a,3f10.4/)') '      ',siga,sigb,sigc
C
C
C....... Extract space group notation (expected char string)
C
         f1 = char_('_symmetry_space_group_name_Hall', name)
         write(6,'(a,a/)') ' Space group   ',name(1:long_)
C
C
C....... Get the next name in the CIF and print it out         
C
         f1 = name_(name)
         write(6,'(a,a/)') ' Next data name in CIF is   ',name
C
C
C....... List the audit record (possible text line sequence)
C
         write(6,'(a/)') ' Audit record'
140      f1 = char_('_audit_update_record', line)
         write(6,'(a)') line
         if(text_)  goto 140
C
C
C....... Extract atom site data in a loop
C
         write(6,'(/a/)') ' Atom sites'
160      f1 = char_('_atom_site_label', name)
         f2 = numb_('_atom_site_fract_x', x, sx)
         f2 = numb_('_atom_site_fract_y', y, sy)
         f2 = numb_('_atom_site_fract_z', z, sz)
         f3 = numb_('_atom_site_U_iso_or_equiv', u, su)
         write(6,'(1x,a4,8f8.4)') name,x,y,z,u,sx,sy,sz,su
         if(loop_)  goto 160
C
C
C
C
C........................... Example 2 .......................................
C
C
C
C   In this example two separate data blocks are accessed. The first 
C   contains looped publication authors and text addresses. The second
C   part of this example shows how data from two different loops may
C   be merged. Remember that data items from different loops may NOT
C   be accessed simultaneously, as this causes the CIFtbx loop counters
C   to be reset to the start of the loop (see Example 3).
C
C
C
C....... List the author addresses from publication data block
C
         if(data_('publication')) 
     *   write(6,'(//a,a/)') ' Access items in data block  ',bloc_
         write(6,'(/a)') ' Author list'
C
210      f1 = char_('_publ_author_name', line)
         write(6,'(/1x,a)') line(1:long_)
C
220      f1 = char_('_publ_author_address', line)
         if(line(1:10).eq.'          ') goto 230
         write(6,'(1x,a)') line(1:50)
230      if(text_) goto 220
         if(loop_) goto 210

C
C
C....... Read and store the atom site data from other data block
C
         f1 = data_('mumbo_jumbo')
         write(6,'(///a,a/)') ' Access items in data block  ',bloc_
C
         nsite = 0
240      nsite = nsite+1
         f1 = char_('_atom_site_label', label(nsite))
         f2 = numb_('_atom_site_fract_x',  xf(nsite), sx)
         f2 = numb_('_atom_site_fract_y',  yf(nsite), sy)
         f2 = numb_('_atom_site_fract_z',  zf(nsite), sz)
         do 250 i=1,6
250      uij(nsite,i)=0.0
         if(loop_) goto 240
C
C....... Read the Uij loop and store in the site list
C
260      f1 = char_('_atom_site_aniso_label', name)         
         do 270 i=1,nsite
         if(label(i).eq.name) goto 280
270      continue
         write(6,'(a)') ' Label mismatch between atom lists'
280      f1 = numb_('_atom_site_aniso_U_11', uij(i,1), dum)
         f1 = numb_('_atom_site_aniso_U_22', uij(i,2), dum)
         f1 = numb_('_atom_site_aniso_U_33', uij(i,3), dum)
         f1 = numb_('_atom_site_aniso_U_12', uij(i,4), dum)
         f1 = numb_('_atom_site_aniso_U_13', uij(i,5), dum)
         f1 = numb_('_atom_site_aniso_U_23', uij(i,6), dum)
         if(loop_) goto 260
C
C....... List the atom site data
C
         write(6,'(/a/)') ' Atom coordinates and Uij'
         do 290 i=1,nsite
         if(uij(i,1).gt.0.0001) goto 285
         write(6,'(1x,a,3f8.4)') label(i),xf(i),yf(i),zf(i)
         goto 290
285      write(6,'(1x,a,9f8.4)') label(i),xf(i),yf(i),zf(i),
     *                           (uij(i,j),j=1,6)
290      continue
C
C
C
C
C........................... Example 3 .......................................
C
C
C   This example serves to illustrate how a general list of data requests
C   may be handled. The character function test_ is used to identify the
C   nature of the requested data item, and then numb_ and char_ are invoked
C   when applicable. The supplied list of requests on 'test.req' is not of 
C   particular significance. They are intentionally jumbled up to show what 
C   happens if a non-loop item is called within a loop [WARNING: CIFtbx
C   interprets this as a signal to end the loop and the next call for a loop
C   item will extract data from its first packet! Look at the output listing
C   to see what happens.]
C   
C
C
C....... Loop over the data request file
C
300      read(5,'(a)',end=400) name
C
         f1 = test_(name)
         write(6,'(/a,3x,a,2i5)') name,type_,long_,list_
C
         if(type_.ne.'numb')      goto 320
         f1 = numb_(name, numb, sdev)
         write(6,'(2f10.4)') numb,sdev
         goto 300
C
320      if(type_.ne.'char')      goto 340
         f1 = char_(name, line)   
         write(6,'(a)') line(1:long_)
         goto 300
C
340      if(type_.ne.'text')      goto 300
350      f1 = char_(name, line)   
         write(6,'(a)') line
         if(text_)  goto 350
         goto 300
C
C
C
C
C........................... Example 4 .......................................
C
C
C
C   In this example a new CIF is created. Note that it will not overwrite
C   an existing CIF of the same name. Note also that reading and existing 
C   CIF and writing a new CIF is possible at the same time, so that it is
C   feasible to use these tools to update or modify and existing CIF.
C
C
C
C....... Open a new CIF
C
400      if(pfile_('test.new'))  goto 450
         write(6,'(//a/)') ' Output CIF by this name exists already!'
         goto 500
C
C....... Insert a data block code
C
450      f1 = pdata_('whoops_a_daisy')
C
C....... Enter various single data items to show how
C
         f1 = pchar_('_audit_creation_method','using CIFtbx')
         f1 = pchar_('_audit_creation_extra1','using_CIFtbx')
         f1 = pchar_('_audit_creation_extra2',"Terry O'Connell")         
         f1 = pchar_('_audit_creation_extra3','Terry O"Connell')         
C
         f1 = ptext_('_audit_creation_record',' Text data may be ')
         f1 = ptext_('_audit_creation_record',' entered like this')
         f1 = ptext_('_audit_creation_record',' or in a loop.')      
C
         f1 = pnumb_('_cell_measurement_temperature', 293., 0.)
         f1 = pnumb_('_cell_volume', 1759.0, 13.)
         f1 = pnumb_('_cell_length_junk', 8.75353553524313,0.)
         f1 = pnumb_('_cell_length_c', 19.737, .003)
C
C....... Enter some looped data
C
         f1 = ploop_('_atom_type_symbol')
         f1 = ploop_('_atom_type_oxidation_number')
         f1 = ploop_('_atom_type_number_in_cell')
         do 470 i=1,10
         f1 = pchar_(' ',alpha(1:i))
         f1 = pnumb_(' ',float(i),float(i)*0.1)
470      f1 = pnumb_(' ',float(i)*8.64523,0.)         
C
C....... Do it again but as contiguous data with text data
C
         f1 = ploop_('_atom_type_symbol')
         f1 = ploop_('_atom_type_oxidation_number')
         f1 = ploop_('_some_silly_text') 
         do 480 i=1,3
         f1 = pchar_(' ',alpha(1:i))
         f1 = pnumb_(' ',float(i),float(i)*0.1)
480      f1 = ptext_(' ',' Hi Ho the diddly oh!')
C 
500      call close_
         stop
         end
C
C
C--------cut here------------------------------------------------------------
C

data_mumbo_jumbo

_audit_creation_date               91-03-20  
_audit_creation_method             from_xtal_archive_file_using_CIFIO
_audit_update_record
; 91-04-09           text and data added by Tony Willis.
  91-04-15           rec'd by co-editor with diagram as manuscript HL7.
  91-04-17           adjustments based on first referees report.
  91-04-18           adjustments based on second referee's report.
;

_chemical_name_systematic
              trans-3-Benzoyl-2-(tert-butyl)-4-(iso-butyl)-1,3-oxazolidin-5-one
_chemical_formula_moiety            'C18 H25 N O3'
_chemical_formula_sum               'C18 H25 N O3'
_chemical_formula_weight            303.40
_chemical_melting_point             ?

####_cell_length_a                     5.959(1)
_cell_length_b                     14.956(1)
_cell_length_c                     19.737(3)
_cell_angle_alpha                  90
_cell_angle_beta                   90
_cell_angle_gamma                  90
_cell_volume                       1759.0(3)
_cell_formula_units_Z              4
_cell_measurement_temperature      293
_cell_measurement_reflns_used       25
_cell_measurement_theta_min         25
_cell_measurement_theta_max         31

_symmetry_cell_setting             orthorhombic
_symmetry_space_group_name_H-M     'P 21 21 21'
_symmetry_space_group_name_Hall    P_2ac_2ab

loop_
_atom_type_symbol
_atom_type_oxidation_number
_atom_type_number_in_cell
_atom_type_scat_dispersion_REAL     #<< capitals to test case insensitivity
_atom_type_scat_dispersion_imag
_atom_type_scat_source
  S  0  6  .319  .557  Int_Tab_Vol_III_p202_Tab._3.3.1a
  O  0  6  .047  .032  Cromer,D.T._&_Mann,J.B._1968_AC_A24,321.
  C  0  20  .017  .009  Cromer,D.T._&_Mann,J.B._1968_AC_A24,321.
  RU  0  1  -.105   3.296  Cromer,D.T._&_Mann,J.B._1968_AC_A24,321.


loop_
_atom_site_label
_atom_site_fract_x
_atom_site_fract_y
_atom_site_fract_z
_atom_site_U_iso_or_equiv
_atom_site_thermal_displace_type
_atom_site_calc_flag
_atom_site_calc_attached_atom
_atom_site_type_symbol
  s  .20200  .79800  .91667  .030(3)  Uij  ?  ?  s
  o  .49800  .49800  .66667  .02520  Uiso  ?  ?  o
  c1  .48800  .09600  .03800  .03170  Uiso  ?  ?  c

loop_
_atom_site_aniso_label
_atom_site_aniso_U_11
_atom_site_aniso_U_22
_atom_site_aniso_U_33
_atom_site_aniso_U_12
_atom_site_aniso_U_13
_atom_site_aniso_U_23
_atom_site_aniso_type_symbol
  s  .035(4)  .025(3)  .025(3)  .013(1)  .00000  .00000  s


loop_ _blat1 _blat2 1 2 3 4 5 6 a b c d 7 8 9 0


data_publication


loop_
_publ_author_name                                                      #ActaC
_publ_author_address                                                   #ActaC

  'Furber, Mark'
;
Research School of Chemistry
Australian National University
GPO Box 4
Canberra, A.C.T.
Australia    2601
;
  'Mander, Lewis N.'
;
Research School of Chemistry
Australian National University
GPO Box 4
Canberra, A.C.T.
Australia    2601
;
  'Patrick, Graham L.'
;
Research School of Chemistry
Australian National University
GPO Box 4
Canberra, A.C.T.
Australia    2601
;
  'Willis, Anthony C.'
;
Research School of Chemistry
Australian National University
GPO Box 4
Canberra, A.C.T.
Australia    2601
;

#----------------------------cut here-------------------------------------------


_audit_creation_date 
_audit_creation_method 
_audit_update_record
_chemical_name_systematic
_chemical_formula_moiety
_chemical_formula_sum  
_chemical_formula_weight 
_chemical_melting_point 
_cell_length_a                 
_cell_length_b                
_cell_length_c               
_cell_angle_alpha           
_cell_angle_beta           
_cell_angle_gamma         
_cell_volume             
_cell_formula_units_Z   
_cell_measurement_temperature    
_cell_measurement_reflns_used   
_cell_measurement_theta_min    
_cell_measurement_theta_max   

_blat2
_blat1
_blat2
_blat1
_blat2
_blat1
_blat2
_blat1
_blat2
_blat1

_symmetry_cell_setting       
_symmetry_space_group_name_H-M   
_symmetry_space_group_name_Hall 

_atom_type_symbol
_atom_type_oxidation_number
_atom_type_number_in_cell
_atom_type_scat_dispersion_real 
_atom_type_scat_dispersion_imag
_atom_type_scat_source
_atom_type_symbol
_atom_type_oxidation_number
_atom_type_number_in_cell
_atom_type_number_in_cell
_atom_type_oxidation_number
_atom_type_scat_dispersion_real 


_atom_site_label
_atom_site_fract_x
_atom_site_fract_y
_atom_site_fract_z
_atom_site_U_iso_or_equiv
_atom_site_thermal_displace_type
_atom_site_calc_flag
_atom_site_calc_attached_atom
_atom_site_type_symbol
_atom_site_type_symbol
_atom_site_type_symbol
_atom_site_type_symbol
_rubish_here
_atom_site_type_symbol
_atom_site_type_symbol
_atom_site_type_symbol
_symmetry_space_group_name_Hall 
_atom_site_type_symbol
_atom_site_type_symbol
_atom_site_type_symbol
_atom_site_type_symbol

_atom_site_aniso_label
_atom_site_aniso_U_11
_atom_site_aniso_U_22
_atom_site_aniso_U_33
_atom_site_aniso_U_12
_atom_site_aniso_U_13
_atom_site_aniso_U_23
_atom_site_aniso_type_symbol
_atom_site_aniso_U_12
_atom_site_aniso_U_12
_atom_site_aniso_U_12

#------------------------------cut here---------------------------------------



 Read data from CIF  test.cif                        

 Warning: data name _atom_type_scat_dispersion_REAL  not in dictionary!
 Warning: data name _blat1                           not in dictionary!
 Warning: data name _blat2                           not in dictionary!

 Access items in data block  mumbo_jumbo                     

 Cell dimension(s) missing!

 Cell     0.0000   14.9560   19.7370
          0.0000    0.0010    0.0030

 Space group   P_2ac_2ab

 Next data name in CIF is   _atom_type_symbol               

 Audit record

  91-04-09           text and data added by Tony Willis.                        
  91-04-15           rec'd by co-editor with diagram as manuscript HL7.         
  91-04-17           adjustments based on first referees report.                
  91-04-18           adjustments based on second referee's report.              

 Atom sites

 s     0.2020  0.7980  0.9167  0.0300  0.0000  0.0000  0.0000  0.0030
 o     0.4980  0.4980  0.6667  0.0252  0.0000  0.0000  0.0000  0.0030
 c1    0.4880  0.0960  0.0380  0.0317  0.0000  0.0000  0.0000  0.0030


 Access items in data block  publication                     


 Author list

 Furber, Mark
 Research School of Chemistry                      
 Australian National University                    
 GPO Box 4                                         
 Canberra, A.C.T.                                  
 Australia    2601                                 

 Mander, Lewis N.
 Research School of Chemistry                      
 Australian National University                    
 GPO Box 4                                         
 Canberra, A.C.T.                                  
 Australia    2601                                 

 Patrick, Graham L.
 Research School of Chemistry                      
 Australian National University                    
 GPO Box 4                                         
 Canberra, A.C.T.                                  
 Australia    2601                                 

 Willis, Anthony C.
 Research School of Chemistry                      
 Australian National University                    
 GPO Box 4                                         
 Canberra, A.C.T.                                  
 Australia    2601                                 
 Warning: data name _atom_type_scat_dispersion_REAL  not in dictionary!
 Warning: data name _blat1                           not in dictionary!
 Warning: data name _blat2                           not in dictionary!



 Access items in data block  mumbo_jumbo                     


 Atom coordinates and Uij

 s     0.2020  0.7980  0.9167  0.0350  0.0250  0.0250  0.0130  0.0000  0.0000
 o     0.4980  0.4980  0.6667
 c1    0.4880  0.0960  0.0380

_audit_creation_date               char    8    0
91-03-20

_audit_creation_method             char   34    0
from_xtal_archive_file_using_CIFIO

_audit_update_record               text   80    0
  91-04-09           text and data added by Tony Willis.                        
  91-04-15           rec'd by co-editor with diagram as manuscript HL7.         
  91-04-17           adjustments based on first referees report.                
  91-04-18           adjustments based on second referee's report.              

_chemical_name_systematic          char   65    0
trans-3-Benzoyl-2-(tert-butyl)-4-(iso-butyl)-1,3-oxazolidin-5-one

_chemical_formula_moiety           char   12    0
C18 H25 N O3

_chemical_formula_sum              char   12    0
C18 H25 N O3

_chemical_formula_weight           numb    6    0
  303.4000    0.0000

_chemical_melting_point            null    1    0

_cell_length_a                     null    1    0

_cell_length_b                     numb    9    0
   14.9560    0.0010

_cell_length_c                     numb    9    0
   19.7370    0.0030

_cell_angle_alpha                  numb    2    0
   90.0000    0.0030

_cell_angle_beta                   numb    2    0
   90.0000    0.0030

_cell_angle_gamma                  numb    2    0
   90.0000    0.0030

_cell_volume                       numb    9    0
 1759.0000    0.3000

_cell_formula_units_Z              numb    1    0
    4.0000    0.3000

_cell_measurement_temperature      numb    3    0
  293.0000    0.3000

_cell_measurement_reflns_used      numb    2    0
   25.0000    0.3000

_cell_measurement_theta_min        numb    2    0
   25.0000    0.3000

_cell_measurement_theta_max        numb    2    0
   31.0000    0.3000

                                   null    1    0

_blat2                             numb    1    4
    2.0000    0.3000

_blat1                             numb    1    4
    1.0000    0.3000

_blat2                             numb    1    4
    4.0000    0.3000

_blat1                             numb    1    4
    3.0000    0.3000

_blat2                             numb    1    4
    6.0000    0.3000

_blat1                             numb    1    4
    5.0000    0.3000

_blat2                             char    1    4
b

_blat1                             char    1    4
a

_blat2                             char    1    4
d

_blat1                             char    1    4
c

                                   null    1    4

_symmetry_cell_setting             char   12    0
orthorhombic

_symmetry_space_group_name_H-M     char   10    0
P 21 21 21

_symmetry_space_group_name_Hall    char    9    0
P_2ac_2ab

                                   null    1    0

_atom_type_symbol                  char    1    1
S

_atom_type_oxidation_number        numb    1    1
    0.0000    0.3000

_atom_type_number_in_cell          numb    1    1
    6.0000    0.3000

_atom_type_scat_dispersion_real    null    1    1

_atom_type_scat_dispersion_imag    numb    4    1
    0.5570    0.3000

_atom_type_scat_source             char   32    1
Int_Tab_Vol_III_p202_Tab._3.3.1a

_atom_type_symbol                  char    1    1
O

_atom_type_oxidation_number        numb    1    1
    0.0000    0.3000

_atom_type_number_in_cell          numb    1    1
    6.0000    0.3000

_atom_type_number_in_cell          numb    1    1
    6.0000    0.3000

_atom_type_oxidation_number        numb    1    1
    0.0000    0.3000

_atom_type_scat_dispersion_real    null    1    1

                                   null    1    1

                                   null    1    1

_atom_site_label                   char    1    2
s

_atom_site_fract_x                 numb    6    2
    0.2020    0.3000

_atom_site_fract_y                 numb    6    2
    0.7980    0.3000

_atom_site_fract_z                 numb    6    2
    0.9167    0.3000

_atom_site_U_iso_or_equiv          numb    7    2
    0.0300    0.0030

_atom_site_thermal_displace_type   char    3    2
Uij

_atom_site_calc_flag               null    1    2

_atom_site_calc_attached_atom      null    1    2

_atom_site_type_symbol             char    1    2
s

_atom_site_type_symbol             char    1    2
s

_atom_site_type_symbol             char    1    2
s

_atom_site_type_symbol             char    1    2
s

_rubish_here                       null    1    2

_atom_site_type_symbol             char    1    2
o

_atom_site_type_symbol             char    1    2
o

_atom_site_type_symbol             char    1    2
o

_symmetry_space_group_name_Hall    char    9    0
P_2ac_2ab

_atom_site_type_symbol             char    1    2
s

_atom_site_type_symbol             char    1    2
s

_atom_site_type_symbol             char    1    2
s

_atom_site_type_symbol             char    1    2
s

                                   null    1    2

_atom_site_aniso_label             char    1    3
s

_atom_site_aniso_U_11              numb    7    3
    0.0350    0.0040

_atom_site_aniso_U_22              numb    7    3
    0.0250    0.0030

_atom_site_aniso_U_33              numb    7    3
    0.0250    0.0030

_atom_site_aniso_U_12              numb    7    3
    0.0130    0.0010

_atom_site_aniso_U_13              numb    6    3
    0.0000    0.0010

_atom_site_aniso_U_23              numb    6    3
    0.0000    0.0010

_atom_site_aniso_type_symbol       char    1    3
s

_atom_site_aniso_U_12              numb    7    3
    0.0130    0.0010

_atom_site_aniso_U_12              numb    7    3
    0.0130    0.0010

_atom_site_aniso_U_12              numb    7    3
    0.0130    0.0010


#------------------------------------cut here----------------------------------


data_whoops_a_daisy 
 
_audit_creation_method            'using CIFtbx' 
_audit_creation_extra1            using_CIFtbx             #< not in dictionary 
_audit_creation_extra2            "Terry O'Connell"        #< not in dictionary 
_audit_creation_extra3            'Terry O"Connell'        #< not in dictionary 
_audit_creation_record                                     #< not in dictionary 
;
 Text data may be 
 entered like this
 or in a loop.
; 
_cell_measurement_temperature     293 
_cell_volume                      1759(13) 
_cell_length_junk                 8.753535                 #< not in dictionary 
_cell_length_c                    19.736(3) 
 
loop_ 
    _atom_type_symbol 
    _atom_type_oxidation_number 
    _atom_type_number_in_cell 
a 1.0(1) 8.645230 
ab 2.0(2) 17.290460 
abc 3.0(3) 25.935691 
abcd 4.0(4) 34.580921 
abcde 5.0(5) 43.226150 
abcdef 6.0(6) 51.871383 
abcdefg 7.0(6) 60.516613 
abcdefgh 8.0(8) 69.161842 
abcdefghi 9.0(9) 77.807075 
abcdefghij 10(1) 86.452301 
 
loop_ 
    _atom_type_symbol 
    _atom_type_oxidation_number 
    _some_silly_text                                       #< not in dictionary 
a 1.0(1) 
;
 Hi Ho the diddly oh!
; 
ab 2.0(2) 
;
 Hi Ho the diddly oh!
; 
abc 3.0(3) 
;
 Hi Ho the diddly oh!
; 

#-----------------------------------end of file-------------------------------
