C
C
C    \ | /            /##|    @@@@  @   @@@@@   |      |             @@@@@@
C     \|/ STAR       /###|   @      @   @     __|__    |                  @
C  ----*----        /####|  @       @   @@@@    |      |___  __  __     @@
C     /|\          /#####|   @      @   @       |      |   \   \/    @    @
C    / | \         |#####|    @@@@  @   @       \___/  \___/ __/\__   @@@@
C                  |#####|________________________________________________
C                 ||#####|                 ___________________            |
C        __/|_____||#####|________________|&&&&&&&&&&&&&&&&&&&||          |
C<\\\\\\\\_ |_____________________________|&&&  1 Sep 2006  &&||          |
C          \|     ||#####|________________|&&&&&&&&&&&&&&&&&&&||__________|
C                  |#####|
C                  |#####|                Version 3.0.4 Release
C                  |#####|
C                 /#######\ 
C                |#########|
C                    ====
C                     ||
C           An extended tool box of fortran routines for manipulating CIF data.
C                     ||
C                     ||  CIFtbx Version 3
C                     ||        by
C                     ||
C                     ||  Sydney R. Hall (syd at crystal dot uwa dot edu dot au)
C                     ||       and
C                     ||  Herbert J. Bernstein (yaya at bernstein-plus-sons dot com)
C                     ||
C                     ||
C_____________________||_____________________________________________________
C                  (C) Copyright 2006 Herbert J. Bernstein
C
C YOU MAY REDISTRIBUTE THE CIFtbx PACKAGE UNDER THE TERMS OF THE GPL.
C
C ALTERNATIVELY YOU MAY REDISTRIBUTE THE CIFtbx API (but not the  programs 
C and documentation) UNDER THE TERMS  OF THE LGPL.
C 
C Work on CIFtbx has been supported in part by grants from the U. S. 
C National Science Foundation, the U.S. Department of Energy and the 
C International Union of Crystallography.
C
C CIFtbx3 is free software; you can redistribute this software and/or 
C modify  this software under the terms of the GNU General Public 
C License as published by the Free Software Foundation; either version 
C 2 of the License, or  (at your option) any later version.
C
C This software is distributed in the hope that it will be useful,  
C but WITHOUT ANY WARRANTY; without even the implied warranty of  
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the  
C GNU General Public License for more details.
C
C You should have received copies of the GNU General Public License  
C and of the GNU Lesser General Public License along with this software; 
C if not, write to the Free Software  Foundation, Inc., 59 Temple Place, 
C Suite 330, Boston, MA 02111-1307 USA
C
C Before using this software, please read the NOTICE and please read 
C the IUCr Policy on the Use of the Crystallographic Information File (CIF)
C
C This is a version of CIFtbx which has been extended to work with DDL 2
C and mmCIF as well as with DDL 1.4 and core CIF dictionaries.  CIFtbx
C version 1 was written by Sydney R. Hall (see Hall, S. R., "CIF Applications
C IV.  CIFtbx: a Tool Box for Manipulating CIFs,"  J. Appl. Cryst (1993). 26,
C 482-494.  The revisions for version 2 were done by Herbert J. Bernstein
C and Sydney R. Hall (see Hall, S. R. and Bernstein, H. J., "CIFtbx 2:
C Extended Tool Box for Manipulating CIFs," J. Appl. Cryst.(1996). 29,
C 598-603) 
C
C The revisions for release 3 were done by Herbert J. Bernstein, work
C funded in part by the International Union of Crystallography
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. if the name dictionary
C               was opened and if the check codes are recognisable.  The
C               data item names used in the first dictionary loaded are
C               considered to be preferred by the user to aliases found
C               in dictionaries loaded in later calls.  On exit from dict_
C               the variable dicname_ is either equal to the filename, or,
C               if the dictionary had a value for the tag dictionary_name
C               of dictionary.title, dicname_ is set to that value.
C               The variable dicver_ is blank or set to the value of
C               _dictionary_version or of _dictionary.version  The check codes
C               'catck' and 'catno' turn on and off checking of dictionary
C               catgeory conventions.  The default is 'catck'.  The check
C               codes 'parck' and 'parno' turn on and off checking of
C               parent-child relationships.  The default is 'parck'.  Three check
C               codes control the handling of tags from the current dictionary
C               which duplicate tags from a dictionary loaded earlier.  These
C               codes ('first', 'final' and 'nodup') have effect only for the
C               current call to dict_  The default is 'first'.]
C
C               <dictionary filename>  A CIF dictionary in DDL format
C                                      or blank if just setting flags
C                                      or resetting the dictionary
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                                      'catck'  check datanames against
C                                               categories
C                                      'catno'  don't check datanames against
C                                               categories
C                                      'first'  accept first dictionary's 
C                                               definitions of duplicate tags
C                                      'final'  accept final dictionary's
C                                               definitions of duplicate tags
C                                      'nodup'  do not accept duplicate tag
C                                               definitions
C                                      'parck'  check datanames against parent-
C                                               child relationahips
C                                      'parno'  don't check datanames against
C                                               parent-child relationships
C                                      'reset'  switch off checking flags
C                                      'close'  close existing dictionaries
C
C___________________________________________________________________________
C
C
C   CIF ACCESS TOOLS  ("the get_ing commands")
C
C
C
C    ocif_      Opens the CIF containing the required data.
C               [logical function returned .true. if CIF opened]
C
C               <CIF filename>        A blank name signals that the
C                                     currently open input CIF file
C                                     will be read.
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    bkmrk_     Saves or restores the current position so that data from 
C               elsewhere in the cif can be examined.
C               [logical function returned as .true. on save if there was
C               room in internal storage to hold the current position, .true.
C               on restore if the bookmark number used was valid.  If the
C               argument is zero, the call is to save the position and return
C               the bookmark number in the argument.  If the argument is
C               non-zero, the call is to restore the position saved for the
C               bookmark number given.  The bookmark and the argument are
C               cleared.  The position set on return allow reprocessing of
C               the data item or loop row last processed when the bookmark
C               was placed.
C
C               NOTE:  All bookmarks are cleared by a call to data_]
C
C               <integer variable>    Bookmark number
C
C
C    find_      Find the location of the requested item in the CIF.
C               [The argument "name" may be a data item name, blank
C               for the next such item.  The argument "type" may be
C               blank for unrestricted acceptance of any non-comment
C               string (use cmnt_ to see comments), including loop headers,
C               "name" to accept only the name itself and "valu"
C               to accept only the value, or "head" to position to the
C               head of the CIF.  Except when the "head" is requested,
C               the position is left after the data item provided.  If the
C               item found is of type "name", posnam_ is set, otherwise, 
C               posval_]
C
C               <data item name>      A blank name signals that the next
C                                     item of the type specified is needed
C
C               <data item type>      blank, 'head', 'name' or 'valu'
C
C               <character variable>  Returned string is of length long_.
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               common variables list_, type_, dictype_, diccat_ and dicname_. 
C               The values in dictype_, diccat_ and dicname_ are valid
C               whether or not the data item is found in the input CIF, as
C               long as the named data item is found in the dictionaries
C               declared by calls to dict_.  The data item name found
C               in the input CIF is stored in tagname_.  The appropriate
C               column numbers are stored in posnam_, posval_, posend_ and (for
C               numbers) in posdec_.  The quotation mark, if any, used is
C               stored in quote_.
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 '?' or '.'
C                              also used for blank quoted fields if
C                              nblank_ is true
C
C               dictype_ is a character*(NUMCHAR) variable with the type code
C               given in the dictionary entry for the named data item.  If
C               no dictionary was used, or no type code was specified, this
C               field will simply agree with type_.  If a dictionary was used,
C               this type may be more specific than the one given by type_.
C
C               diccat_ is a character*(NUMCHAR) variable with the category
C               of the named data item, or '(none)'
C
C               dicname_ is a character*(NUMCHAR) variable with the name of
C               the data item which is found in the dictionary for the
C               named data item.  If alias_ is .true., this name may
C               differ from the name given in the call to test_.  If alias_
C               is .false. or no preferred alias is found, dicname_ agrees with
C               the data item name. 
C
C               dicpname_ is a character*(NUMCHAR) variable with the name of
C               the parent of the data item which is found in the dictionary for the
C               named data item.  The default when no parent is specified in a
C               dictionary is to give the value on dicname_.
C
C               tagname_ is a character*(NUMCHAR) variable with the name
C               of the data item as found in the input CIF.  It will be
C               blank if the data item name requested is not found in the
C               input CIF and may differ from the data item name provided
C               by the user if the name used in the input CIF is an
C               alias of the data item name and alias_ is .true.
C
C               posnam_, posval_, posend_  and posdec_ are integer variables
C               which may be examined if information about the horizontal
C               position of the name and data read are needed.  posnam_ is the
C               starting column of the data name found (most often 1).
C               posval_ is the starting column of the data value.  If the
C               field is numeric, then posdec_ will contain the effective
C               column number of the decimal point.  For whole numbers, the
C               effective position of the decimal point is one column to the
C               right of the field.  posend_ contains the ending column of the
C               data value.
C
C               valid_ is a logical variable that may be examined to
C               determine if the value conforms to dictionary-specified
C               type, range and enumeration restrictions. 
C
C               quote_ is a character*1 varibale which may be examined to
C               determine if a quotation character was used on character data.]
C
C               <data name>           Name of the data item to be tested.
C
C
C    dtype_     Return the dictionary type of a data name, if any.
C               [logical function returned as .true. if the item has a type
C               in the dctionary, .false. if not.  The type returned is
C               one of the base type used by type_ (see above), if possible]
C
C               <data name>          Name of the item for which a type is needed
C               <data type>          Returned type from the dictionary
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    numd_      Extracts the number and its standard deviation (if appended)
C               as double precision variables.
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               <double precision variable>
C                                     Returned number.
C
C               <double precision variable>
C                                     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               Non-text blank (quoted blanks) or empty ('' or "") fields
C               are converted by char to a null field, if nblank_ is true.]
C
C               <data name>           Name of the string sought.
C
C               <character variable>  Returned string is of length long_.
C
C    charnp_    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               Non-text blank (quoted blanks) or empty ('' or "") fields
C               are converted by char to a null field, if nblank_ is true.]
C               Only the number of characters returned in the third argument
C               are set.  This value is never less than 1, but may be less
C               than the allocated length of the returned string.
C
C               <data name>           Name of the string sought.
C
C               <character variable>  Returned string is of length long_.
C
C               <integer variable>    Returned length of valid characters.
C
C
C    cmnt_      Extracts the next comment from the data block.
C               [logical function returned as .true. if a comment is present.
C               The initial comment character "#" is _not_ included in the
C               returned string.  A completely blank line is treated as
C               a comment.]
C
C               <character variable>  Returned string is of length long_.
C
C
C
C    purge_     Closes existing data files and clears tables and pointers.
C               [subroutine call]        
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>           Blank for use of currently open file
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               Produces a save frame instead of a data block if the
C               variable saveo_ is true during the call.  No block duplicate
C               check is made for a save frame.]
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.  If pposval_ 
C               is non-zero, the "loop_" header is positioned to 
C               that column.  If pposnam_ is non-zero, the data name is 
C               positioned to that column.]
C
C               <data name>         If the name is blank on the first call
C                                   of a loop, only the "loop_" is placed.
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               The action of pchar_ is modified by the variables pquote_ and
C               nblanko_.  If pquote_ is non-blank, it is used as a quotation
C               character for the string written by pchar_.  The valid values
C               are '''', '"', and ';'.  In the last case a text field is
C               written.  If the string contains a matching character to the
C               value of quote_, or if quote_ is not one of the valid
C               quotation characters, a valid, non-conflicting quotation
C               character is used.  Except when writing a text field, if 
C               nblanko_ is true, pchar_ converts a blank string to 
C               an unquoted period.]
C
C               <data name>         If the name is blank, do not output name.
C
C               <character string>  A character string of MAXBUF chars or less.
C
C
C
C    pcmnt_     Puts a comment into the created CIF.
C               [logical function returned as .true.  The comment character
C               "#" should not be included in the string.  A blank comment
C               is presented as a blank line without the leading "#"].
C
C               <character string>  A character string of MAXBUF chars or less.
C
C
C    pnumb_     Put a single precision 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               The number of esd digits is controlled by the variable
C               esdlim_]
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    pnumd_     Put a double precision 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               The number of esd digits is controlled by the variable
C               esdlim_]
C
C               <data name>         If the name is blank, do not output name.
C
C               <double precision variable>  
C                                   Number to be inserted.
C
C               <double precision variable>  
C                                   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               If used when pfold_ is non-zero, the text field will be marked
C               as folded even if the first line is small enough to fit.
C               In order to produce a non-folded text field in the midst
C               of generally folded items, pfold_ should be set to 0 before
C               calling ptext_ and then restored to the previous value.
C
C               <data name>         If the name is blank, do not output name.
C
C               <character string>  A character string of MAXBUF chars or less.
C
C
C    prefx_     Puts a prefix onto subsequent lines of the created CIF.
C               [logical function returned as .true.  The second argument
C               may be zero to suppress a previously used prefix, or
C               greater than the non-blank length of the string to force
C               a left margin.  Any change in the length of the prefix 
C               string flushes pending partial output lines, but does _not_
C               force completion of pending text blocks or loops.
C               This function allows the CIF output functions to be used 
C               within what appear to be text fields to support annotation 
C               of a CIF. ]
C
C               <character string>  A character string of MAXBUF chars or less.
C
C               <integer variable>  The length of the prefix string to use.
C
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    alias_      Logical variable: if left .true. then all calls to
C                CIFtbx functions may use aliases of data item names.
C                The preferred synonym from the dictionary will be
C                subsituted internally, provided aliased data names were
C                supplied by an input dictionary (via dict_).  The
C                default is .true., but alias_ may be set to .false.
C                in an application.
C
C    aliaso_     Logical variable: if set .true. then cif output 
C                routines will convert aliases to the names to preferred
C                synonyms from the dictionary.  The default is .false., but
C                aliaso_ may be set to .true. in an application.  The
C                setting of aliaso_ is independent of the setting of
C                alias_.
C
C    align_      Logical variable signals alignment of loop_ lists during
C                the creation of a CIF. The default is .true.
C
C    append_     Logical variable:  if set .true. each call to ocif_ will
C                append the information found to the current cif.  The default
C                is .false.
C
C    bloc_       Character*(NUMCHAR) variable: the current block name.
C
C    decp_       Logical variable: set when processing numeric input, .true.
C                if there is a decimal point in the numeric value, .false.
C                otherwise
C
C    dictype_    Character*(NUMCHAR) variable: the precise data type code
C                (see test_)
C
C    diccat_     Character*(NUMCHAR) variable: the category (see test_)
C
C    dicname_    Character*(NUMCHAR) variable: the root alias (see test_) or
C                the name of the dictionary just loaded (see dict_)
C
C    dicpname_   Character*(NUMCHAR) variable: the parent (see test_)
C
C    dicver_     Character*(NUMCHAR) variable: the version of the dictionary
C                just loaded (see dict_)
C
C    esdlim_     Integer variable:  Specifies the upper limit of esd's
C                produced by pnumb_, and, implicitly, the lower limit.
C                The default value is 19, which limits esd's to the range
C                2-19.  Typical values of esdlim_ might be 9 (limiting
C                esd's to the range 1-9), 19, or 29 (limiting esd's
C                to the range 3-29).  If esdlim_ is given as a negative
C                value, the upper limit of esd's is the absolute value
C                of esdlim_ and the lower limit is 1.
C
C    esddig_     Integer variable:  The number of esd digits in the last
C                number read from a CIF.  Will be zero if no esd
C                was given.
C
C    file_       Character*(MAXBUF) variable: the filename of the current file.
C                Warning:  only file_(1:longf_) is valid
C
C    fold_       Logical variable signals that the current text block
C                began with the ';\' fold indicator. Only meaningful
C                when text_ is .true. and type_ is 'text'.
C                (fold_ is .true. if the indicator is present)  
C
C    glob_       Logical variable signals that the current data block
C                is actually a global block (.true. for a global block).
C
C    globo_      Logical variable signals that the output data block from
C                pdata_ is actually a global block (.true. for a global block).
C
C    line_       Integer variable: Specifies the input/output line limit
C                for processing a CIF. The default value is 80 characters.
C                This may be set by the program. The max value is MAXBUF
C                which has a default value of 2048.  In order to use
C                the CIF 1.1 line folding protocol for lines that
C                cannot be fit into line_ characters, the variable
C                pfold_ must be set to a non-zero value less than
C                or equal to line_
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    longf_      Integer variable: the length of the filename in file_.
C
C    loop_       Logical variable signals if another loop packet is present.
C
C    lzero_      Logical variable: set when processing numeric input, .true.
C                if the numeric value is of the form [sign]0.nnnn rather than
C                [sign].nnnn, .false. otherwise 
C
C    nblank_     Logical variable: if set .true. then all calls to
C                to char_ or test_ which encounter a non-text quoted blank 
C                will return the type as 'null' rather than 'char'.
C
C    nblanko_    Logical variable: if set .true. then cif output 
C                routines will convert quoted blank strings to an
C                unquoted period (i.e. to a data item of type null).
C
C    pdecp_      Logical variable: if set .true. then cif numeric output
C                routines will insert a decimal point in all numbers written by
C                pnumb_ or pnumbd_.  If set .false. then a decimal point will be
C                written only when needed.  The default is .false.
C
C    pesddig_    Integer variable: if set non-zero, and esdlim_ is negative,
C                controls the number of digits for esd's produced by
C                pnumb_ and pnumd_
C
C    pfold_      Integer variable:  If set non-zero, specifies a column
C                on which output lines are to be folded.  The default is 0.
C                If pfold_ is set to a value greater than line_ the
C                value of line_ will be used instead.  Non-zero values of 
C                pfold_ less than 4 are not valid and will be reset to 4.
C                Non-zero values of pfold_ less than 80 can cause conflict
C                with the syntactic requirements of creating a valid CIF.
C 
C    plzero_     Logical variable: if set .true. then cif numeric output
C                routines will insert a zero before a leading decimal point,
C                The default is .false.
C
C    pposdec_    Integer variable giving the position of the decimal point
C                for the next number to be written.  This acts very much like
C                a decimal centered tab in a word processor, to help align
C                columns of number on a decimal point, if a decimal point
C                is present.
C
C    pposend_    Integer variable giving the ending column of the next
C                number or quoted character value to be written.  Used to
C                pad with zeros or blanks.
C
C    pposnam_    Integer variable giving the starting column of the next
C                name or comment or data block to be written.
C
C    pposval_    Integer variable giving the starting column of the next
C                data value to be written by pchar_, pnumb_ or pnumd_.
C                Also used to set the position of the initial "loop_"
C                in a ploop_ call or to set the position of a terminal "save_"
C                for a save frame in a pdata_ call for which saveo_ is .true.
C
C    posdec_     Integer variable giving the position of the decimal point
C                for the last number read, if a decimal point was present.
C
C    posend_     Integer variable giving the ending column of the last
C                data value read, not including a terminal quote.
C
C    posnam_     Integer variable giving the starting column of the last
C                name or comment or data block read.
C
C    posval_     Integer variable giving the starting column of the last
C                data value read.  Also reports the column of the
C                terminal "save_" of a save frame.
C
C    pquote_     Character variable giving the quotation symbol to be
C                used for the next string written, or the comment
C                flag for the next comment written.
C
C    precn_      Integer variable:  Reports the record number of the last
C                line written to the output cif.  Set to zero by init_.  Also
C                set to zero by pfile_ and close_ if the output cif file name
C                was not blank.
C
C    ptabx_      Logical variable signals tab character expansion to blanks 
C                during the creation of a CIF. The default is .true.
C
C    quote_      Character variable giving the quotation symbol found
C                delimiting the last string read or the comment flag
C                for the last comment read.
C
C    recbeg_     Integer variable:  Gives the record number of the first
C                record to be used.  May be changed by the user to restrict
C                access to a CIF.
C
C    recend_     Integer variable:  Gives the record number of the last
C                record to be used.  May be changed by the user to restrict
C                access to a CIF.
C
C    recn_       Integer variable:  Reports the record number of the last
C                line read from the direct access copy of the input cif.
C
C    save_       Logical variable signals that the current data block
C                is actually a save-frame (.true. for a save-frame).
C
C    saveo_      Logical variable signals that the output data block from
C                pdata_ is actually a save-frame (.true. for a save-frame).
C
C    strg_       Character*(MAXBUF) variable: the current data item.
C
C    tabl_       Logical variable signals tab-stop alignment of output 
C                during the creation of a CIF. The default is .true.
C
C    tabx_       Logical variable signals tab character expansion to blanks 
C                during the reading of a CIF. The default is .true.
C
C    tbxver_     Character*32 variable: the CIFtbx version and date
C                in the form 'CIFtbx version N.N.N, DD MMM YY '
C
C    text_       Logical variable signals if another text line is present.
C
C    type_       Character*4 variable: the data type code (see test_).
C
C    unfold_     Logical variable signals that input lines are to be
C                unfolded before presentation of data.  The default
C                is .false.
C
C    valid_      Logical variable:  set when processing input data for which
C                dictionary type checking has been requested , .true.
C                if the value conforms to type, range and enumeration
C                specifications for the given tag in the dictionary.
C
C    xmlout_     Logical variable:  Set by the user to change the output
C                style to XML conventions.  Note that this is not a
C                cml output, but a literal translation from the input CIF.
C                The default is .false.
C
C    xmlong_     Logical variable:  Set by the user to change the style of
C                xml output if xmlout_ is .true.  When .true. (the default)
C                xml tag names are the full CIF tag names with the leading
C                '_' removed.  When .false. an attempt is made to strip
C                the leading category name as well.
C
C
C_____________________________________________________________________________
C
C
C >>>>>> Set the device numbers.
C
         function init_(devcif,devout,devdir,deverr)
C
         logical   init_
         include   'ciftbx.sys'
         integer   devcif,devout,devdir,deverr
         integer   ii,kdig
         real      ytest
         double precision ztest         
C
         init_=.true.
         cifdev=devcif
         outdev=devout
         dirdev=devdir
         errdev=deverr
         recn_=0
         precn_=0
         plcat = ' '
         plxcat = ' '
         plhead(1) = ' '
         plxhead(1) = ' '
         pdblok = ' '
         ploopn = 0
         nstable = 0
         nivt = 0
C
C        recompute decimal single precision precision
C        This is found by computing the smallest power of
C        10 which, when added to 1, produces a change
C        and then backing off by 1
C
         decprc = .1
         do ii = 1,8
         ytest = 1.+decprc/10.
         if (ytest.eq.1.) go to 100
         decprc = decprc/10.
         enddo
100      continue
         decprc=decprc*10.
C
C        recompute decimal double precision precision
C
         kdig = 1
         dpprc = .1D0
         do ii = 1,17
         ztest = 1.D0+dpprc/10.
         if (ztest.eq.1.D0) go to 200
         dpprc = dpprc/10.D0
         kdig = kdig+1
         enddo
200      continue
         dpprc=dpprc*10.D0
         write(ndpfmt,'(5h(d30.,i2,1h))') kdig-1
C
C        recompute decimal single precision minimum power of ten
C
         decmin = .1
         do ii = 1,39
         ytest = decmin/10.
         if (ytest.eq.0.) go to 300
         decmin = decmin/10.
         enddo
300      continue
C
C        recompute decimal double precision minimum power of 10
C        and its log base 10 (minexp)
C
         dpmin = .1D0
         minexp = -1
         do ii = 1,309
         ztest = dpmin/10.
         if (ztest.eq.0.D0) go to 400
         dpmin = dpmin/10.D0
         minexp = minexp-1
         enddo
400      continue
         call clearfp
         return
         end
C
C
C
C
C
C >>>>>> Read a CIF dictionary and prepare for checks
C
         function dict_(fname,checks)
C
         logical   dict_
         logical   ocif_
         logical   data_
         logical   charnp_
         logical   test_
         integer   lastnb
         include  'ciftbx.sys'
         logical   tbxxnid, tbxxoid
         logical   nresult
         character fname*(*),checks*(*)
         character temp*(MAXBUF)
         character codes(11)*5,name*(MAXBUF),bxname*(NUMCHAR)
         character bpname*(NUMCHAR)
         character bcname*(NUMCHAR),biname*(NUMCHAR),bname*(NUMCHAR)
         character baname*(NUMCHAR),ganame*(NUMCHAR),btname*(NUMCHAR)
         character batag*(NUMCHAR)
         character mcstrg*(NUMCHAR)
         character riname*(NUMCHAR),rfname*(NUMCHAR)
         character xdicnam*(NUMCHAR)
         character xdicver*(NUMCHAR)
         character xmtoken*(NUMCHAR),xmtarg*(XMLCHAR),xmtyp*(NUMCHAR)
         character xxxtemp*(NUMCHAR)
         character*3 ovchk, otchk
         integer   nrecds,recends,recbegs
         integer   lchecks,lbpname,lbcname,lbaname,lbtname,lbname
         integer   lriname,lrfname
         integer   kdict,kadict,ifind,jfind,iafind,jck,ick
         integer   i,j,nmatch,mycat,ksmatch,ii,jj,idstrt,icstrt,kdup
         integer   nmycat,ixmtyp,nxmc,kxmc
		 integer   lstrg,lxmtoken,lxmtarg,lxmtyp,kvrtp,kstrg,sindex

C
C        Control flags for matching categories, names and types
C
C        icloop is the loop number of the block for the
C        current category
C        ictype is the type of the current category
C          0 - none found yet
C          1 - _item.category.id
C          2 - _category
C          3 - _category.id
C        inloop is the loop number of the block for the
C        current name
C        intype is the type of the current name
C          0 - none found yet
C          1 - _item.name
C          2 - _name
C        ialoop is the loop number of the block for the
C        current alias
C        iatype is the type for the current alias
C          0 - none found yet
C          1 - _item_aliases.alias_name
C        imloop is the loop number of the block for the
C        current parent
C        imtype is the type for the current parent
C          0 - none found yet
C          1 - _item.mandatory_code
C        iploop is the loop number of the block for the
C        current parent
C        iptype is the type for the current parent
C          0 - none found yet
C          1 - _item_linked.parent_name
C          2 - _item_link_parent
C        itloop is the loop number of the block for the
C        current type
C        ittype is the type of the current type
C          0 - none found yet
C          1 - _item_type.code
C          2 - _type
C        iritype is the type of the current related item
C          0 - none found yet
C          1 - _item_related.related_name
C          2 - _related_item
C        irftype is the type of the current related item function
C          0 - none found yet
C          1 - _item_related.function_code
C          2 - _related_function
C

         integer icloop,ictype,inloop,intype,ialoop,iatype,
     * imloop,imtype,iploop,iptype,itloop,ittype,
     * iriloop,iritype,irfloop,irftype,icktype
C
         character*4 map_type(16),map_to(16),mapped
         character*(NUMCHAR) dt(2),dv(2),ct(3),nt(2),at(1),tt(2)
         character*(NUMCHAR) ri(2),rf(2),ck(2),pt(2),pc(2),mc(2)
         character*(NUMCHAR) ve(2),vr(3)
         data map_type
     *   /'floa','int ','yyyy','symo','ucha','ucod','name','idna',
     *    'any ','code','line','ulin','atco','fax ','phon','emai'/
         data map_to
     *   /'numb','numb','char','char','char','char','char','char',
     *    'char','char','char','char','char','char','char','char'/
         data ri
     *      /'_item_related.related_name      ',
     *       '_related_item                   '/
         data rf
     *      /'_item_related.function_code     ',
     *       '_related_function               '/
         data dt
     *      /'_dictionary.title               ',
     *       '_dictionary_name                '/
         data dv
     *      /'_dictionary.version             ',
     *       '_dictionary_version             '/
         data ct
     *      /'_item.category_id               ',
     *       '_category                       ',
     *       '_category.id                    '/
         data nt
     *      /'_item.name                      ',
     *       '_name                           '/
         data at
     *      /'_item_aliases.alias_name        '/
         data tt
     *      /'_item_type.code                 ',
     *       '_type                           '/
         data ck
     *      /'_category_key.name              ',
     *       '_list_reference                 '/
         data pt
     *      /'_item_linked.parent_name        ',
     *       '_item_link_parent               '/
         data pc
     *      /'_item_linked.child_name         ',
     *       '_item_link_child                '/
         data mc
     *      /'_item.mandatory_code            ',
     *       '_mandatory                      '/
         data ve
     *      /'_item_enumeration.value         ',
     *       '_enumeration                    '/
         data vr
     *      /'_item_range.minimum             ',
     *       '_enumeration_range              ',
     *       '_item_range.maximum             '/

C
         data codes /'valid','dtype','reset','close',
     *       'catck','catno','nodup','final','first',
     *       'parck','parno'/
C
         nrecds=nrecd
         recbegs=recbeg_
         recends=recend_
         if(append_) then
           recbeg_=nrecd
         endif
C
C        Initialize kdup to 0 ('final')
C
         kdup = 0
C
C        initialize both xdicnam and xdicver to blank
C
         xdicnam = ' '
         xdicver = ' '
C
C        preserve entry values of tcheck and vcheck in case dict fails
C
         otchk = tcheck
         ovchk = vcheck
C
C....... Are the codes OK
C
         lchecks=min(len(temp),len(checks))
         call tbxxnlc(temp(1:lchecks),checks)
         i=0         
120      i=i+1
         if(i.ge.lchecks)            goto 190
         if(temp(i:i).eq.' ')        goto 120
         do 150 j=1,11
         if(temp(i:i+4).eq.codes(j)) goto 170
150      continue
         dict_=.false.
         goto 500
170      i=i+4
         if(j.eq.1) then
           vcheck='yes'
           goto 120
         endif
         if(j.eq.2) then
           tcheck='yes'
           goto 120
         endif
         if(j.eq.3) then
           vcheck = 'no '
           tcheck = 'no '
           goto 120
         endif
         if(j.eq.4) then
           vcheck = 'no '
           tcheck = 'no '
           catchk = 'yes'
           ndcname = 0
           ndict = 0
           if(nname.gt.0) then
           do 180 i = 1,nname
             dtype(i)=' '
             dxtyp(i)=' '
             cindex(i)=0
             ddict(i)=0
180        continue
           endif
           dict_=.true.
           goto 500
         endif
         if (j.eq.5) then
           catchk = 'yes'
           goto 120
         endif
         if (j.eq.6) then
           catchk = 'no '
           goto 120
         endif
         if (j.eq.10) then
           parchk = 'yes'
           goto 120
         endif
         if (j.eq.11) then
           parchk = 'no '
           goto 120
         endif
         kdup=j-8
         goto 120
C
C        if no category names have been loaded, clean up
C        the hash table for dictionary category names
C
190      if(ndcname.eq.0) then
           call hash_init(dcname,dcchain,NUMDICT,ndcname,dchash,
     *     NUMHASH)
         endif
         icstrt=ndcname
C
C        if no dictionary names have been loaded, clean up
C        the hash table for dictionary names
C
         if(ndict.eq.0) then
           call hash_init(dicnam,dicchain,NUMDICT,ndict,dichash,
     *     NUMHASH)
         endif
         idstrt=ndict
C
C....... Open and store the dictionary
C
         dict_=.true.
         if(fname.eq.' ')            goto 500
         if(nname.gt.0) call err(' Dict_ must precede ocif_')
         dict_=ocif_(fname)
         if(.not.dict_)              goto 500
         dictfl='yes'
C
C        At this point is is proper to update xdicnam to fname
C
         xdicnam = fname         
C
C....... Loop over data blocks; extract _name's, _type etc.
C
200      if(.not.data_(' '))         goto 400
         lbloc = lastnb(bloc_)
         if(bloc_(1:1).eq.'_'.or.glob_.or.bloc_.eq.' ') then
           call tbxxclc(bname,lbname,bloc_(1:lbloc),lbloc)
         else
           call tbxxclc(bname,lbname,'_'//bloc_(1:lbloc),lbloc+1)
         endif
C
C        see if this is a dictionary defining block
C
         do i = 1,2
           if(charnp_(dt(i),name,lstrg)) then
             xdicnam = name(1:lstrg)
             do j = 1,2
               if(test_(dv(j))) then
                 xdicver = strg_(1:max(1,long_))
                 goto 200
               endif  
             enddo
             goto 200
           endif
         enddo
C
Cdbg     WRITE(6,*) ndict,bloc_
C
C        Analyze loop structure for categories, names, types and parents
C
C
C        initalize loop info
C
         icloop = -1
         inloop = -1
         ialoop = -1
         imloop = -1
         iploop = -1
         itloop = -1
         iriloop = -1
         irfloop = -1
         ictype = 0
         intype = 0
         iatype = 0
         imtype = 0
         iptype = 0
         ittype = 0
         iritype = 0
         irftype = 0
         icktype = 0
         ixmtyp = 0
         bcname = ' '
         bpname = ' '
         lbcname = 1
         lbpname = 1
         baname = ' '
         batag = ' '
         lbaname = 1
         btname = ' '
         lbtname = 1
         biname=bloc_
         mycat=0
         loop_=.false.
         loopnl=0
         nmatch=0
         ksmatch=0
         riname = ' '
         lriname = 0
         rfname = ' '
         lrfname = 0
C
C        Pick up category_keys and list_references
C
         do i = 1,2
210        if(charnp_(ck(i),name,lstrg)) then
             if (icktype.ne.0 .and. icktype.ne.i)
     *         call warn
     *         (' Multiple DDL 1 and 2 related key definitions ')
             icktype = i
             if (tbxxnid(name(1:lstrg),ick)) then
               catkey(ick) = .true.
             else
               if(.not.catkey(ick)) then
                 ifind = aroot(ick)
215              catkey(ifind) = .true.
                 ifind = alias(ifind)
                 if (ifind.ne.0) go to 215
               endif
             endif
             if (loop_) go to 210
           endif
         enddo

C
C        Process related items
C
         do i = 1,2
           if(charnp_(ri(i),name,lstrg)) then
             if (iritype.ne.0)
     *         call warn
     *         (' Multiple DDL 1 and 2 related item definitions ')
             iritype = i
             if(loop_) iriloop = loopnl
             call tbxxnlc(riname,name(1:lstrg))
             lriname=long_
C
C            Seek the matching function, may be in the same loop or not
C
             if(charnp_(rf(i),name,lstrg)) then
               if (irftype.ne.0)
     *           call warn
     *           (' Multiple DDL 1 and 2 related item functions ')
               irftype = i
               if (loop_) irfloop = loopnl
               call tbxxnlc(rfname,name(1:lstrg))
               lrfname=long_
             endif
           endif
         enddo
         loop_ = .false.
         loopnl = 0
C
C        Process categories
C
         do i = 1,3
           if(charnp_(ct(i),name,lstrg)) then
             if(ictype.ne.0)
     *         call warn(' Multiple DDL 1 and 2 category definitions ')
             ictype = i
             if(loop_) icloop = loopnl
             call tbxxnlc(bcname,name(1:lstrg))
             lbcname=long_
             nmycat = ndcname+1
             call hash_store(bcname(1:long_),
     *         dcname,dcchain,NUMDICT,ndcname,dchash,NUMHASH,mycat)
             if(mycat.eq.0) then
               call err(' Dictionary category names > NUMDICT ')
             endif
             if (mycat.eq.nmycat) then
               ccatkey(mycat) = 0
               xmcind(mycat)=0
             endif
C
C            if this is not a loop of categories, we expect a match
C            against the block name, unless we are doing replacements
C
             if(.not.loop_) then
               if(ictype.eq.1) then
                 if(bname(1:min(lbname,lbcname+2)).ne.
     *            '_'//bcname(1:lbcname)//'.' 
     *            .and. catchk.eq.'yes'
     *            .and. (rfname(1:7).ne.'replace')) then
                 call warn(' Category id does not match block name')
                 endif
               else
                 if(ictype.eq.2) then
                   if(bcname.ne.'dictionary_definition' .and.
     *                bcname.ne.'category_overview') then
                   if(bname(1:min(lbname,lbcname+2)).ne.
     *               '_'//bcname(1:lbcname)//'_') then
                   if(bname(1:min(lbname,lbcname+1)).ne.
     *               '_'//bcname(1:lbcname) 
     *            .and. catchk.eq.'yes'
     *            .and. (rfname(1:7).ne.'replace')) then
                   call warn(' Category id does not match block name')
                   endif
                   endif
                   endif
                 endif
               endif
             endif
           endif
           loop_ = .false.
           loopnl = 0
         enddo
C
C        Process XML translations
C
         loop_ = .false.
         loopnl = 0
         if(charnp_('_xml_mapping.token',xmtoken,lxmtoken)) then
230        if(charnp_('_xml_mapping.token_type',xmtyp,lxmtyp)) then
             if(charnp_('_xml_mapping.target',xmtarg,lxmtarg)) then
               if (xmnxlat.ge.XMLDEFS) then 
                 call err(' XML translations > XMLDEFS')
               else
                 xmnxlat=xmnxlat+1
                 xmlate(xmnxlat)=xmtarg(1:lxmtarg)
               endif
               if (xmtyp.eq.'data') then
                 ixmtyp = 1
                 if (xmdata.eq.0) then
                   xmdata = xmnxlat
                 else
                   call warn(' XML duplicate DATA_ translation')
                 endif
               endif
               if (xmtyp(1:lxmtyp).eq.'category') then
                 ixmtyp = 2
                 nxmc = ndcname+1
                 call tbxxnlc(xxxtemp,xmtoken(1:lxmtoken))
                 call hash_store(xxxtemp,
     *           dcname,dcchain,NUMDICT,ndcname,dchash,NUMHASH,kxmc)
                 if( kxmc.eq.nxmc) then
                   ccatkey(kxmc) = 0
                   xmcind(kxmc) = xmnxlat
                 else
                   if (xmcind(kxmc).ne.0) then
                     call warn(' XML duplicate category translation')
                   else
                     xmcind(kxmc) = xmnxlat
                   endif 
                 endif
               endif
               if (xmtyp.eq.'item') then
                 ixmtyp = 3
                 if (tbxxnid(xmtoken(1:lxmtoken),ifind)) then
                   xmindex(ifind) = xmnxlat
                 else
                   if (xmindex(ifind).ne.0) then
                     call warn(' XML duplicate item translation')
                   else
                     ifind = aroot(ifind)
 235                 xmindex(ifind) = xmnxlat
                     ifind = alias(ifind)
                     if (ifind.ne.0) go to 235
                   endif
                 endif
               endif
               if(loop_) then
                 if(charnp_('_xml_mapping.token',xmtoken,lxmtoken)) then
                   go to 230
                 else
                   call err(' XML dictionary logic error')
                 endif
               endif
             else
               call err(' XML target missing')
             endif
           else
             call err(' XML token_type missing')
           endif
         else
           xmtoken = bname(1:lbname)
		   lxmtoken=lbname
           if(charnp_('_xml_mapping.token_type',xmtyp,lxmtyp)) then
             if(charnp_('_xml_mapping.target',xmtarg,lxmtarg)) then
               if (xmnxlat.ge.XMLDEFS) then 
                 call err(' XML translations > XMLDEFS')
               else
                 xmnxlat=xmnxlat+1
                 xmlate(xmnxlat)=xmtarg(1:lxmtarg)
               endif
               if (xmtyp(1:lxmtyp).eq.'data') then
                 ixmtyp = 1
                 if (xmdata.eq.0) then
                   xmdata = xmnxlat
                 else
                   call warn(' XML duplicate DATA_ translation')
                 endif
               endif
               if (xmtyp.eq.'category') then
                 ixmtyp = 2
                 nxmc = ndcname+1
                 call tbxxnlc(xxxtemp,xmtoken(1:lxmtoken))
                 call hash_store(xxxtemp,
     *           dcname,dcchain,NUMDICT,ndcname,dchash,NUMHASH,kxmc)
                 if( kxmc.eq.nxmc) then
                   ccatkey(kxmc) = 0
                   xmcind(kxmc) = xmnxlat
                 else
                   if (xmcind(kxmc).ne.0) then
                     call warn(' XML duplicate category translation')
                   else
                     xmcind(kxmc) = xmnxlat
                   endif
                 endif
               endif
               if (xmtyp.eq.'item') then
                 ixmtyp = 3
                 if (tbxxnid(xmtoken(1:lxmtoken),ifind)) then
                   xmindex(ifind) = xmnxlat
                 else
                   if (xmindex(ifind).ne.0) then
                     call warn(' XML duplicate item translation')
                   else
                     ifind = aroot(ifind)
 240                 xmindex(ifind) = xmnxlat
                     ifind = alias(ifind)
                     if (ifind.ne.0) go to 240
                     xmindex(ifind) = xmnxlat
                   endif
                 endif
               endif
               if(loop_) then
                 call err(' XML dictionary logic error')
               endif
             else
               call err(' XML target missing')
             endif
           endif
         endif
C
C        Process names
C
         bxname = ' '
         do i = 1,2
         if(charnp_(nt(i),name,lstrg)) then
           if(intype.ne.0)
     *       call warn(' Multiple DDL 1 and 2 name definitions ')
           intype = i
           bxname = name(1:lstrg)
           if(loop_) inloop = loopnl
         endif
         loop_ = .false.
         loopnl=0
         enddo
         if(intype.eq.0.and.ictype.ne.3.and.(.not.glob_)
     *     .and.bname(1:lbname).ne.' '.and.ixmtyp.eq.0)
     *     call warn (' No name defined in block')
         loop_ = .false.
         if(charnp_(at(1),name,lstrg)) then
           iatype=1
           call tbxxnlc(baname,name(1:lstrg))
           batag = name(1:lstrg)
           lbaname = lstrg
           if(loop_) ialoop = loopnl
         endif
         loop_ = .false.
         loopnl=0
         mcstrg = "no"
         if(ictype.ne.3) then
           do i=1,2
             if(charnp_(tt(i),name,lstrg)) then
               if(ittype.ne.0)
     *           call warn(' Multiple DDL 1 and 2 type definitions ')
               ittype = i
               call tbxxnlc(btname,name(1:lstrg))
               if(loop_) itloop = loopnl
             endif
             loop_ = .false.
             loopnl=0
           enddo
           do i = 1,2
             if(charnp_(mc(i),name,lstrg)) then
               if (imtype.ne.0)
     *           call warn(' Multiple DDL 1 and 2 mandatory codes ')
               imtype = i
               call tbxxnlc(mcstrg,name(1:lstrg))
               if (loop_) imloop = loopnl
             endif
             loop_ = .false.
             loopnl=0
           enddo
         endif
C
C        Now test for consistent combinations
C
         if(inloop.ne.-1) then
           if(icloop.ne.-1.and.icloop.ne.inloop 
     *            .and. catchk.eq.'yes')
     *       call warn(
     *       ' Categories and names in different loops')
           if(iatype.ne.0.and.ialoop.ne.inloop) then
             if(ialoop.eq.-1) then
               if(bxname.ne.bname(1:lbname))
     *          call warn(
     *         ' One alias, looped names, linking to first')
             else
               call warn(
     *         ' Aliases and names in different loops '
     *         //' only using first alias ')
             endif
           endif
           if(itloop.ne.-1.and.itloop.ne.inloop)
     *       call warn(
     *       ' Types and names in different loops')
           if(imloop.ne.-1.and.imloop.ne.inloop)
     *       call warn(
     *       ' Mandatory codes and names in different loops')
         else
           if(icloop.ne.-1)
     *       call warn(
     *         ' Multiple categories for one name')
           if(itloop.ne.-1)
     *       call warn(
     *         ' Multiple types for one name')
           if(imloop.ne.-1)
     *       call warn(
     *         ' Multiple madatory codes for one name')
         endif
C
C        Pick up parents
C
         do i = 1,2
220        if(charnp_(pt(i),bpname,lbpname)) then
             if (iptype.ne.0 .and. iptype.ne.i)
     *         call warn
     *         (' Multiple DDL 1 and 2 parent definitions ')
             iptype = i
             if(loop_) iploop = loopnl
C
C            Seek the matching child, may be in the same loop or not
C
             if (charnp_(pc(i),name,lstrg)) then
               nresult = tbxxnid(name(1:lstrg),ifind)
               nresult = tbxxnid(bpname(1:lbpname),dpindex(ifind))
               bpname = ' '
               lbpname = 1
             endif
             if (loop_) go to 220
           endif
         enddo

C
C        Now we need to process value enumerations and ranges
C        and load them into item value table
C        
         if (tcheck .eq. 'yes' .and. bxname.ne.' ') then
         loop_ = .false.
         nresult = tbxxnid(bxname,ifind)
         
         do i = 1,2
5400       if(charnp_(ve(i),name,lstrg) .and. nivt.lt.NUMIVALS) then
             call tbxxsstb(name(1:lstrg),sindex)
             if (sindex.gt.0) then
               if (deindex(ifind).eq.0) then
                 deindex(ifind)=nivt+1
               else
                 kivt = deindex(ifind)
5410             if (ivtnxt(kivt).ne.0) then
                   kivt = ivtnxt(kivt)
                   go to 5410
                 endif
                 ivtnxt(kivt)=nivt+1
               endif
               nivt = nivt+1
               ivtnxt(nivt)=0
               ivtvet(nivt)=0
               ivtsbp(nivt)=sindex
             endif
           endif
           if (loop_) go to 5400
         enddo


         do i = 1,2
         loop_ = .false.
5420     strg_=' '
         long_=1
         nresult = test_(vr(i))
         if (strg_(1:long_).ne.' '.and.type_.eq.'null') nresult = .true. 
         if (nresult .and. nivt.lt.NUMIVALS) then
           nresult = charnp_(vr(i),name,lstrg)
           if (type_.ne.'char'.and.type_.ne.'numb') then
             name = '.'
             lstrg = 1
           endif
           kvrtp = -1
           if(i.eq.1 .and. lstrg<len(name)-2) then
             strg_=' '
             long_=1
             nresult = test_(vr(3))
             if (strg_(1:long_).ne.' '.and.
     *         type_.eq.'null') nresult = .true. 
             if (nresult) then
               nresult = charnp_(vr(3),
     *           name(lstrg+2:len(name)),kstrg)
               if (type_.ne.'char'.and.type_.ne.'numb') then
                 name(lstrg+2:len(name)) = '.'
                 kstrg = 1
               endif
               if (name(1:lstrg).ne.name(lstrg+2:lstrg+1+kstrg)) 
     *           kvrtp = 1
               name(lstrg+1:lstrg+1)=':'
               lstrg = lstrg+kstrg+1
               endif
             endif
             if (name(1:lstrg).eq.'.:.') then
               loop_=.false.
             else
               call tbxxsstb(name(1:lstrg),sindex)
               if (sindex.gt.0) then
                 if (deindex(ifind).eq.0) then
                   deindex(ifind)=nivt+1
                 else
                   kivt = deindex(ifind)
5430               if (ivtnxt(kivt).ne.0) then
                     kivt = ivtnxt(kivt)
                     go to 5430
                   endif
                   ivtnxt(kivt)=nivt+1
                 endif
                 nivt = nivt+1
                 ivtnxt(nivt)=0
                 ivtvet(nivt)=kvrtp
                 ivtsbp(nivt)=sindex
               endif
               if(loop_) go to 5420
             endif
           endif
         enddo
         endif

C
C        This is the main loop
C
         if(intype.eq.0) go to 200
250      if(.not.charnp_(nt(intype),name,lstrg)) goto 200
         kdict=ndict+1
251      nresult = tbxxnid(name(1:lstrg),ifind)
         if (bpname .ne. ' ') then
           nresult=tbxxnid(bpname(1:lbpname),dpindex(ifind))
           bpname = ' '
           lbpname = 1         
         endif
         nresult = tbxxoid(bxname,jfind)
         if (nresult.and.jfind.ne.ifind.and.deindex(ifind).eq.0) 
     *     deindex(ifind) = deindex(jfind)
         if(ifind.le.idstrt) then
           if(kdup)252,253,254
252        call err(' Duplicate name in dictionary '//
     *       dictag(ifind)(1:lastnb(dictag(ifind))))
253        dicnam(ifind)=char(0)
           goto 251
254        continue       
         endif
         if(dicnam(ifind).eq.bname(1:lbname)) nmatch=ifind
         if(dicnam(ifind)(1:lbname).eq.bname(1:lbname)) ksmatch=ifind
Cdbg     if(dicnam(ifind).ne.bname(1:lbname))
Cdbg *   call warn (' Name mismatch: '//dicnam(ifind)//bname(1:lbname))
         if(inloop.ge.0)then
C
C          We are in a loop of names.  If it is the same loop as
C          for categories, we need to extract the matching category
C
           if(inloop.eq.icloop) then
             mycat=0
             if(charnp_(ct(ictype),name,lstrg)) then
               call tbxxnlc(bcname,name(1:lstrg))
               lbcname=lstrg
               nmycat=ndcname+1
               call hash_store(bcname,
     *         dcname,dcchain,NUMDICT,ndcname,dchash,NUMHASH,mycat)
               if(mycat.eq.0) then
                 call err(' Dictionary category names > NUMDICT ')
               endif
               if(mycat.eq.nmycat) ccatkey(mycat)=0
             endif
           endif
C
C          If it is the same loop as for types, we need to extract
C          the matching type
C
           if(inloop.eq.itloop) then
             btname=' '
             if(charnp_(ct(ittype),name,lstrg)) then
               call tbxxnlc(btname,name(1:lstrg))
               lbtname=lstrg
             endif
           endif
C
C          If it is the same loop as for mandatory codes, we need to extract
C          the matching mandatory
C
           if(inloop.eq.imloop) then
             mcstrg='no'
             if(charnp_(mc(imtype),name,lstrg)) then
               call tbxxnlc(mcstrg,name(1:lstrg))
             endif
           endif
C
C          If it is the same loop as for aliases, we need to extract
C          the matching alias
C
           if(inloop.eq.ialoop) then
             baname=' '
             batag=' '
             if(charnp_(at(1),name,lstrrg)) then
               call tbxxnlc(baname,name(1:lstrg))
               batag = name(1:lstrg)
               lbaname = lstrg
             endif
           endif
         endif
C
C        now we have a name stored in dicnam at location ifind
C        the index of the category in mycat, the type in btname,
C        the alias in baname, and the mandatory code in mcstrg
C
C        First verify match between the name and category, if
C        we have one, or extract from the block name
C
         if (mycat.eq.0) then
         if (dcindex(ifind).eq.0) then
           if (dicnam(ifind).eq.bloc_) then
             call tbxxcat(dicnam(ifind),bcname,lbcname)
Cdbg         call warn(' Extracting category name from block name '
Cdbg *       //bloc_(1:max(1,lastnb(bloc_))))
             if(bcname(1:1).ne.' ') then
               ictype = 1
               nmycat = ndcname+1
               call hash_store(bcname,
     *         dcname,dcchain,NUMDICT,ndcname,dchash,NUMHASH,mycat)
               if(mycat.eq.0) then
                 call err(' Dictionary category names > NUMDICT ')
               endif
               if (mycat.eq.nmycat) then
                 ccatkey(mycat) = 0
                 xmcind(mycat) = 0
               endif
             else 
               if(catchk.eq.'yes')
     *         call warn(' No category defined in block ' 
     *       //bloc_(1:max(1,lastnb(bloc_)))//' and name '
     *       //dictag(ifind)(1:max(1,lastnb(dicnam(ifind))))
     *       //' does not match')
             endif
           endif
         endif
         else
         if (bcname(1:lbcname).ne.'dictionary_definition' .and.
     *     bcname(1:lbcname).ne.'category_overview') then
           if (dicnam(ifind)(1:lbcname+1).ne.'_'//bcname(1:lbcname)
     *        .or.( dicnam(ifind)(lbcname+2:lbcname+2).ne.'_' .and.
     *          dicnam(ifind)(lbcname+2:lbcname+2).ne.'.' .and.
     *          dicnam(ifind)(lbcname+2:lbcname+2).ne.' ' )) then
                if (catchk.eq.'yes'.and.rfname(1:7).ne.'replace') 
     *          call warn(' Item name '//
     *          dictag(ifind)(1:max(1,lastnb(dictag(ifind))))//' '//
     *       ' does not match category name '//bcname(1:lbcname))
           endif
         endif
         endif
C
C        We will need the type in what follows.  cif_mm.dic defines
C        some higher level types.  We map them to primitive types
C
         mapped = btname(1:4)
         do i = 1,16
           if (btname(1:4).eq.map_type(i)) mapped = map_to(i)
         enddo
         if (mapped.ne.'char' .and.
     *       mapped.ne.'text' .and.
     *       mapped.ne.'    ' .and.
     *       mapped.ne.'null' .and.
     *       mapped.ne.'numb' ) then
             if (tcheck .eq. 'yes') then 
               call warn (' Item type '//
     *           btname(1:max(1,lastnb(btname)))//' not recognized')
               mapped = 'char'
             endif
         endif
         
C
C        There are two cases to consider, one if the name is new to
C        the dictionary, the other, if it is not
C
         if(ifind.eq.kdict) then
           aroot(ifind)=ifind
           alias(ifind)=0
           dcindex(ifind)=mycat
           dictyp(ifind)=mapped
           dicxtyp(ifind)=btname
           dmcode(ifind) = 0
           if (mcstrg .eq. 'yes') dmcode(ifind) = 1
           if (mcstrg .eq. 'implicit') dmcode(ifind) = -1
         else
           if(dcindex(ifind).ne.mycat) then
             if(dcindex(ifind).eq.0) then
               jfind=ifind
               if (aroot(ifind).ne.0) jfind=aroot(ifind)
255            continue
               dcindex(jfind)=mycat
               jfind=alias(jfind)
               if(jfind.ne.0) goto 255
             else
               if(mycat.ne.0.and.
     *           (vcheck.eq.'yes'.or.tcheck.eq.'yes')
     *           .and.catchk.eq.'yes')  then
                 if(rfname(1:7).ne.'replace') 
     *           call warn(' Attempt to redefine category for item')
                 endif
             endif
           endif
           if(dictyp(ifind).ne.mapped .or.
     *       dicxtyp(ifind).ne.btname) then
             if(dictyp(ifind).eq.' ') then
               jfind=ifind
               if (aroot(ifind).ne.0) jfind=aroot(ifind)
256            continue
               dictyp(jfind)=mapped
               dicxtyp(jfind)=btname
               jfind=alias(jfind)
               if(jfind.ne.0) go to 256
             else
               if(mapped.ne.' '.and.tcheck.eq.'yes')
     *           call warn(' Attempt to redefine type for item')
             endif
           endif
           if(dmcode(ifind).eq.0) then
             jfind = ifind
             if (aroot(ifind).ne.0) jfind = aroot(ifind)
257          continue
             dmcode(jfind) = 0
             if (mcstrg.eq.'yes') dmcode(jfind) = 1
             if (mcstrg.eq.'implicit') dmcode(jfind) = -1
             jfind=alias(jfind)
             if(jfind.ne.0) go to 257
           else
             if((mcstrg.eq.'yes' .and. dmcode(ifind).lt.0) .or.
     *         (mcstrg.eq.'implicit' .and. dmcode(ifind).gt.0))
     *         call warn(
     *           ' Attempt to redefine mandatory code for item')
           endif
         endif
C
C        now deal with alias, if any.
C
         if(baname.ne.' ') then
           if (tbxxnid(baname(1:lbaname),iafind)) then
             dictag(iafind)    =batag
             aroot(iafind)     =aroot(ifind)
             if(aroot(iafind).eq.0) aroot(iafind)=ifind
             catkey(iafind)    =catkey(ifind)
             alias(ifind)      =iafind
             dcindex(iafind)   =dcindex(ifind)
             dictyp(iafind)    =dictyp(ifind)
             dicxtyp(iafind)   =dicxtyp(ifind)
             xmindex(iafind)   =xmindex(ifind)
             dmcode(iafind)    =dmcode(ifind)
             dpindex(iafind)   =dpindex(ifind)
             deindex(iafind)   =deindex(ifind)
           else
             if(aroot(iafind).ne.0 .and.
     *         aroot(iafind).ne.iafind) then
               if(aroot(iafind).eq.ifind .or.
     *           aroot(iafind).eq.aroot(ifind)) then
                 call warn(' Duplicate definition of same alias')
               else
                 call warn(' Conflicting definition of alias')
               endif
             else
               if((dcindex(iafind).eq.0.or.
     *           dcindex(iafind).eq.dcindex(ifind)).and.
     *           (dictyp(iafind).eq.' '.or.
     *           (dictyp(iafind).eq.dictyp(ifind) .and.
     *            dicxtyp(iafind).eq.dicxtyp(ifind)))) then
                 dcindex(iafind)   =dcindex(ifind)
                 dictyp(iafind)    =dictyp(ifind)
                 dicxtyp(iafind)   =dicxtyp(ifind)
               endif
               if(xmindex(iafind).eq.0) 
     *           xmindex(iafind)=xmindex(ifind)
               if(xmindex(ifind).eq.0)
     *           xmindex(ifind)=xmindex(iafind)
               if (dmcode(iafind).eq.0)
     *           dmcode(iafind)=dmcode(ifind)
               if (dmcode(ifind).eq.0)
     *           dmcode(ifind)=dmcode(iafind)
               if (dpindex(iafind).eq.iafind
     *           .and. dpindex(ifind).ne.ifind)
     *           dpindex(iafind) = dpindex(ifind) 
               if (dpindex(ifind).eq.ifind
     *           .and. dpindex(iafind).ne.iafind)
     *           dpindex(ifind) = dpindex(iafind) 
               if (deindex(ifind).eq.0)
     *           deindex(ifind)=deindex(iafind)
               if (deindex(iafind).eq.0)
     *           deindex(iafind)=deindex(ifind)
               aroot(iafind)     =aroot(ifind)
               if(aroot(iafind).eq.0) aroot(iafind)=ifind
               alias(ifind)      =iafind
               if (catkey(iafind)) catkey(ifind) = .true.
               if (catkey(ifind)) catkey(iafind) = .true.
             endif
           endif
         endif
         if(inloop.ge.0) then
           baname = ' '
           batag = ' '
         endif
C
         if(inloop.ge.0.and.loop_) go to 250
         if(nmatch.eq.0) then
         if ((ksmatch.eq.0.or.inloop.lt.0)
     *     .and.(rfname(1:7).ne.'replace')) then
         call warn(' No name in the block matches the block name')
         endif
         endif
C
C        check for aliases
C        we execute this loop only in the case of unlooped name
C        with looped alias
C
         if(inloop.lt.0.and.ialoop.ge.0) then
           loop_=.false.
           loopnl=0 
           ganame=baname
260        if(.not.charnp_(at(iatype),name,lstrg)) goto 200
           call tbxxnlc(baname,name(1:lstrg))
           batag=name(1:lstrg)
           lbaname=lstrg
           if(baname.eq.ganame) then
             if(loop_) go to 260
             go to 200
           endif
           if(baname.ne.' ') then
             if (tbxxnid(baname(1:lbaname),iafind)) then
             if(iafind.eq.0) call err(' CIFdic names > NUMDICT')
               dictag(iafind)    =batag
               aroot(iafind)     =aroot(ifind)
               if(aroot(iafind).eq.0) aroot(iafind)=ifind
               catkey(iafind)    =catkey(ifind)
               alias(ifind)      =iafind
               dcindex(iafind)   =dcindex(ifind)
               dictyp(iafind)    =dictyp(ifind)
               dicxtyp(iafind)   =dicxtyp(ifind)
               xmindex(iafind)   =xmindex(ifind)
               dmcode(iafind)    =dmcode(ifind)
               dpindex(iafind)   =dpindex(ifind)
               deindex(iafind)   =deindex(ifind)
               ifind=iafind
             else
               if(aroot(iafind).ne.0 .and.
     *           aroot(iafind).ne.iafind) then
                 if(aroot(iafind).eq.ifind .or.
     *             aroot(iafind).eq.aroot(ifind)) then
                   call warn(' Duplicate definition of same alias')
                 else
                   call warn(' Conflicting definition of alias')
                 endif
               else
                 if((dcindex(iafind).eq.0.or.
     *           dcindex(iafind).eq.dcindex(ifind)).and.
     *           (dictyp(iafind).eq.' '.or.
     *           (dictyp(iafind).eq.dictyp(ifind) .and.
     *            dicxtyp(iafind).eq.dicxtyp(ifind)))) then
                 dcindex(iafind)   =dcindex(ifind)
                 dictyp(iafind)    =dictyp(ifind)
                 dicxtyp(iafind)   =dicxtyp(ifind)
                 ifind=iafind
                 endif
                 if(xmindex(iafind).eq.0) 
     *             xmindex(iafind)=xmindex(ifind)
                 if(xmindex(ifind).eq.0)
     *             xmindex(ifind)=xmindex(iafind)
                 if (dmcode(iafind).eq.0)
     *             dmcode(iafind)=dmcode(ifind)
                 if (dmcode(ifind).eq.0)
     *             dmcode(ifind)=dmcode(iafind)
                 if (dpindex(iafind).eq.iafind
     *             .and. dpindex(ifind).ne.ifind)
     *             dpindex(iafind) = dpindex(ifind) 
                 if (dpindex(ifind).eq.ifind
     *             .and. dpindex(iafind).ne.iafind)
     *             dpindex(ifind) = dpindex(iafind)
                 if (deindex(ifind).eq.0)
     *             deindex(ifind) = deindex(iafind)
                 if (deindex(iafind).eq.0)
     *             deindex(iafind) = deindex(ifind)     
                 aroot(iafind)     =aroot(ifind)
                 if(aroot(iafind).eq.0) aroot(iafind)=ifind
                 alias(ifind)      =iafind
                 if (catkey(iafind)) catkey(ifind) = .true.
                 if (catkey(ifind)) catkey(iafind) = .true.
               endif
             endif
           endif
           if(loop_) go to 260
         endif
         go to 200
C
400      bloc_=' '
         if (ndcname.ne.0) then
         do ii = idstrt+1,ndict
         keychain(ii) = 0
         if (aroot(ii).eq.0.and.dcindex(ii).eq.0
     *     .and.catchk.eq.'yes')
     *     call warn(' No category specified for name '//
     *       dictag(ii)(1:max(1,lastnb(dicnam(ii)))))
         enddo
         endif
         do ii = idstrt+1,ndict
         if (dicxtyp(ii).eq.' ') then
           if (dpindex(ii).ne.ii
     *       .and. dicxtyp(dpindex(ii)).ne.' ') then
             dicxtyp(ii) = dicxtyp(dpindex(ii))
             dictyp(ii) = dicxtyp(dpindex(ii))
           else
             dicxtyp(ii) = 'null'
             dictyp(ii) = 'null'
             if (tcheck.eq.'yes')  then
               jj = lastnb(dicnam(ii))
               if (jj.gt.0) then
               if (dicnam(ii)(jj:jj).ne.'_')
     *         call warn(' No type specified for name '//
     *           dictag(ii)(1:max(1,lastnb(dicnam(ii)))))
               endif
             endif
           endif
         endif
         if (catkey(ii) .or. dmcode(ii).gt.0) then
           ifind = aroot(ii)
           mycat = dcindex(ifind)
           if (mycat.ne.0) then
             jj = ccatkey(mycat)
             if (jj.eq.0) then
               ccatkey(mycat) = ifind
             else
410            if (keychain(jj).eq.0) then
                 keychain(jj) = ifind
                 keychain(ifind) = 0
               else
                 if(keychain(jj).ne.ifind) then
                   jj = keychain(jj)
                   goto 410
                 endif
               endif
             endif 
           endif
         endif
         enddo
         if (.not.append_) then
           close(dirdev)
           nrecd=0
         endif
         dictfl='no '
500      continue
         if (append_) then
           nrecd=nrecds
           recend_=recends
           recbeg_=recbegs
         endif
         if(dict_) then
           dicname_=xdicnam
           dicver_ =xdicver
         else
           tcheck = otchk
           vcheck = ovchk
         endif
         if(tcheck.eq.'yes') vcheck='yes'
Cdbg     WRITE(6,'(i5,3x,a,2x,a)') (i,dicnam(i),dictyp(i),i=1,ndict)
         return
         end
C
C
C
C
C
C >>>>>> Create a new dictionary entry, or find a matching existing one
C
         function tbxxnid(xname,ick)
         logical   tbxxnid
         include  'ciftbx.sys'
         character xname*(*)
         character xxxtemp*(NUMCHAR)
         integer   jck, ick, ilen
         tbxxnid = .true.
         ilen = lastnb(xname)
         jck = ndict
         call tbxxnlc(xxxtemp,xname(1:ilen))
         call hash_store(xxxtemp,
     *     dicnam,dicchain,
     *     NUMDICT,ndict,dichash,NUMHASH,ick)
         if(ick.eq.0) call err(' CIFdic names > NUMDICT')
         if(ick .eq. jck+1) then
           dictag(ick) = xname(1:ilen)
           dictyp(ick) = ' '
           dicxtyp(ick) = ' '
           catkey(ick) = .false.
           dpindex(ick) = ick
           deindex(ick) = 0
           alias(ick) = 0
           aroot(ick) = ick
           keychain(ick) = 0
           dcindex(ick) = 0
           xmindex(ick) = 0
           dmcode(ick) = 0
         else
           tbxxnid = .false.
         endif
         return
         end
C
C
C
C
C
C >>>>>> Find matching existing dictionary entry if any
C
         function tbxxoid(xname,ick)
         logical   tbxxoid
         include  'ciftbx.sys'
         character xname*(*)
         character xxxtemp*(NUMCHAR)
         integer   jck, ick, ilen
         tbxxoid = .true.
         ilen = lastnb(xname)
         jck = ndict
         call tbxxnlc(xxxtemp,xname(1:ilen))
         call hash_find(xxxtemp,
     *     dicnam,dicchain,
     *     NUMDICT,ndict,dichash,NUMHASH,ick)
         if(ick.eq.0) tbxxoid = .false.
         return
         end
C
C
C
C
C
C >>>>>> Find position of last non_blank in a string
C        but never less than 1
C
         function lastnb(str)
C
         integer    lastnb
         include   'ciftbx.sys'
         character*(*) str
         integer lenn,ihi,itestl
         lenn = len(str)
c
         ihi = lenn
         if(ihi.eq.0) then
           ihi = 1
           go to 200
         endif
         itestl = ihi/4
         if (itestl.lt.4) go to 200
c
100      if (ihi.gt.itestl) then
         if (str(ihi-itestl+1:ihi-itestl+1).eq.' ') then
           if (str(ihi-itestl+1:ihi).eq.' ') then
             ihi = ihi-itestl
             go to 100
           endif
         endif
         endif
         itestl = itestl/2
         if (itestl.gt.3) go to 100
c
200      if (ihi.gt.1 .and. str(ihi:ihi).eq.' ') then
           ihi = ihi-1
           go to 200
         endif
         lastnb = ihi
         return
         end
C
C
C
C
C
C >>>>>> Convert a character to a radix XXRADIX digit
C
C        given a character c, return a decimal value
C
         function tbxxc2dig(c)
         integer   tbxxc2dig
         character*(*) c
         include  'ciftbx.sys'
C
         tbxxc2dig = ichar(c)-ichar(' ')
C
C        The code above may not be portable, especially to non-ascii
C        computer systems.  In that case, comment out the line above
C        and uncomment the following lines.  Be sure to make the
C        matching change in tbxxd2chr.  Be certain to have at least
C        XXRADIX characters in the search string.
C
C         tbxxc2dig = index(
C     *   '+-01234567890'//
C     *   'abcdefghijlmnopqrstuvwxyz'//
C     *   'ABCDEFGHIJKLMNOPQRSTUVWXYZ',c)-1
         return
         end
C
C
C
C
C
C >>>>>> Convert a radix XXRADIX digit to a character
C
C        given an integer value, return a character
C
         function tbxxd2chr(d)
         character*1 tbxxd2chr
         integer   d
         include  'ciftbx.sys'
C
         tbxxd2chr = char(d+ichar(' '))
C
C        The code above may not be portable, especially to non-ascii
C        computer systems.  In that case, comment out the line above
C        and uncomment the following lines.  Be sure to make the
C        matching change in tbxxc2dig.  Be certain to have at least
C        XXRADIX characters in the search string.
C
C         character*(XXRADIX) digits
C         digits = 
C     *   '+-01234567890'//
C     *   'abcdefghijlmnopqrstuvwxyz'//
C     *   'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
C         tbxxd2chr = digits(d+1:d+1)
         return
         end
C
C
C
C
C
C >>>>>> Convert a string to Run Length Encoded version
C
         subroutine tbxxrle(astr,bstr,mlen)
C
C        astr is the raw input string
C        bstr is the run-length-encoded string
C          beginning with the compressed length in
C            in base-XXRADIX in the first four characters
C          followed by either individual characters or run
C          flagged by XXFLAG
C        XXFLAG//tbxxd2chr(n)//c represents n copies of c
C
         character*(*) astr, bstr
         include  'ciftbx.sys'
         character*1 c
         character*1 tbxxd2chr
         integer tbxxc2dig
         integer klen, krep, ialen, iblen, mode
C
         ialen = len(astr)
         iblen = len(bstr)
         mode = 0
         klen = 4
         bstr(1:4) = tbxxd2chr(0)//tbxxd2chr(0)
     *     //tbxxd2chr(0)//tbxxd2chr(0)
         do ii = 1,ialen
           c = astr(ii:ii)
           if (mode .eq. -2) then
             krep = tbxxc2dig(bstr(klen-1:klen-1))
             if (c.eq.bstr(klen:klen).and.krep.lt.XXRADIX-1) then
               bstr(klen-1:klen-1) = tbxxd2chr(krep+1)
             else
               mode = 0
               if (c.eq.bstr(klen:klen)) mode=-1
             endif
           endif
           if (klen.ge.iblen) go to 100
           if (mode .ge.-1 .and. mode .le.2) then
             klen = klen+1
             bstr(klen:klen) = c
             if (klen .gt. 5) then
               if (c.eq.bstr(klen-1:klen-1)) mode=mode+1
               if (c.ne.bstr(klen-1:klen-1)) mode=0
             endif
             if (c.eq.XXFLAG .and. klen.lt.iblen-1) then
               bstr(klen+1:klen+2) = tbxxd2chr(1)//c
               mode = -2
               klen = klen+2
             endif
           endif
           if (mode.eq.2) then
             bstr(klen-2:klen-1) = XXFLAG//tbxxd2chr(3)
             mode = -2
           endif
         enddo
 100     mlen = klen
         do ii = 4,1,-1
           bstr(ii:ii) = tbxxd2chr(mod(klen,XXRADIX))
           klen = klen/XXRADIX
         enddo
         return
         end
C
C
C
C
C
C >>>>>> Decode a string from  Run Length Encoded version
C
         function tbxxrld(astr,bstr,fill)
C
C        astr is the raw output string
C        bstr is the run-length-encoded string
C          beginning with the compressed length in
C            in base-XXRADIX in the first four characters
C          followed by either individual characters or run
C          flagged by char(0)
C        char(0)//char(n)//c represents n copies of c
C        fill is a logical variable, .true. to fill astr with blanks
C        the return value is the number of valid characters in astr
C        never less than 1
C
C
         character*(*) astr, bstr
         logical fill
         integer tbxxrld
         include  'ciftbx.sys'
         character*1 c
         character*1 tbxxd2chr
         integer tbxxc2dig
         integer klen, krep, ialen, iblen, mode
C
         ialen = len(astr)
         iblen = len(bstr)
         if (fill) then
           astr = ' '
         else
           astr(1:1) = ' '
         endif
         mode = 0
         klen = 0
         do ii = 1,4
           klen = klen*XXRADIX+tbxxc2dig(bstr(ii:ii))
         enddo
         mode = 0
         ipos = 0
         do ii = 5,klen
           c = bstr(ii:ii)
           if(mode.eq.0) then
             if(c.ne.XXFLAG) then
               if (ipos.ge.ialen) then
                 tbxxrld = ialen
                 return
               endif
               ipos = ipos+1
               astr(ipos:ipos) = c
             else
               mode = 1
             endif
           else
             if (mode.eq.1) then
               krep = tbxxc2dig(c)
               mode = -1
             else
               do jj = 1,krep
                 if (ipos.ge.ialen) return
                 ipos=ipos+1
                 astr(ipos:ipos) = c
               enddo
               mode = 0
             endif
           endif
         enddo
         if(ipos .lt. ialen) astr(ipos+1:ipos+1) = ' '
         tbxxrld = max(ipos,1)
         return
         end
C
C
C
C
C
C >>>>>> Extract the item.category_id from a save frame name
C
         subroutine tbxxcat(sfname,bcname,lbcname)
C
         character*(*) sfname,bcname
         integer lbcname,ii,ic,lastnb,lenn
C
C        Note that this logic works only for item.category_id
C        not for category.id
C
         lenn = lastnb(sfname)
         bcname = ' '
         lbcname = 1
         if (lenn.eq.0.or.sfname(1:1).ne.'_') return
         do ii = 1,lenn-2
         ic = 1+lenn-ii
         if (sfname(ic:ic).eq.'.') then
           bcname = sfname(2:ic-1)
           lbcname = ic-2
           return
         endif
         enddo
         return
         end
C
C
C
C
C
C >>>>>> Fetch line from direct access file
C
         subroutine tbxxflin(linno,lip,lipag,lipof,kip,ip,mip,mis)
C
         include   'ciftbx.sys'
C        integer    linno,lip,kip,ip,mip,mis
C
C        linno -- the line number to locate
C        lip   -- the location of the line 
C                   (page*(NUMCPP/NUMCIP)+offset)
C        lipag -- the page number (1...)
C        lipof -- the offset (1...)
C        kip   -- subindex number
C        ip    -- subindex offset
C        mip   -- master index number
C        mis   -- master index offset

         kip = (linno-1)/NUMSIP + 1
         ip = mod(linno-1,NUMSIP) + 1
         mip = (kip-1)/NUMMIP + 1
         mis = mod(kip-1,NUMMIP) + 1
C
C        test subindex page number against number in memory
C
         if (kip.ne.iabs(ipim)) then
C
C          save the current subindex page if it has been written
C
           if (ipim.lt.0) then
             do i = 1,NUMSIP
               write(scrbuf(NUMCIP*(i-1)+1:NUMCIP*i),'(i8)')
     *           ippoint(i)
             enddo
             write(dirdev,'(a)',rec=iabs(iprim)) scrbuf
             ipim = -ipim
           endif
C
C          find the appropriate master index page and slot
C
           if (mip.ne.iabs(mipim)) then
C
C            save the current master index page if it has been written
C
             if (mipim.lt.0) then
               write(scrbuf(1:NUMCIP),'(i)')mipcp
               do i = 1,NUMMIP
                 write(scrbuf(NUMCIP*i+1:NUMCIP*(i+1)),'(i8)')
     *             mippoint(i)
               enddo
               write(dirdev,'(a)',rec=iabs(miprim))scrbuf
               mipim = -mipim
             endif
C
C            search the master index pages for a match
C
             mipno = 0
             miprno = 1
             kzero = 0
             kmode = 1
 10          read(dirdev,'(a)',rec=miprno) scrbuf
             mipno = mipno+1
             read(scrbuf(1:NUMCIP),'(i8)') mipcp
             if (mipno.ne.mip) then
               if (mipcp.eq.0) then
                 if (nfword.gt.1) then
                   nfblock = nfblock+1
                   nfword = 1
                 endif
                 mipcp = nfblock
                 nfblock = nfblock+1
                 write(scrbuf(1:NUMCIP),'(i8)') mipcp
                 write(dirdev,'(a)',rec=miprno) scrbuf
                 scrbuf = ' '
                 write(scrbuf(1:NUMCIP),'(i8)') kzero
                 write(dirdev,'(a)',rec=mipcp) scrbuf
                 kmode = -1
               endif
               miprno = mipcp
               go to 10
             endif
C
C            Have the master index in scrbuf, copy to mippoint
C
             do i = 1,NUMMIP
               if (scrbuf(NUMCIP*i+1:NUMCIP*(i+1)).eq.' ') then
                 mippoint(i) = 0
               else
                 read(scrbuf(NUMCIP*i+1:NUMCIP*(i+1)),'(i8)')
     *             mippoint(i)
               endif
             enddo
             mipim =kmode* mip
             miprim = miprno
           endif
C
C          See if the subindex page exists
C
           if (mippoint(mis).eq.0) then
             do i = 1,NUMSIP
               ippoint(i) = 0
             enddo
             if (nfword.gt.1) then
               nfblock=nfblock+1
               nfword = 1
             endif
             mippoint(mis) = nfblock
             mipim = -iabs(mipim)
             ipim = -kip
             iprim = -nfblock
             scrbuf = ' '
             write(dirdev,'(a)', rec=nfblock) scrbuf
             nfblock = nfblock+1
           else
             read(dirdev,'(a)', rec=mippoint(mis)) scrbuf
             do i = 1,NUMSIP
               if (scrbuf(NUMCIP*(i-1)+1:NUMCIP*i).eq.' ') then
                 ippoint(i) = 0
               else
               read(scrbuf(NUMCIP*(i-1)+1:NUMCIP*i),'(i8)')
     *           ippoint(i)
               endif
             enddo
             ipim = kip
             iprim = mippoint(mis)
           endif
         endif
         lip = ippoint(ip)
         lipag = (lip-1)/(NUMCPP/NUMCIP) + 1
         lipof = mod(lip-1,NUMCPP/NUMCIP) + 1
         lipof = (lipof-1)*NUMCIP + 1
         return
         end
         
C
C
C
C
C
C >>>>>> Store a string in the string table
C
         subroutine tbxxsstb(astrg,sindex)
C
C        store string astrg in the string table, returning the
C        index in sindex
C
         character *(*) astrg
         integer sindex
         include  'ciftbx.sys'
         character *(MAXBUF) temp
         character *(MAXBUF) temp1
         integer mlen, ii, ibstb, icstb, ikstb, rlen
         integer tbxxfstb
         
         call tbxxrle(astrg,temp,mlen)
         icstb = mod(nstable,NUMCSTB)+1
         ibstb = (nstable+NUMCSTB)/NUMCSTB
         iestb = min(NUMCSTB,icstb+mlen-1)
         ikstb = iestb-icstb+1
         if (mlen+nstable .le. NUMCSTB*NUMSTB) then
           stable(ibstb)(icstb:iestb)=temp(1:ikstb)
           sindex = nstable+1
           nstable = nstable+mlen
           rlen = mlen - ikstb           
           if (rlen .gt. 0) then
             do ii = ikstb+1,mlen,NUMCSTB
               ibstb = ibstb+1
               iestb = min(NUMCSTB,rlen)
               stable(ibstb)(1:iestb) = temp(ii:ii+iestb-1)
               rlen = rlen - iestb            
             enddo
           endif
         else
           sindex = 0
           call warn(
     *      ' More than NUMCSTB*NUMSTB stable characters needed')
         endif
         return
         end
         
C
C
C
C
C
C >>>>>> Fetch a string from the string table
C
         function tbxxfstb(astrg,sindex,fill)
C
C        fetch string astrg from the string table, starting at the
C        index in sindex, and returning the valid length.
C
C        fill is a logical variable, .true. to fill astr with blanks
C        the return value is the number of valid characters in astr
C        never less than 1, unless there is no valid string

         integer tbxxfstb
         character *(*)astrg
         integer sindex
         logical fill
         integer tbxxc2dig, tbxxrld
         
         include  'ciftbx.sys'
         character *(MAXBUF) temp

         tbxxfstb = 0

         if (sindex.le.0.or.nstable+3.gt.NUMCSTB*NUMSTB) return

         icstb = mod(sindex-1,NUMCSTB)+1
         ibstb = (sindex-1+NUMCSTB)/NUMCSTB
         iestb = min(NUMCSTB,icstb+3)
         ikstb = iestb-icstb+1
         temp(1:ikstb)=stable(ibstb)(icstb:iestb)
 
         rlen = 4-ikstb
         if (rlen .gt. 0) then
         temp(ikstb+1:4)=stable(ibstb+1)(1:rlen)
         endif
         
         klen = 0
         do ii = 1,4
           klen = klen*XXRADIX+tbxxc2dig(temp(ii:ii))
         enddo

         if (klen.gt.MAXBUF.or.klen.le.0) return
         if (sindex+klen-1.gt.NUMCSTB*NUMSTB) return

         if (klen.gt.4) then
           icstb = mod(sindex+3,NUMCSTB)+1
           ibstb = (sindex+3+NUMCSTB)/NUMCSTB
           iestb = min(NUMCSTB,icstb+klen-5)
           ikstb = iestb-icstb+1
           temp(5:ikstb+4) = stable(ibstb)(icstb:iestb)
           rlen = klen - ikstb - 4
           if (rlen .gt. 0) then
             do ii = ikstb+1,ikstb+rlen,NUMCSTB
               ibstb = ibstb+1
               iestb = min(NUMCSTB,rlen)
               temp(ii:ii+iestb-1) = stable(ibstb)(1:iestb)
               rlen = rlen - iestb            
             enddo
           endif
         endif
         
         tbxxfstb = tbxxrld(astrg,temp(1:klen),fill)
         return
         end
         

C
C
C
C
C
C >>>>>> Open a CIF and copy its contents into a direct access file.
C
         function ocif_(fname)
C
         logical   ocif_
         integer   lastnb
         include  'ciftbx.sys'
         logical   test
         character fname*(*)
         integer   lfname
         integer   case,i,kp,lp,mp,krpp,mpp
C
         save_=.false.
         glob_=.false.
         jchar=MAXBUF
         lastch=0
         if(line_.gt.MAXBUF) call err(' Input line_ value > MAXBUF')
         if(nrecd.ne.0 .and. (.not.append_)) then
           close(dirdev)
           nrecd=0
           lrecd=0
         endif
C
C        clear the memory resident page buffer
C
         do i = 1,NUMPAGE
         mppoint(i)=0
         enddo
C
         case=ichar('a')-ichar('A')
         tab=char(05)
         if(case.lt.0) goto 100
         tab=char(09)
         bloc_=' '
C
C....... Make sure the CIF is available to open
C
100      file_(1:longf_)=' '
         lfname = len(fname)
         file_(1:lfname) = fname
         do 120 i=1,lfname
         if(file_(i:i).eq.' ' .or. file_(i:i).eq.char(0) ) goto 140
120      continue
140      longf_=i-1
         if (longf_.gt.0) then
           inquire(file=file_(1:longf_),exist=test)
           ocif_=test
           if(.not.ocif_)      goto 200
         else
           file_(1:1) = ' '
           longf_ = 1
           ocif_ = .true.
         endif
C
C....... Open up the CIF and a direct access formatted file as scratch
C
         if (file_(1:1).ne.' ')
     *   open(unit=cifdev,file=file_(1:longf_),status='OLD',
     *                    access='SEQUENTIAL',
     *                    form='FORMATTED')
         if(nrecd.eq.0)  then
           open(unit=dirdev,status='SCRATCH',access='DIRECT',
     *                    form='FORMATTED',recl=NUMCPP)
           mipim = -1
           miprim = 1
           mipcp = 0
           ipim = -1
           iprim = 2
           do i = 1,NUMPAGE
             mppoint(i) = 0
           enddo
           do i = 1,NUMMIP
             mippoint(i) = 0
           enddo
           mippoint(1)=2
           do i = 1,NUMSIP
             ippoint(i) = 0
           enddo
           nfblock = 3
           nfword = 1
         endif
		 if (mppoint(1).lt.0) then
            write(dirdev,'(a)',rec=-mppoint(1)) pagebuf(1)
            mppoint(1) = 0
		 endif
         if(append_ .and. nrecd.ne.0) then
           kp = 1
           lp = nfblock
           nfblock = nfblock+1
           mppoint(kp) = lp
           mp = 1
         else
		   do kp = 1,NUMPAGE
		     mppoint(kp)=0
		   enddo
           kp = 1
           lp = 3
           nfblock = 4
           mp = 1
         endif
C
C....... Copy the CIF to the direct access file
C
160      read(cifdev,'(a)',end=180) buffer
         nrecd=nrecd+1
         irecd=nrecd
         klen = lastnb(buffer(1:MAXBUF))
         if (klen.gt.line_)
     *     call warn(' Input line length exceeds line_')
         call tbxxrle(buffer(1:klen),scrbuf,mlen)
         if (mp+mlen-1 .gt. NUMCPP) then
           if (mp.lt.NUMCPP) pagebuf(kp)(mp:NUMCPP) = ' '
C          write(dirdev,'(a)',rec=lp) pagebuf(kp)
           mppoint(kp)=-lp
           if (nfword.gt.1) then
             nfblock = nfblock+1
             nfword = 1
           endif
           lp = nfblock
           nfblock=nfblock+1
           kp = kp+1
           if(kp.gt.NUMPAGE) kp=1
		   if (mppoint(kp).lt.0) then
		     write(dirdev,'(a)',rec=-mppoint(kp)) pagebuf(kp)
		   endif
           mppoint(kp)=0
           mp=1
         endif
         pagebuf(kp)(mp:mp+mlen-1)=scrbuf(1:mlen)
		 mppoint(kp) = -lp
         mlen = ((mlen+NUMCIP-1)/NUMCIP)
         mlen = mlen*NUMCIP
         call tbxxflin(nrecd,lip,lppag,lipof,kip,ip,mip,mis)
         ippoint(ip) = (mp-1)/NUMCIP+(lp-1)*(NUMCPP/NUMCIP)+1
         ipim = -iabs(ipim)
         mp = mp+mlen
         goto 160
C
180      if (mp.lt.NUMCPP) pagebuf(kp)(mp:NUMCPP) = ' '
         if (mp.gt.1) then
C          write(dirdev,'(a)',rec=lp) pagebuf(kp)
           mppoint(kp)=-lp
         endif
         lrecd=max(0,recbeg_-1)
         jrecd=max(0,recbeg_-1)
         jrect=-1
         irecd=max(0,recbeg_-1)
         recn_=irecd
         recend_=nrecd
         if (file_(1:1).ne.' ') close(cifdev)
200      return
         end
C
C
C
C
C
C >>>>>> Close off direct access file of the current CIF
C         and reset all data name tables and pointers       
C
         subroutine purge_
C
         include   'ciftbx.sys'
C
         integer i
         if(nrecd.ne.0) close(dirdev)
         do i = 1,NUMPAGE
           mppoint(i)=0
         enddo
         do i = 1,MAXBOOK
           ibkmrk(1,i)=-1
           ibkmrk(2,i)=-1
           ibkmrk(3,i)=-1
           ibkmrk(4,i)=-1
         enddo
         recn_=0
         save_=.false.
         glob_=.false.
         jchar=MAXBUF
         lastch=0
         nrecd=0
         lrecd=0
         irecd=0
         nname=0
         nhash=0
         iname=0
         loopct=0
         loopnl=0
         loop_=.false.
         text_=.false.
         textfl='no '
         append_=.false.
         recbeg_=0
         recend_=0
         nivt = 0
         nstable = 0
         return
         end
C
C
C
C
C
C >>>>>> Store the data names and pointers for the requested data block
C
         function data_(name) 
C
         logical   data_
         logical   wasave
         logical   tbxxoid, nresult
         integer   lastnb
         include  'ciftbx.sys'
         character name*(*),flag*4,temp*(NUMCHAR),ltype*4
         character ctemp*(NUMCHAR)
         character xdname*(NUMCHAR)
         character ydname*(NUMCHAR)
         character isbuf*(MAXBUF),lsbuf*(MAXBUF)
         logical   ixcat(NUMDICT)
         integer   ndata,idata,nitem,npakt,i,ii,j,k,kchar,krecd
         integer   jj,icc,idd
         integer   fcatnum,lctemp,isrecd,isjchr,islast
         integer   lsrecd,lsjchr,lslast
         integer   pnname,itpos,ipp,ipj
         integer   ltemp
C
         jchar=MAXBUF
         nname=0
         ndata=0
         nhash=0
         nitem=0
         idata=0
         iname=0
         loopct=0
         loopnl=0
         ltype=' '
         posnam_=0
         posval_=0
         posdec_=0
         posend_=0
         data_=.false.
         wasave=.false.
         loop_=.false.
         text_=.false.
         textfl='no '
         glob_=.false.
         do ii = 1,MAXBOOK
         ibkmrk(1,ii)=-1
         enddo
         irecd=lrecd
         lrecd=min(nrecd,recend_)
         if(name(1:1).ne.' ') irecd=max(0,recbeg_-1)
         call hash_init(dname,dchain,NUMBLOCK,nname,dhash,
     *     NUMHASH)
         call hash_init(cname,cchain,NUMBLOCK,ncname,chash,
     *     NUMHASH)
         isrecd=irecd
         isjchr=jchar
         islast=lastch
         lsrecd=isrecd
         lsjchr=isjchr
         lslast=islast
         isbuf=' '
         if(lastch.gt.0)isbuf(1:lastch)=buffer(1:lastch)
         lsbuf=' '
         if(lastch.gt.0)lsbuf(1:lastch)=isbuf(1:lastch)
         call tbxxnlc(xdname,name)
C
C....... Find the requested data block in the file
C
100      lsjchr=isjchr
         call getstr
         isjchr=jchar
         if(irecd.ne.isrecd) then
           lsrecd=isrecd
           lslast=islast
           lsbuf=' '
           if(islast.gt.0)lsbuf(1:islast)=isbuf(1:islast)
           isrecd=irecd
           islast=lastch
           isbuf=' '
           if(lastch.gt.0)isbuf(1:lastch)=buffer(1:lastch)
         endif
         if(type_.eq.'fini')           goto 500
         if(type_.ne.'text')           goto 120
110      call getlin(flag)       
         if(buffer(1:1).ne.';')        goto 110
         jchar=2
         goto 100
120      continue
         if(type_.eq.'save') then
           if(long_.lt.6) then
             if(.not.save_)
     *         call err(' Save frame terminator found out of context ')
             wasave=.true.
             save_=.false.
             goto 100
           else
             if(save_)
     *         call err(' Prior save frame not terminated ')
             save_=.true.
             if(name.eq.' ')          goto 150
             call tbxxnlc(ydname,strg_(6:long_))
             if(ydname.ne.xdname) goto 100
             goto 150
           endif
         endif
         if(type_.eq.'glob') then
           if(name.ne.' ')            goto 100
           glob_=.true.
           goto 150
         endif
         if(type_.eq.'name'.or.type_.eq.'loop') then
           if(name.ne.' ')            goto 100
           if(.not.wasave)
     *       call warn(' Data block header missing ')
           isrecd=lsrecd
           islast=lslast
           isjchr=lsjchr
           isbuf=' '
           if(islast.gt.0)isbuf(1:islast)=lsbuf(1:islast)
           data_=.true.
           bloc_=' '
           itpos=jchar-long_
           if(tabx_) then
           itpos=0
           do ipp=1,jchar-long_
             itpos=itpos+1
             if(buffer(ipp:ipp).eq.tab) itpos=((itpos+7)/8)*8
           enddo
           endif
           posnam_=itpos
           goto 204           
         endif
         if(type_.ne.'data')          goto 100
         if(name.eq.' ')              goto 150
         call tbxxnlc(ydname,strg_(6:long_))
         if(ydname.ne.xdname)   goto 100
150      data_=.true.
         bloc_=strg_(6:long_)
         itpos=jchar-long_
         if(tabx_) then
         itpos=0
         do ipp=1,jchar-long_
           itpos=itpos+1
           if(buffer(ipp:ipp).eq.tab) itpos=((itpos+7)/8)*8
         enddo
         endif
         posnam_=itpos
C
C....... Get the next token and identify
C
200      call getstr
Cdbg     if(dictfl.eq.'no ')
Cdbg *    WRITE(6,*) ltype,type_,loop_,nitem,ndata,idata,iname,nname
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.'null')                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
         if(type_.eq.'null')                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_.eq.'save')           goto 210
         if(type_.eq.'glob')           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.'save')           goto 300
         if(type_.eq.'glob')           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.NUMLOOP) call err(' Number of loop_s > NUMLOOP')
         loorec(loopct)=irecd
         loopos(loopct)=jchar-long_
         if(quote_.ne.' ') loopos(loopct)=jchar-long_-1
         itpos=0
         do ipp=1,loopos(loopct)
           itpos=itpos+1
           if(buffer(ipp:ipp).eq.tab) itpos=((itpos+7)/8)*8
         enddo
         loopox(loopct)=itpos
         goto 200
C
C....... This is the data item; store char position and length
C
220      if(loop_ .and. nitem.eq.0)
     *   call err(' Illegal tag/value construction')
         loop_=.false.
C
         i=nname
         if(nitem.gt.0) i=i-nitem+mod(idata,nitem)+1
         if(i.lt.1) call err(' Illegal tag/value construction')
         if(dtype(i).ne.'test')       goto 223
         if(dictfl.eq.'yes')          goto 223
         if(tcheck.eq.'no ')          goto 223
C>>>>    if(long_.eq.1.and.strg_(1:1).eq.'?') goto 223
C>>>>    if(long_.eq.1.and.strg_(1:1).eq.'.') goto 223
         if(type_.eq.'null')          goto 223
         if(type_.eq.'numb')          goto 223
         call warn( ' Numb type violated  '//dname(i))
223      if(nitem.le.0)               goto 224
         idata=idata+1
         if(dtype(i).eq.'null') dtype(i)=type_
         if(dtype(i).eq.'numb' .and.
     *     (type_.eq.'char'.or.type_.eq.'text')) dtype(i)='char'
224      if(nname.eq.ndata)           goto 230
         ndata=ndata+1
         if(iloop(ndata).gt.1)        goto 225
         krecd=irecd
         kchar=jchar-long_-1
         if(quote_.ne.' ')kchar=kchar-1
225      continue
         if(dtype(ndata).eq.'    ') 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
         if(nloop(ndata).eq.0) dchar(ndata)=0
         if(nloop(ndata).eq.0) iloop(ndata)=long_
250      call getlin(flag)
         if(buffer(1:1).eq.';') then
           jchar=2
           goto 200
         endif
         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      call tbxxclc(temp,ltemp,strg_(1:long_),long_)
         k=0
         if(dictfl.ne.'yes' .and. ndict.gt.0) then
           nresult = tbxxoid(temp(1:ltemp),k)
           if(k.ne.0) then
             if(alias_ .and. aroot(k).ne.0) then
               temp=dicnam(aroot(k))
               ltemp = lastnb(temp)
             endif
           endif
         endif
         pnname=nname
         call hash_store(temp(1:ltemp),
     *   dname,dchain,NUMBLOCK,nname,dhash,
     *     NUMHASH,j)
         if(j.eq.pnname+1) then
           dtag(j)=strg_(1:long_)
           if(k.ne.0) dtag(j)=dictag(k)
           trecd(j)=irecd
           tchar(j)=jchar-long_
           if(quote_.ne.' ') tchar(j)=jchar-long_-1
           itpos=0
           do ipp=1,tchar(j)
             itpos=itpos+1
             if(buffer(ipp:ipp).eq.tab) itpos=((itpos+7)/8)*8
           enddo
           xchar(j)=itpos
         endif
         if(j.eq.0)
     *     call err(' Number of data names > NUMBLOCK')
         if(k.ne.0) then
           ltemp = lastnb(dicnam(k))
           temp(1:ltemp) = dicnam(k)(1:ltemp)
         endif
         if(j.ne.pnname+1) then
           call warn(' Duplicate data item '//
     *     temp(1:ltemp))
           goto 200  
         endif
         dtype(nname)=' '
         dxtyp(nname)=' '
         cindex(nname)=0
         ddict(nname)=0
         ctemp(1:6)='(none)'
         lctemp=6
C
         if(dictfl.eq.'yes' .or. vcheck.eq.'no ') goto 290
         j=k
         if(j.ne.0) then
           ddict(nname)=j
           cindex(nname)=dcindex(j)
           dxtyp(nname)=dicxtyp(j)
           dtype(nname)=dictyp(j)
           if(vcheck.eq.'no ')          goto 280
           if(dictyp(j).eq.'numb') then
             dtype(nname)='test'
           endif
           if(cindex(nname).ne.0) then 
             lctemp=lastnb(dcname(cindex(nname)))
             ctemp(1:lctemp)=dcname(cindex(nname))(1:lctemp)
             goto 290
           endif   
           goto  280
         endif
         call warn(' Data name '//
     *               temp(1:ltemp)
     *               //' not in dictionary!')
280      call tbxxcat(temp(1:ltemp),ctemp,lctemp)
         if (ctemp(1:lctemp).eq.' '.or.
     *     ('_'//ctemp(1:lctemp).eq.temp(1:ltemp))) then
           ctemp = '(none)'
           lctemp= 6
           if (ndcname.ne.0.and.vcheck.eq.'yes')
     *       call warn(' No category defined for '
     *       //temp(1:ltemp))
         else
           call hash_find(ctemp(1:lctemp),
     *       dcname,dcchain,NUMDICT,ndcname,dchash,NUMHASH,j)
           if(j.ne.0) then
             cindex(nname) = j
           else
             ipj=ncname
             call hash_store(ctemp(1:lctemp),
     *         cname,cchain,NUMBLOCK,ncname,chash,NUMHASH,j)
             if (j.eq.0)
     *         call err(' Number of categories > NUMBLOCK ')
             cindex(nname) = -j
             if (ndcname.gt.0.and.j.eq.ipj+1.and.vcheck.eq.'yes'
     *         .and.catchk.eq.'yes')
     *         call warn(' Category '//
     *         ctemp(1:lctemp)//' first implicitly defined in cif ')
           endif
         endif
C
290      lloop(nname)=0
         nloop(nname)=0
         iloop(nname)=0
         if (nitem.eq.0) fcatnum=cindex(nname)
         if(.not.loop_)               goto 200
         nitem=nitem+1
         if(nitem.gt.NUMITEM)
     *     call err(' Items per loop packet > NUMITEM')
         nloop(nname)=loopct
         iloop(nname)=nitem
         if (fcatnum.ne.cindex(nname)) then
           temp = '(none)'
           if (fcatnum.gt.0) temp=dcname(fcatnum)
           if (fcatnum.lt.0) temp=cname(-fcatnum)
           ltemp = lastnb(temp)
           if (ctemp(1:lctemp).ne.temp(1:ltemp)
     *     .and.catchk.eq.'yes')
     *     call warn (' Heterogeneous categories in loop '//
     *     ctemp(1:lctemp)//' vs '//
     *     temp(1:ltemp))
           fcatnum=cindex(nname)
         endif
         goto 200
300      continue
C
C....... Are names checked against dictionary?
C
         if(dictfl.eq.'yes')          goto 500
         if(vcheck.eq.'no '.or.ndict.eq.0) goto 500
         do i=1,nname
           if(dtype(i).eq.'test') dtype(i)='numb'
         enddo
         
C
C        prepare for category and parent checks
C
         if ((catchk.eq.'yes'.or.parchk.eq.'yes')
     *      .and. ndict.gt.0) then
         do i = 1,ndict
           ixcat(i) = .false.
         enddo
C
C        make a pass marking all used tags and their aliases
C
         do i = 1,nname
           icc=cindex(i)
           idd=ddict(i)
           if(icc.ne.0.and.idd.ne.0) then
             icc = aroot(idd)
310          ixcat(icc) = .true.
             icc = alias(icc)
             if (icc.ne.0) goto 310
           endif
         enddo
         endif
C
C        check for category keys
C
C
C
C        now make a pass making certain the keys are
C        used
C
         if(catchk.eq.'yes' .and. ndict.gt.0) then
         do i = 1,nname
           idd=cindex(i)
           if (idd.gt.0) then
             icc=ccatkey(idd)
             if(icc.ne.0) then
             if(aroot(icc).ne.0) icc=aroot(icc)
320          if(icc.ne.0) then
               if(.not.ixcat(icc)) then
                 jj = irecd
                 irecd = drecd(i)
                 if (catkey(icc)) then
                   call warn(' Category key '//
     *               dictag(icc)(1:lastnb(dictag(icc)))//
     *               ' not given for '//
     *               dcname(idd)(1:lastnb(dcname(idd))))
                 else
                   call warn(' Mandatory item '//
     *               dictag(icc)(1:lastnb(dictag(icc)))//
     *               ' not given for '//
     *               dcname(idd)(1:lastnb(dcname(idd))))
                 endif
                 ixcat(icc) = .true.
                 irecd = jj
               endif
               icc = keychain(icc)
               if(icc.ne.0) go to 320
             endif
             endif
           endif      
         enddo
         endif
C
C        check for parents of tags that are used
C
         if(parchk.eq.'yes' .and. ndict.gt.0) then
         do i = 1,nname
           if (ddict(i).ne.0) then
             if (dpindex(ddict(i)).ne.ddict(i)) then
               if (.not.ixcat(dpindex(ddict(i)))) then
                 call warn(' Parent '//
     *             dicnam(dpindex(ddict(i)))
     *             (1:lastnb(dicnam(dpindex(ddict(i)))))//
     *             ' of '//
     *             dname(i)(1:lastnb(dname(i))) //
     *             ' not given')
               endif
             endif
           endif
         enddo     
         endif
         
C
C....... End of data block; tidy up loop storage
C
500      lrecd=irecd-1
         if(type_.eq.'save'.and.long_.lt.6) then
           itpos=jchar-long_
           if(tabx_) then
           itpos=0
           do ipp=1,jchar-long_
             itpos=itpos+1
             if(buffer(ipp:ipp).eq.tab) itpos=((itpos+7)/8)*8
           enddo
           endif
           posval_=itpos
         endif
         irecd=isrecd
         jchar=isjchr
         lastch=islast
         recn_=irecd
         buffer(1:1)=' '
         if(lastch.gt.0)buffer(1:min(MAXBUF,lastch))=isbuf(1:lastch)
         jrecd=irecd
         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 >>>>>> Check dictionary for data name validation    
C
         function dtype_(name,type)
C
         logical    dtype_, tbxxoid, nresult
         include   'ciftbx.sys'
         integer    nln, ii
         character  name*(*),temp*(NUMCHAR),
     *              type*4
C
         character*4 map_type(16),map_to(16),mapped
         data map_type
     *   /'floa','int ','yyyy','symo','ucha','ucod','name','idna',
     *    'any ','code','line','ulin','atco','fax ','phon','emai'/
         data map_to
     *   /'numb','numb','char','char','char','char','char','char',
     *    'char','char','char','char','char','char','char','char'/

C
         type = ' '
         dtype_ = .false.
         nln = min(len(name),len(temp))
         call tbxxnlc(temp(1:nln),name)
         if (ndict.eq.0) go to 200
         nresult = tbxxoid(temp(1:nln),xdchk)
         if(xdchk.eq.0) go to 200
         mapped = dictyp(xdchk)(1:4)
         do ii = 1,16
           if (dictyp(xdchk)(1:4).eq.map_type(ii)) mapped = map_to(ii)
         enddo
         type = mapped
         dtype_ = .true.
200      continue
         return
         end
C
C
C
C
C
C
C >>>>>> Get the attributes of data item associated with data name
C
         function test_(temp)
C
         logical   test_
         include   'ciftbx.sys'
         character  temp*(*),name*(NUMCHAR)
         integer lname
         character  otestf*3
C
         otestf=testfl
         testfl='yes'
         call tbxxclc(name,lname,temp,len(temp))
         test_=.true.   
         if(otestf.eq.'no ' .or. type_.eq.' ')  goto 100
         if(name(1:lname).eq.nametb(1:lnametb))   goto 200
100      call tbxxgitm(name(1:lname))        
200      list_ =loopnl
         if(type_.eq.'null') test_=.false.
         return
         end

C
C
C
C
C
C >>>>>> Set or Reference a bookmark
C
         function bkmrk_(mark)
C
         logical   bkmrk_
         include   'ciftbx.sys'
C
         integer   mark,ii,nitem
         character*4 flag
         bkmrk_=.true.
         if(mark.eq.0) then
           do ii=1,MAXBOOK
             if(ibkmrk(1,ii).lt.0)      goto 100
           enddo
           bkmrk_=.false.
           call warn(' More than MAXBOOK bookmarks requested')
           return
100        mark=ii
           ibkmrk(1,ii)=iname
           ibkmrk(2,ii)=irecd
           ibkmrk(3,ii)=jchar
           if(iname.gt.0) then
             ibkmrk(2,ii) = trecd(iname)
             ibkmrk(3,ii) = tchar(iname)
           endif
           ibkmrk(4,ii)=0
           if(iname.gt.0) then
             if(nloop(iname).ne.0.and.
     *         loopnl.eq.nloop(iname).and.loopct.ne.0) then
               nitem=loopni(nloop(iname))
               ibkmrk(2,ii)=looprd(1)
               ibkmrk(3,ii)=max(0,loopch(1)-1)
               ibkmrk(4,ii)=loopct
             endif
           endif
         else
           if(ibkmrk(1,mark).lt.0) then
             bkmrk_=.false.
             return
           endif
           iname=ibkmrk(1,mark)
           irecd=ibkmrk(2,mark)
           loopct=ibkmrk(4,mark)
           loop_=.false.
           text_=.false.
           textfl = 'no '
           loopnl=-1
           testfl='no '
           if(iname.gt.0) then
            if(nloop(iname).ne.0.and.loopct.ne.0) then
               nitem=loopni(nloop(iname))
               looprd(nitem+1)=ibkmrk(2,mark)
               loopch(nitem+1)=ibkmrk(3,mark)
               do ii = 1,nitem
                 lloop(ii+iname-iloop(iname))=loopct-1
               enddo
               loopct=loopct-1
               if(lloop(iname).gt.0) then
                 loop_=.true.
                 loopnl=nloop(iname)
               endif
             endif
           endif
           jchar=MAXBUF
           if(irecd.gt.0) then
             irecd=irecd-1
             call getlin(flag)
             jchar=ibkmrk(3,mark)
           endif
           ibkmrk(1,mark)=-1
           mark=0
         endif
         return
         end
C
C
C
C
C
C
C >>>>>> Find the location of the requested item in the CIF
C        The argument "name" may be a data item name, blank
C        for the next such item.  The argument "type" may be
C        blank for unrestricted acceptance of any non-comment
C        string (use cmnt_ to see comments), including loop headers,
C        "name" to accept only the name itself and "valu"
C        to accept only the value, or "head" to position to the
C        head of the CIF.  Except when the "head" is requested,
C        the position is  left after the data item provided.
C
         function find_(name,type,strg)
C
         logical   find_
         include   'ciftbx.sys'
         character  name*(*),type*(*),strg*(*),flag*4
         character  jjbuf*(MAXBUF)
         integer    jjchar,jjrecd,jjlast,jjlrec,jjjrec
C
         find_  = .false.
         strg   = ' '
         long_  = 0
         jjchar = jchar
         jjrecd = lrecd
         jjlast = lastch
         jjlrec = lrecd
         jjjrec = jrecd
         jjbuf  = ' '
         if(lastch.gt.0) jjbuf(1:lastch)=buffer(1:lastch)
         if(type.eq.'head') then
           lrecd = min(nrecd,recend_)
           irecd = max(0,recbeg_-1)
           jchar=MAXBUF+1
           call getlin(flag)
           if(flag.eq.'fini')       goto 300
           find_=.true.
           lrecd=max(0,recbeg_-1)
           return
         endif
         if(name.ne.' ') then
           testfl='no '
           call tbxxgitm(name)
           if(iname.eq.0) goto 300
           if(type.eq.'valu') then
             list_=loopnl
             strg=strg_(1:long_)
             find_=.true.
             return
           endif
           if(type.eq.'name'.or.loopnl.eq.0) then
             irecd=trecd(iname)-1
             call getlin(flag)
             jchar=tchar(iname)
             posnam_=jchar+1
             call getstr
             strg=strg_(1:long_)
             recn_=irecd
             find_=.true.
             return
           endif
           if(type.eq.' ') then
             irecd=loorec(loopnl)-1
             call getlin(flag)
             jchar=loopos(loopnl)
             call getstr
             posval_=loopos(loopnl)
             if(tabx_) posval_=loopox(loopnl)
             strg=strg_(1:long_)
             recn_=irecd
             find_=.true.
             return
           endif
           call err(' Call to find_ with invalid arguments')
         endif
         if(name.eq.' ') then
200        call getstr
           if(type_.eq.'fini')      goto 300
           if(type.ne.' '.and.
     *      (type_.eq.'data'.or.type_.eq.'save'.or.
     *      type_.eq.'glob'))   goto 300
           if(type.eq.'name'.and.type_.ne.'name')  goto 200
           if(type.eq.'valu'.and.
     *       type_.ne.'numb'.and.type_.ne.'text'
     *      .and.type_.ne.'char'.and.type_.ne.'null') goto 200
           find_=.true.
           strg=strg_(1:long_)
           if(type_.eq.'name') then
             posnam_=jchar-long_
           else
             posval_=jchar-long_
             if(quote_.ne.' ') posval_=posval_-1
           endif
           recn_=irecd
           return
         endif
    
C
C        Search failed, restore pointers
C
300      irecd  = jjrecd
         lastch = jjlast
         lrecd  = jjlrec
         jchar  = jjchar
         buffer(1:1) = ' '
         if(lastch.gt.0)buffer(1:min(MAXBUF,lastch))=jjbuf(1:lastch)
         jrecd  = jjjrec
         if(jrecd.ne.irecd) jrecd=-1
         recn_  = irecd
C           
         return
         end
C
C
C
C
C
C
C >>>>>> Get the next data name in the data block
C
         function name_(temp)
C
         logical    name_
         include   'ciftbx.sys'
         character  temp*(*)
C
         name_=.false.
         temp=' '
         iname=iname+1
         if(iname.gt.nname)  goto 100
         name_=.true.
         temp=dtag(iname)
         if(ddict(iname).ne.0) temp=dictag(ddict(iname))
100      return
         end
C
C
C
C
C
C
C >>>>>> Extract a number data item and its standard deviation
C        This version return single precision numbers
C
         function numb_(temp,numb,sdev)
C
         logical    numb_
         include   'ciftbx.sys'
         character  temp*(*),name*(NUMCHAR)
         integer    lname
         real       numb,sdev
C
         call tbxxclc(name,lname,temp,len(temp))
         if(testfl.eq.'no ')  goto 100
         if(name(1:lname).eq.nametb(1:lnametb))   goto 150
C
100      call tbxxgitm(name(1:lname))
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 number data item and its standard deviation
C        This version returns double precision numbers
C
         function numd_(temp,numb,sdev)
C
         logical    numd_
         include   'ciftbx.sys'
         character  temp*(*),name*(NUMCHAR)
         integer    lname
         double precision numb,sdev
C
         call tbxxclc(name,lname,temp,len(temp))
         if(testfl.eq.'no ')  goto 100
         if(name(1:lname).eq.nametb(1:lnametb))   goto 150
C
100      call tbxxgitm(name(1:lname))
C
150      numd_=.false.
         if(type_.ne.'numb') goto 200
         numd_=.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
         logical    char_, charnp_
         include   'ciftbx.sys'
		 character  temp*(*), strg*(*)
		 integer    lstrg,nstrg
		 
		 nstrg = len(strg)
		 char_ = charnp_(temp,strg,lstrg)
		 
	     if (lstrg.lt.len(strg)) strg(lstrg+1:nstrg) = ' '
		 return
		 end

C >>>>>> Extract a character data item.
C
         function ochar_(temp,strg)
C
         logical    ochar_
         include   'ciftbx.sys'
         character  temp*(*),name*(NUMCHAR)
         character  strg*(*),flag*4
         character*1 slash
         integer    icpos,itpos,ixpos,ixtpos,ipp,iepos,ispos
         integer    ltemp, lname
C
         slash = '\\'
         ltemp = lastnb(temp)
         call tbxxclc(name,lname,temp,ltemp)
         if(testfl.eq.'yes')    goto 100
         if(.not.text_)         goto 120
         if(name(1:lname).ne.nametb(1:lnametb))     goto 120
         ochar_=.false.
         text_=.false.
         strg=' '
         long_=0
         call getlin(flag)
         if(flag.eq.'fini')    goto 200
         if(buffer(1:1).eq.';') then
           jchar=2
           textfl = 'no '
           goto 200
         endif
         quote_=' '
         jchar=lastch+1
         long_=max(1,lastch)
         strg_(1:long_)=buffer(1:long_)
         goto 150
C
100      if(name(1:lname).eq.nametb(1:lnametb))     goto 150
C
120      call tbxxgitm(name(1:lname))
         if(type_.eq.'null') then
           ochar_=.false.
           text_=.false.
           textfl = 'no '
           strg_=' '
           long_=0
           goto 200
         endif
C
150      ochar_=.true.
         text_=.false.
         if(tabx_) then
           call detab
           icpos=jchar-long_
           if(quote_.ne.' ') icpos=icpos-1
           iepos=icpos+long_-1
           itpos=0
           do ipp=1,icpos
             itpos=itpos+1
             if(buffer(ipp:ipp).eq.tab) itpos=((itpos+7)/8)*8
           enddo
           ispos=itpos
160        ixpos=index(buffer(icpos:iepos),tab)
           ixtpos=itpos+ixpos-1
           if(ixpos.gt.0.and.ixtpos.le.MAXBUF) then
             ixtpos=((ixtpos+7)/8)*8
             icpos=icpos+ixpos
             itpos=ixtpos+1
             if(icpos.le.iepos) goto 160
           else
           strg =
     *       bufntb(ispos:min(MAXBUF,itpos+iepos-icpos))
           long_=min(MAXBUF,itpos+iepos-icpos)-ispos+1
           if(ispos.eq.1.and.strg(1:1).eq.';') then
             strg(1:1) = ' '
             if(strg(1:long_).eq.(' '//slash)) then
               fold_=.true.
               if(unfold_) then
                 strg_(1:long_)=slash
                 long_=1
               endif
             endif
           endif
           endif
         else
           strg=' '
           if(long_.gt.0) then
             strg=strg_(1:long_)
           endif
         endif
         if(type_.eq.'char')   goto 200
         ochar_=.false.
         if(type_.ne.'text')   goto 200
         ochar_=.true.
         call getlin(flag)
         jchar=MAXBUF+1
         if(flag.eq.'fini')    goto 200
         if(buffer(1:1).eq.';')then
           jchar=2
           textfl = 'no '
           goto 200
         endif
         irecd=irecd-1
         text_=.true. 
         if (long_.gt.0) then
         if (unfold_ .and. strg(long_:long_).eq.slash) then
170        klow = long_
           long_ = long_-1
           call getlin(flag)
           if(flag.eq.'fini')    goto 210
           if(buffer(1:1).eq.';') then
             jchar=2
             textfl = 'no '
           goto 210
           endif
           quote_=' '
           jchar=lastch+1
           long_=min(len(strg_),klow+max(1,lastch)-1)
           strg_(klow:long_)=buffer(1:max(1,lastch))
           if(tabx_) then
             call detab
             icpos=jchar-long_
             if(quote_.ne.' ') icpos=icpos-1
             iepos=icpos+long_-1
             itpos=0
             do ipp=1,icpos
               itpos=itpos+1
               if(buffer(ipp:ipp).eq.tab) itpos=((itpos+7)/8)*8
             enddo
             ispos=itpos
180          ixpos=index(buffer(icpos:iepos),tab)
             ixtpos=itpos+ixpos-1
             if(ixpos.gt.0.and.ixtpos.le.MAXBUF) then
               ixtpos=((ixtpos+7)/8)*8
               icpos=icpos+ixpos
               itpos=ixtpos+1
               if(icpos.le.iepos) goto 180
             else
               if (ispos.eq.1 .and. bufntb(1:1).eq.';') go to 210
               long_=min(len(strg_),klow+itpos+iepos-icpos-ispos)
               strg(klow:long_) =
     *         bufntb(ispos:min(MAXBUF,itpos+iepos-icpos))
             endif
           else
             strg(long_:long_)=' '
             if(lastch.gt.0) then
               long_=min(len(strg),klow+lastch-1)
               if(long_.ge.klow) strg(klow:long_)=buffer(1:lastch)
             endif
           endif
           if( strg(long_:long_).eq.slash ) go to 170
         endif
         endif
C
200      testfl='no '
         return
C
210      text_ = .false.
         go to 200
C
         end
C
C
C
C
C
C >>>>>> Extract a character data item, no padding.
C
         function charnp_(temp,strg,lstrg)
C
         logical    charnp_
         include   'ciftbx.sys'
         character  temp*(*),name*(NUMCHAR)
         character  strg*(*),flag*4
		 integer    lstrg
         character*1 slash
         integer    icpos,itpos,ixpos,ixtpos,ipp,iepos,ispos
         integer    ltemp, lname
C
         slash = '\\'
         ltemp = lastnb(temp)
         call tbxxclc(name,lname,temp,ltemp)
         if(testfl.eq.'yes')    goto 100
         if(.not.text_)         goto 120
         if(name(1:lname).ne.nametb(1:lnametb))     goto 120
         charnp_=.false.
         text_=.false.
         strg(1:1)=' '
         long_=0
		 lstrg = 1
         call getlin(flag)
         if(flag.eq.'fini')    goto 200
         if(buffer(1:1).eq.';') then
           jchar=2
           textfl = 'no '
           goto 200
         endif
         quote_=' '
         jchar=lastch+1
         long_=max(1,lastch)
         strg_(1:long_)=buffer(1:long_)
         goto 150
C
100      if(name(1:lname).eq.nametb(1:lnametb))     goto 150
C
120      call tbxxgitm(name(1:lname))
         if(type_.eq.'null') then
           charnp_=.false.
           text_=.false.
           textfl = 'no '
           strg_=' '
           long_=0
           goto 200
         endif
C
150      charnp_=.true.
         text_=.false.
         if(tabx_) then
           call detab
           icpos=jchar-long_
           if(quote_.ne.' ') icpos=icpos-1
           iepos=icpos+long_-1
           itpos=0
           do ipp=1,icpos
             itpos=itpos+1
             if(buffer(ipp:ipp).eq.tab) itpos=((itpos+7)/8)*8
           enddo
           ispos=itpos
160        ixpos=index(buffer(icpos:iepos),tab)
           ixtpos=itpos+ixpos-1
           if(ixpos.gt.0.and.ixtpos.le.MAXBUF) then
             ixtpos=((ixtpos+7)/8)*8
             icpos=icpos+ixpos
             itpos=ixtpos+1
             if(icpos.le.iepos) goto 160
           else
           strg =
     *       bufntb(ispos:min(MAXBUF,itpos+iepos-icpos))
           long_=min(MAXBUF,itpos+iepos-icpos)-ispos+1
           if(ispos.eq.1.and.strg(1:1).eq.';') then
             strg(1:1) = ' '
             if(strg(1:long_).eq.(' '//slash)) then
               fold_=.true.
               if(unfold_) then
                 strg_(1:long_)=slash
                 long_=1
               endif
             endif
           endif
           endif
         else
           strg(1:1)=' '
		   lstrg = 1
           if(long_.gt.0) then
             strg=strg_(1:long_)
			 lstrg = long_
           endif
         endif
         if(type_.eq.'char')   goto 200
         charnp_=.false.
         if(type_.ne.'text')   goto 200
         charnp_=.true.
         call getlin(flag)
         jchar=MAXBUF+1
         if(flag.eq.'fini')    goto 200
         if(buffer(1:1).eq.';')then
           jchar=2
           textfl = 'no '
           goto 200
         endif
         irecd=irecd-1
         text_=.true. 
         if (long_.gt.0) then
         if (unfold_ .and. strg(long_:long_).eq.slash) then
170        klow = long_
           long_ = long_-1
           call getlin(flag)
           if(flag.eq.'fini')    goto 210
           if(buffer(1:1).eq.';') then
             jchar=2
             textfl = 'no '
           goto 210
           endif
           quote_=' '
           jchar=lastch+1
           long_=min(len(strg_),klow+max(1,lastch)-1)
           strg_(klow:long_)=buffer(1:max(1,lastch))
           if(tabx_) then
             call detab
             icpos=jchar-long_
             if(quote_.ne.' ') icpos=icpos-1
             iepos=icpos+long_-1
             itpos=0
             do ipp=1,icpos
               itpos=itpos+1
               if(buffer(ipp:ipp).eq.tab) itpos=((itpos+7)/8)*8
             enddo
             ispos=itpos
180          ixpos=index(buffer(icpos:iepos),tab)
             ixtpos=itpos+ixpos-1
             if(ixpos.gt.0.and.ixtpos.le.MAXBUF) then
               ixtpos=((ixtpos+7)/8)*8
               icpos=icpos+ixpos
               itpos=ixtpos+1
               if(icpos.le.iepos) goto 180
             else
               if (ispos.eq.1 .and. bufntb(1:1).eq.';') go to 210
               long_=min(len(strg_),klow+itpos+iepos-icpos-ispos)
               strg(klow:long_) =
     *         bufntb(ispos:min(MAXBUF,itpos+iepos-icpos))
             endif
           else
             strg(long_:long_)=' '
             if(lastch.gt.0) then
               long_=min(len(strg),klow+lastch-1)
               if(long_.ge.klow) strg(klow:long_)=buffer(1:lastch)
             endif
           endif
           if( strg(long_:long_).eq.slash ) go to 170
         endif
         endif
C
200      testfl='no '
         if(long_.eq.0) strg(1:1)=' '
		 lstrg = max(1,long_)
         return
C
210      text_ = .false.
         go to 200
C
         end
C
C
C
C
C
C
C >>>>>> Extract a comment field.               
C
         function cmnt_(strg)          
C
         logical   cmnt_
         integer   lastnb
         include  'ciftbx.sys'
         character strg*(*),flag*4,c*1,
     *     jjbuf*(MAXBUF)
         integer   jjchar,jjrecd,jjlast,jjlrec,jjjrec
         integer   ipp,itpos,ixpos
         integer   klow
         character*1 slash
C
         jjchar = jchar
         jjrecd = irecd
         jjlast = lastch
         jjlrec = lrecd
         jjjrec = jrecd
         jjbuf=' '
         slash = '\\'
         if(lastch.gt.0)jjbuf(1:lastch)=buffer(1:lastch)
         lrecd = nrecd
         if(bloc_.eq.' ') then
           if(irecd.eq.0) jchar=MAXBUF
         endif
         strg=' '
         long_=0
         cmnt_=.false.
         goto 105
100      jchar=jchar+1
105      if(jchar.le.lastch)     goto 140
C
C....... Read a new line
C
110      call getlin(flag)
         if(flag.eq.'fini') then
           strg='fini'
           jchar=MAXBUF+1
           long_=4
           cmnt_=.false.
           return
         endif
         jchar=1
         strg=char(0)
         long_=1
         posnam_=0
         quote_=' '
         goto 220
140      if(lastch.eq.1.and.buffer(1:1).eq.' ') go to 200
C
C....... Process this character in the line
C
150      c=buffer(jchar:jchar)
         if(c.eq.' ')       goto 100
         if(c.eq.tab.and.(.not.tabx_)) goto 190
         if(c.eq.tab)       goto 100
         if(c.eq.'#')       goto 200
         goto 300
C
C        For a tab, when not expanding to blanks, accept
C        that single character as a comment
C
190      long_=1
         strg=tab
         posnam_=jchar
         jchar=jchar+1
         goto 220
C
C....... Accept the remainder of the line as a comment 
C
200      long_=lastch-jchar
         quote_=buffer(jchar:jchar)
         itpos=jchar
         if(tabx_) then
           itpos=0
           do ipp=1,jchar
             itpos=itpos+1
             if(buffer(ipp:ipp).eq.tab) itpos=((itpos+7)/8)*8
           enddo
         endif
210      posnam_=itpos
         if(long_.gt.0) then
           if(tabx_) then
             call detab
             ixpos= lastnb(bufntb)
             strg = bufntb(itpos+1:ixpos)
           else
             strg = buffer(jchar+1:lastch)
           endif
         endif
         if(long_.le.0) then
           strg=' '
           long_=1
         endif
         if (strg.eq.slash .and. unfold_) go to 390
         jchar=MAXBUF+1
220      lrecd=jjlrec
         cmnt_=.true.
         return
C
C....... Found a non-comment field, restore pointers
C
300      irecd = jjrecd
         lastch = jjlast
         lrecd = jjlrec
         jchar = jjchar
         buffer(1:1)=' '
         if(lastch.gt.0)buffer(1:min(MAXBUF,lastch))=jjbuf(1:lastch)
         jrecd=jjjrec
         if(jrecd.ne.irecd) jrecd=-1
         recn_=irecd
         return
C
C....... Got a comment with a folding flag
C
390      klow = 1
         lrecd=jjlrec
         cmnt_=.true.
         strg(1:1)=' '
400      jjchar = MAXBUF+1
         lrecd = nrecd
         if(bloc_.eq.' ') then
           if(irecd.eq.0) jchar=MAXBUF
         endif
         long_=0
         go to 420
410      jchar=jchar+1
         if(jchar.le.lastch) go to 450
420      call getlin(flag)
         jchar = 1
         jjchar = 1
         if(flag.eq.'fini') then
           strg='fini'
           jchar=MAXBUF+1
           long_=lastnb(strg)
           return
         endif
         jchar=1
450      if(lastch.eq.1.and.buffer(1:1).eq.' ') go to 400
C
C....... Process this character in the line
C
460      c=buffer(jchar:jchar)
         if(c.eq.' '.or.c.eq.tab)      goto 410
         if(c.eq.'#')       goto 470
         goto 500
C
C....... Accept the remainder of the line as part of the comment 
C
470      long_=lastch-jchar
         itpos=jchar
         if(tabx_) then
           itpos=0
           do ipp=1,jchar
             itpos=itpos+1
             if(buffer(ipp:ipp).eq.tab) itpos=((itpos+7)/8)*8
           enddo
         endif
         if(long_.gt.0) then
           if(tabx_) then
             call detab
             ixpos= lastnb(bufntb)
             if(ixpos.gt.itpos)
     *          strg(klow:min(len(strg),klow+ixpos-2)) = 
     *          bufntb(itpos+1:ixpos)
           else
             if(lastch.gt.jchar)
     *          strg(klow:min(len(strg),klow+lastch-2)) = 
     *          buffer(jchar+1:lastch)
           endif
         endif
         klow=lastnb(strg)
           if (strg(klow:klow).eq.slash) then
             strg(klow:klow)=' '
             go to 400
           endif
         jchar=MAXBUF+1
         long_ = klow
         lrecd=jjlrec
         return
C
C....... Found a non-comment field, restore pointers, but return the
C        comment found so far
C
500      jchar = jjchar
         return

         end
C
C
C
C
C
C >>>>> Convert name string to lower case
C        
         function locase(name)
C
         include     'ciftbx.sys'
         character    locase*(MAXBUF)
         character    temp*(MAXBUF),name*(*)
         character    low*26,cap*26,c*1
         integer      i,j,kln
         data  cap /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
         data  low /'abcdefghijklmnopqrstuvwxyz'/
C
         temp=name
         kln = lastnb(name)
         do 100 i=1,kln
         c=temp(i:i)
         j=index(cap,c)
         if(j.ne.0) temp(i:i)=low(j:j)        
100      continue
200      locase=temp
         return
         end
C
C
C
C
C
C >>>>> Convert name string to lower case as subroutine
C        
         subroutine tbxxnlc(loname, name)
C
         include     'ciftbx.sys'
         character    temp*(MAXBUF),loname*(*),name*(*)
         character    low*26,cap*26,c*1
         integer      i,j,kln
         integer      lolen,olen
         data  cap /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
         data  low /'abcdefghijklmnopqrstuvwxyz'/
C
         lolen = len(loname)
         olen = len(name)
         kln = min(MAXBUF,lolen,olen)
         kln = lastnb(name(1:kln))
         temp(1:kln)=name(1:kln)
         do 100 i=1,kln
         c=temp(i:i)
         j=index(cap,c)
         if(j.ne.0) temp(i:i)=low(j:j)        
100      continue
200      loname=temp(1:kln)
         return
         end
C
C
C
C
C
C >>>>> Convert counted name string to lower case as subroutine
C       with counts
C        
         subroutine tbxxclc(loname, lloname, name, lname)
C
         include     'ciftbx.sys'
         character    temp*(MAXBUF),loname*(*),name*(*)
         integer      lloname, lname
         character    low*26,cap*26,c*1
         integer      i,j,kln
         integer      lolen,olen
         data  cap /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
         data  low /'abcdefghijklmnopqrstuvwxyz'/
C
         lolen = len(loname)
         olen = min(len(name),lname)
         kln = min(MAXBUF,lolen,olen)
         kln = lastnb(name(1:kln))
         temp(1:kln)=name(1:kln)
         do 100 i=1,kln
         c=temp(i:i)
         j=index(cap,c)
         if(j.ne.0) temp(i:i)=low(j:j)        
100      continue
200      loname(1:kln)=temp(1:kln)
         lloname = kln
         return
         end

C
C
C
C
C
C >>>>> Convert name string to upper case
C        
         function upcase(name)
C
         include     'ciftbx.sys'
         character    upcase*(MAXBUF)
         character    temp*(MAXBUF),name*(*)
         character    low*26,cap*26,c*1
         integer      i,j,kln
         data  cap /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
         data  low /'abcdefghijklmnopqrstuvwxyz'/
C
         temp=name
         kln = lastnb(name)
         do 100 i=1,kln
         c=temp(i:i)
         j=index(low,c)
         if(j.ne.0) temp(i:i)=cap(j:j)        
100      continue
200      upcase=temp
         return
         end
C
C
C
C
C
C >>>>> Convert name string to upper case as subroutine
C        
         subroutine nupcase(upname, name)
C
         include     'ciftbx.sys'
         character    temp*(MAXBUF),upname*(*),name*(*)
         character    low*26,cap*26,c*1
         integer      i,j,kln
         integer      lolen,olen
         data  cap /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
         data  low /'abcdefghijklmnopqrstuvwxyz'/
C
         uplen = len(upname)
         olen = len(name)
         kln = min(MAXBUF,uplen,olen)
         kln = lastnb(name(1:kln))
         temp(1:kln)=name(1:kln)
         do 100 i=1,kln
         c=temp(i:i)
         j=index(low,c)
         if(j.ne.0) temp(i:i)=cap(j:j)        
100      continue
200      upname=temp(1:kln)
         return
         end

C
C
C
C
C
C >>>>>> Get the data item associated with the tag.
C
         subroutine tbxxgitm(name)
C
         include   'ciftbx.sys'
         SAVE
         character name*(*)
         character flag*4
         character*1 slash
         integer   iitem,nitem,npakt
         integer   kchar,loopi,i,jdict,itpos,ipp
         logical   tbxxoid
C
         slash = '\\'
C
C....... Find requested dataname in hash list
C
         lnametb=lastnb(name)
         nametb(1:lnametb)=name(1:lnametb)
         posnam_=0
         posval_=0
         posdec_=0
         posend_=0
         valid_ = .false.
         quote_=' '
         jdict = 0
         if(name(1:1).eq.'_')       goto 100
         type_='null'
         dictype_='null'
         diccat_='(none)'
         dicname_=name
         dicpname_=name
         tagname_=' '
         strg_=' '
         long_=1
         goto 1000
100      call hash_find(nametb(1:lnametb),
     *     dname,dchain,NUMBLOCK,nname,dhash,NUMHASH,
     *     iname)
         if(iname.gt.0) go to 180
         if(dictfl.ne.'yes') then
         if (tbxxoid(nametb(1:lnametb),jdict)) then
           dictype_=dicxtyp(jdict)
           if(dcindex(jdict).ne.0) diccat_=dcname(dcindex(jdict))
           dicname_=dictag(jdict)
           dicpname_=dictag(dpindex(jdict))
           if(aroot(jdict).ne.0) then
             dicname_=dictag(aroot(jdict))
             dicpname_=dictag(dpindex(aroot(jdict)))
             call hash_find(dicnam(aroot(jdict)),
     *         dname,dchain,NUMBLOCK,nname,dhash,NUMHASH,
     *         iname)
             if(iname.gt.0)      goto 180
           endif
           type_='null'
           tagname_=' '
           strg_=' '
           long_=1
           go to 1000
         endif
         endif
160      continue
         type_='null'
         dictype_='null'
         diccat_='(none)'
         dicname_=name
         long_=1
         goto 1000
C
C
180      tagname_=dtag(iname)
         if(ddict(iname).ne.0) tagname_=dictag(ddict(iname))
         posnam_=tchar(iname)
         if(tabx_)posnam_=xchar(iname)
         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.
         loopct=0
         loopnl=nloop(iname)
         nitem=loopni(loopnl)
         npakt=loopnp(loopnl)
         irecd=drecd(iname)-1
         call getlin(flag)
         jchar=max(0,dchar(iname)-1)
Cdbg     if(jchar.lt.0) write(6,'(7H dchar ,i5)') jchar
         do 220 i=1,nitem
220      lloop(i+iname-iloop(iname))=0
         goto 240
C
C....... Read a packet of loop items
C
230      nitem=loopni(loopnl)
         npakt=loopnp(loopnl)
         irecd=looprd(nitem+1)-1
         call getlin(flag)
         jchar=loopch(nitem+1)
Cdbg     if(jchar.lt.0) write(6,'(7H 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_
         if(quote_.ne.' ')loopch(iitem)=jchar-long_-1
         loopln(iitem)=long_
         looprd(iitem)=irecd
         if(buffer(1:1).ne.';'.or.loopch(iitem).ne.1)
     *                          goto 250
260      call getlin(flag)
         if(flag.eq.'fini') call err(' Unexpected end of data')
         if(buffer(1:1).ne.';') goto 260
         jchar=2
         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)
         dictype_=dxtyp(iname)
         diccat_='(none)'
         if(cindex(iname).gt.0) diccat_=dcname(cindex(iname))
         if(cindex(iname).lt.0) diccat_=cname(-cindex(iname))
         if(diccat_.eq.' ') diccat_='(none)'
         dicname_=dtag(iname)
         if(ddict(iname).ne.0) then
           if (aroot(ddict(iname)).ne.0) then
             dicname_=dictag(aroot(ddict(iname)))
           endif
         endif
         strg_=' '
         if(long_.gt.0) then
           strg_(1:long_)=buffer(kchar:kchar+long_-1)
         endif
         itpos=kchar
         if(tabx_) then
         itpos=0
         do ipp=1,kchar
           itpos=itpos+1
           if(buffer(ipp:ipp).eq.tab) itpos=((itpos+7)/8)*8
         enddo
         endif
         posval_=itpos
         posend_=itpos+long_-1
         jchar=kchar+long_
         if(jchar.le.MAXBUF) then
           if(buffer(jchar:jchar).ne.' ' .and.
     *       buffer(jchar:jchar).ne.tab) jchar=jchar+1
         endif
         quote_=' '
         if(kchar.gt.1) then
           if(buffer(kchar-1:kchar-1).ne.' ' .and.
     *        buffer(kchar-1:kchar-1).ne.tab) then
             quote_=buffer(kchar-1:kchar-1)
           endif
         endif
         if(type_.eq.'char' .and. kchar.eq.1 .and.
     *     buffer(1:1).eq.';') then
           type_='text'
           fold_=.false.
         endif
         if(type_.eq.'text') then
           if(buffer(1:1).eq.';') then
             strg_(1:1)=' '
             if (strg_(1:long_).eq.(' '//slash) ) then
               fold_=.true.
               if(unfold_) then
                 strg_(1:long_)=slash
                 long_=1
               endif
             endif
           else
             type_='char'
           endif
         endif
         if(type_.eq.'numb') then
           call ctonum
           if(posdec_.gt.0) posdec_=posval_+posdec_-1
         endif
         if(type_.eq.'char' .and. strg_.eq.' '.and.nblank_) 
     *     type_='null'
         if (quote_.ne.' ') goto 1000
         if (long_.eq.1.and.strg_(1:1).eq.'?') type_='null'
         if (long_.eq.1.and.strg_(1:1).eq.'.') type_='null'
         if (tcheck.eq.'yes') then
           if (tbxxoid(nametb(1:lnametb),jdict))
     *     call tbxxckv(jdict)
         endif
C
1000     return
         end

C
C
C
C
C
C
C
C >>>>>> Convert string to integer, marking non-digit
C
C
         function tbxxsti(xstr,nondig)
         integer tbxxsti
         character *(*) xstr
         integer nondig, i
         integer sign, digits, kdv
         
         tbxxsti = 0
         digits = 0
         nondig = 0
         sign = 1
         do i = 1,len(xstr)
           kdv = ichar(xstr(i:i))-ichar('0')
           if (digits.eq.0) then
             if (xstr(i:i).eq.'-') then
               sign = -1
               digits = 1
             else
               if (xstr(i:i).eq.'+') then
                 sign = 1
                 digits = 1
               else
                 if (kdv.ge.0 .and. kdv.le.9) then
                   digits = 1
                   tbxxsti = kdv
                 else
                   if (xstr(i:i).ne.' ') then
                     nondig = i
                     return
                   endif
                 endif
               endif
             endif
           else
             if (kdv.ge.0 .and.kdv.le.9) then
               tbxxsti = tbxxsti*10+kdv
             else
               tbxxsti = sign*tbxxsti
               nondig = i
               return
             endif
           endif
         enddo
         
         return
         
         end
         


C
C
C
C
C
C
C
C >>>>>> Convert string to double, marking non-digit
C
C
         function tbxxstd(xstr,nondig)
         double precision tbxxstd
         integer tbxxsti
         character *(*) xstr
         integer nondig, i
         integer sign, digits, kdv
         integer idp, eval        
         tbxxstd = 0.0       
         digits = 0
         nondig = 0
         sign = 1
         idp = 0
         do i = 1,len(xstr)
           kdv = ichar(xstr(i:i))-ichar('0')
           if (i.lt.len(xstr)
     *       .and. (xstr(i:i).eq.'e'
     *       .or. xstr(i:i).eq.'E'
     *       .or. xstr(i:i).eq.'d'
     *       .or. xstr(i:i).eq.'D'
     *       .or. xstr(i:i).eq.'q'
     *       .or. xstr(i:i).eq.'Q')) then
             eval = tbxxsti(xstr(i+1:len(xstr)),nondig)
             tbxxstd = sign*tbxxstd*10.**eval
             if (nondig.ne.0) nondig=nondig+i+1
             return
           endif
           if (i.lt.len(xstr) .and. digits .ne.0
     *       .and. (xstr(i:i).eq.'+'
     *       .or. xstr(i:i).eq.'-')) then
             eval = tbxxsti(xstr(i:len(xstr)),nondig)
             tbxxstd = sign*tbxxstd*10.**eval
             if (nondig.ne.0) nondig=nondig+i
             return
           endif
           if (xstr(i:i).eq.'.'.and.idp.eq.0) then
             idp = i
             digits = 1
           endif
           if (digits.eq.0) then
             if (xstr(i:i).eq.'-') then
               sign = -1
               digits = 1
             else
               if (xstr(i:i).eq.'+') then
                 sign = 1
                 digits = 1
               else
                 if (kdv.ge.0 .and. kdv.le.9) then
                   digits = 1
                   tbxxstd = kdv
                 else
                   if (xstr(i:i).ne.' ') then
                     nondig = i
                     return
                   endif
                 endif
               endif
             endif
           else
             if (kdv.ge.0 .and.kdv.le.9) then
               if (idp.eq.0) then
                 tbxxstd = tbxxstd*10.+kdv
               else
                 tbxxstd = tbxxstd+kdv*(10.**(idp-i))
               endif
             else
               if (i.ne.idp) then
                 tbxxstd = sign*tbxxstd
                 nondig = i
                 return
               endif
             endif
           endif
         enddo
         tbxxstd = sign*tbxxstd
         return
         
         end


C
C
C
C
C
C
C
C >>>>>> Validate the string in strg_(1:long_) of type type_
C        against the dictionary item at jdict
C
C
         subroutine tbxxckv(jdict)
         integer jdict
C
         include   'ciftbx.sys'

         character*(MAXBUF) temp, target, lcvalue
         integer tbxxfstb
         integer tbxxsti
         double precision tbxxstd
         integer tlen
         logical igood, isword, nolo, nohi
         integer fblank,ftab, symop, xlate, itest
         integer yyyy, mm, dd, hr, mi, se, sf, tz
         integer nondig, prevdig, ldt, ldn
         double  precision tardvalue

         valid_ = .false.
         igood = .false.
         if (long_ .lt. 1) return
              
         fblank = index(strg_(1:long_),' ')
         ftab = index(strg_(1:long_),tab)
         ldt = max(1,lastnb(dictype_))
         ldn = max(1,lastnb(dicnam(jdict)))
         isword = .true.
         if (fblank.ne.0 .or. ftab.ne.0) isword =.false.
     
         if (type_.eq.'null') igood = .true.
         
         if ((type_.eq.'char' .or. type_.eq. 'numb').and. isword) then
           if (dictype_.eq.'uchar3') then
             if (long_.eq.3.or.
     *            (long_.eq.4.and.strg_(1:1).eq.'+')
     *            ) igood = .true. 
             go to 90
           endif
           
           if (dictype_.eq.'uchar1') then
             if (long_.eq.1.or.
     *            (long_.eq.2.and.strg_(1:1).eq.'+')
     *          ) igood = .true.
             go to 90
           endif
            
           if (dictype_(1:4).eq.'symo') then
             symop = tbxxsti(strg_(1:long_),nondig)
             xlate = 0
             if (nondig.ne.0.and.nondig.lt.long_) then
               if (strg_(nondig:nondig).eq.'_') then
                 xlate = tbxxsti(strg_(nondig+1:long_),nondig)
               endif
             endif
               
             if (nondig.eq.0 .and.
     *         symop .ge. 1 .and.
     *         symop .le. 192 .and.
     *         xlate .ge. 0 .and.
     *         xlate .le. 1000) igood =.true.
             go to 90
           endif
           
           if (dictype_(1:5).eq.'yyyy-') then
           
             mm=-1
             dd=-1
             hr=0
             mi =0
             se=0
             sf=0
             tz = 0
           
             yyyy = tbxxsti(strg_(1:long_),nondig)
             if (nondig.ne.0.and.nondig.lt.long_) then
             if (strg_(nondig:nondig).eq.'-') then
               prevdig = nondig
               mm = tbxxsti(strg_(nondig+1:long_),nondig)
               if (nondig.ne.0) nondig=prevdig+nondig
               if (nondig.ne.0.and.nondig.lt.long_) then
               if (strg_(nondig:nondig).eq.'-') then
                 prevdig = nondig
                 dd = tbxxsti(strg_(nondig+1:long_),nondig)
                 if (nondig.ne.0) nondig=prevdig+nondig
                 if (nondig.ne.0.and.nondig.lt.long_) then
                 if (strg_(nondig:nondig).eq.'T'
     *             .or. strg_(nondig:nondig).eq.'t'
     *             .or. strg_(nondig:nondig).eq.':') then
                   prevdig = nondig
                   hr = tbxxsti(strg_(nondig+1:long_),nondig)
                   if (nondig.ne.0) nondig=prevdig+nondig
                   if (nondig.ne.0.and.nondig.lt.long_) then
                   if (strg_(nondig:nondig).eq.':') then
                     prevdig = nondig
                     mi = tbxxsti(strg_(nondig+1:long_),nondig)
                     if (nondig.ne.0) nondig=prevdig+nondig
                     if (nondig.ne.0.and.nondig.lt.long_) then
                     if (strg_(nondig:nondig).eq.':') then
                       prevdig = nondig
                       se = tbxxsti(strg_(nondig+1:long_),nondig)
                       if (nondig.ne.0) nondig=prevdig+nondig
                       if (nondig.ne.0.and.nondig.lt.long_) then
                       if (strg_(nondig:nondig).eq.'.') then
                         prevdig = nondig
                         sf = tbxxsti(strg_(nondig+1:long_),nondig)
                         if (nondig.ne.0) nondig=prevdig+nondig
                       endif
                       endif
                     endif
                     endif
                   endif
                   endif
                 endif
                 endif
               endif
               endif
             endif
             endif
             if (nondig.ne.0) then
             if (strg_(nondig:nondig).eq.'-'
     *         .or. strg_(nondig:nondig).eq.'+') then
               tz = tbxxsti(strg_(nondig+1:long_),nondig)
             endif
             endif
             if (nondig.eq.0
     *         .and. yyyy .ge. 0  .and. yyyy .lt. 10000
     *         .and. mm .gt. 0 .and. mm .lt. 13
     *         .and. dd .gt. 0 .and. dd .lt. 32
     *         .and. hr .ge. 0 .and. hr .lt. 25
     *         .and. mi .ge. 0 .and. mi .lt. 61
     *         .and. se .ge. 0 .and. se .lt. 61
     *         .and. sf .ge. 0 
     *         .and. tz .ge. 0 .and. tz .lt. 25 ) igood =.true.
             go to 90  
           endif
           
           if (dictype_(1:4).eq.'char'
     *       .or. dictype_(1:4).eq.'ucha'
     *       .or. dictype_(1:4).eq.'code'
     *       .or. dictype_(1:4).eq.'ucod'
     *       .or. dictype_(1:4).eq.'line'
     *       .or. dictype_(1:4).eq.'ulin'
     *       .or. dictype_(1:3).eq.'any'
     *       .or. dictype_(1:4).eq.'atco'
     *       .or. dictype_(1:4).eq.'phon'
     *       .or. dictype_(1:4).eq.'emai'
     *       .or. dictype_(1:4).eq.'fax'
     *       .or. dictype_(1:4).eq.'text')  then
             igood = .true.
             go to 90
           endif

           if (dictype_(1:4).eq.'numb'
     *       .or. dictype_(1:3).eq.'int'
     *       .or. dictype_(1:4).eq.'floa') then
             itest = tbxxsti(strg_(1:long_),nondig)
             if (nondig.eq.0) then
               igood = .true.
               go to 90
             endif
             if (strg_(nondig:nondig).eq.'(' 
     *         .and. nondig .lt. long_) then
               itest = tbxxsti(strg_(nondig+1:long_),nondig)
               if (nondig.gt.0) then
                 if (strg_(nondig:nondig).eq.')') then
                   igood = .true.
                   go to 90
                 endif
               endif
             endif
             if (dictype_(1:4).eq.'numb'
     *         .or. dictype_(1:4).eq.'floa') then
               if (type_.eq.'numb') igood = .true.
             endif
             go to 90
           endif    	        	  	
           go to 90
         endif
 
         if (type_.eq.'char') then
           if (dictype_(1:4).eq.'text'
     *       .or. dictype_(1:3).eq.'any'
     *       .or. dictype_(1:4).eq.'line'
     *       .or. dictype_(1:4).eq.'ulin'
     *       .or. dictype_(1:4).eq.'phon'
     *       .or. dictype_(1:4).eq.'atco'
     *       .or. dictype_(1:4).eq.'phon'
     *       .or. dictype_(1:4).eq.'char'
     *       .or. dictype_(1:4).eq.'ucha' ) igood = .true.
           go to 90
         endif
 
         if (type_.eq.'text') then
           if (dictype_(1:4).eq.'text'
     *       .or. dictype_(1:3).eq.'any'
     *       .or. dictype_(1:4).eq.'char'
     *       .or. dictype_(1:4).eq.'ucha' ) igood = .true.
           go to 90
         endif
         
 
 90      continue
     
         if (.not.igood) then
           call warn(' Dictionary type '//dictype_(1:ldt)//
     *     ' for '//dicnam(jdict)(1:ldn)//
     *     ' not matched by '//strg_(1:long_))
           return
         endif
         kptr = deindex(jdict)
         if (kptr.eq.0 .or. type_.eq.'null') then
           valid_ = .true.
           return
         endif
         
         
         
         call tbxxclc(lcvalue,llcvalue,strg_,long_)
     
100      if (kptr.ne.0) then

           tlen = tbxxfstb(temp,ivtsbp(kptr),.false.)
           if (tlen.gt.0) then
             call tbxxclc(target,ltarget,temp,tlen)
             if (ivtvet(kptr) .eq. 0) then
               if (target(1:ltarget).eq.lcvalue(1:llcvalue)) then
                 valid_ = .true.
                 return
               endif
               if(type_.eq.'numb'
     *           .and. (dictype_(1:4).eq.'numb'
     *              .or. dictype_(1:3).eq.'int'
     *              .or. dictype_(1:4).eq.'floa')) then
                 if (tbxxstd(target(1:ltarget),nondig)
     *              .eq.numbtb) then
                    valid_= .true.
                    return
                 endif
               endif
             else
               icptr = index(target(1:ltarget),':')
               ilolo = 1
               ilohi = icptr-1
               ihilo = icptr+1
               ihihi = ltarget
               nolo = .true.
               if (ilohi.ge.ilolo) then
                 nolo = .false.
                 if (target(ilolo:ilohi).eq.'.') 
     *             nolo = .true.
               endif
               nohi = .true.
               if (ihihi.ge.ihilo) then
                 nohi = .false.
                 if (target(ihilo:ihihi).eq.'.') 
     *             nohi = .true.
               endif
              if (dictype_(1:4).eq.'numb'
     *         .or. dictype_(1:3).eq.'int'
     *         .or. dictype_(1:4).eq.'floa') then
              if (nolo.and.(.not.nohi)) then
                 if ((ivtvet(kptr).gt.0
     *             .and. numbtb .lt.
     *               tbxxstd(target(ihilo:ihihi),nondig)) .or.
     *               (ivtvet(kptr).lt.0
     *             .and. numbtb .le.
     *               tbxxstd(target(ihilo:ihihi),nondig))) then
                   valid_= .true.
                   return
                 endif
               endif
               if (nohi.and.(.not.nolo)) then
                 if ((ivtvet(kptr).gt.0
     *             .and. numbtb .gt.
     *               tbxxstd(target(ilolo:ilohi),nondig)) .or.
     *               (ivtvet(kptr).lt.0
     *             .and. numbtb .ge.
     *               tbxxstd(target(ilolo:ilohi),nondig))) then
                   valid_= .true.
                   return
                 endif
               endif
               if ((.not.nohi).and.(.not.nolo)) then
                 if ((ivtvet(kptr).gt.0
     *             .and. numbtb .lt.
     *               tbxxstd(target(ihilo:ihihi),nondig)
     *             .and. numbtb .gt.
     *               tbxxstd(target(ilolo:ilohi),nondig)) .or.
     *               (ivtvet(kptr).lt.0
     *             .and. numbtb .le.
     *               tbxxstd(target(ihilo:ihihi),nondig)
     *             .and. numbtb .ge.
     *               tbxxstd(target(ilolo:ilohi),nondig))) then
                   valid_= .true.
                   return
                 endif     
               endif
               else
               if (nolo.and.(.not.nohi)) then
                 if ((ivtvet(kptr).gt.0
     *             .and. lcvalue(1:llcvalue) .lt.
     *               target(ihilo:ihihi)) .or.
     *               (ivtvet(kptr).lt.0
     *             .and. lcvalue(1:llcvalue) .le.
     *               target(ihilo:ihihi))) then
                   valid_= .true.
                   return
                 endif
               endif
               if (nohi.and.(.not.nolo)) then
                 if ((ivtvet(kptr).gt.0
     *             .and. lcvalue(1:llcvalue) .gt.
     *               target(ilolo:ilohi)) .or.
     *               (ivtvet(kptr).lt.0
     *             .and. lcvalue(1:llcvalue) .ge.
     *               target(ilolo:ilohi))) then
                   valid_= .true.
                   return
                 endif
               endif
               if ((.not.nohi).and.(.not.nolo)) then
                 if ((ivtvet(kptr).gt.0
     *             .and. lcvalue(1:llcvalue) .lt.
     *               target(ihilo:ihihi)
     *             .and. lcvalue(1:llcvalue) .gt.
     *               target(ilolo:ilohi)) .or.
     *               (ivtvet(kptr).lt.0
     *             .and. lcvalue(1:llcvalue) .le.
     *               target(ihilo:ihihi)
     *             .and. lcvalue(1:llcvalue) .ge.
     *               target(ilolo:ilohi))) then
                   valid_= .true.
                   return
                 endif     
               endif
              endif
             endif
           endif
           kptr = ivtnxt(kptr)
           go to 100
         endif
200      continue
         call warn(' Dictionary type '//dictype_(1:ldt)//
     *    ' for '//dicnam(jdict)(1:ldn)//
     *    ' range not matched by '//strg_(1:long_))
         return
         end

C
C
C
C
C
C
C
C >>>>>> Read the next string from the file
C
C
         subroutine getstr
C
C        On entry, jchar is set to one less than the next character
C        to be read, on the line given by irecd, which is assumed
C        to have been loaded into buffer, with lastch set to the
C        position of the last character
C
         include   'ciftbx.sys'
         integer   i,j,jj(11),im
         logical   quoted
         character c*1,num*21,flag*4
         data num/'0123456789+-.()EDQedq'/
C
         quoted=.false.
         quote_=' '
         if(irecd.gt.0.and.
     *     jchar.le.1.and.lastch.gt.0) then
           jchar=1
           goto 140
         end if
100      jchar=jchar+1
         if(jchar.le.lastch)     goto 150
C
C....... Read a new line
C
110      call getlin(flag)
         type_='fini'
         dictype_=type_
         diccat_='(none)'
         dicname_=' '
Cdbg     write(6,'(/5i5,a)') 
Cdbg *              irecd,jrecd,lrecd,nrecd,lastch, buffer(1:lastch)
         if(flag.eq.'fini')  goto 500
C
C....... Test if the new line is the start of a text sequence
C
140      if(buffer(1:1).ne.';') goto 150
         type_='text'
         jchar=lastch+1
         long_=lastch
         strg_(1:long_)=buffer(1:long_)
         strg_(1:1)=' '
         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....... Span blank delimited token; test if a number or a character 
C
200      type_='numb'
         im=0
         do 205 i=1,11
205      jj(i)=0
210      do 250 i=jchar,lastch
         if(buffer(i:i).eq.' ')       goto 400
         if(buffer(i:i).eq.tab)       goto 400
         if(type_.ne.'numb')          goto 250
         j=index(num,buffer(i:i))
         if(j.eq.0)                 type_='char'
         if(j.le.10) then
           im=im+1
           goto 250
         endif
         if(j.gt.13.and.im.eq.0) type_='char'
         jj(j-10)=jj(j-10)+1
250      continue
         i=lastch+1
         if(type_.ne.'numb') goto 400
         do 270 j=1,5
         if((jj(j).gt.1.and.j.gt.2) .or.
     *     jj(j).gt.2)             type_='char'
270      continue
         goto 400
C
C....... Span quote delimited token; assume character
C
300      type_='char'
         quoted=.true.
         jchar=jchar+1
         do 320 i=jchar,lastch
         if(buffer(i:i).ne.c)             goto 320
         if(i+1.ge.lastch)                goto 400
         if(buffer(i+1:i+1).eq.' ')       goto 400
         if(buffer(i+1:i+1).eq.tab)       goto 400
320      continue
Cdbg     write(6,'(a,4i5,a)') 
Cdbg *       '**** ',irecd,lastch,i,jchar,buffer(jchar:i)       
         call warn(' Quoted string not closed')
C
C....... Store the string for the getter
C
400      long_=0
         strg_=' '
         if(i.gt.jchar) then
           long_=i-jchar
           strg_(1:long_)=buffer(jchar:i-1)
         endif
         jchar=i
         quote_=' '
         if(quoted) then
           quote_=buffer(jchar:jchar)
           jchar =jchar+1
         endif
Cdbg     write(6,'(5x,8i5,5x,a)') 
Cdbg *   irecd,jrecd,lrecd,nrecd,lastch,i,jchar,long_,strg_(1:long_)
         if(type_.ne.'char'.or.quoted) goto 500
         if(strg_(1:5).eq.'data_') type_='data'
         if(strg_(1:5).eq.'loop_') type_='loop'
         if(long_.eq.1.and.strg_(1:1).eq.'?') type_='null'
         if(long_.eq.1.and.strg_(1:1).eq.'.') type_='null'
         if(strg_(1:5).eq.'save_') type_='save'
         if(long_.eq.7.and. strg_(1:7).eq.'global_') type_='glob'
C
500      return
         end
C
C
C
C
C
C
C >>>>>> Convert a character string into a number and its esd
C
C                                          Q
C                                          D+
C                                          E-
C                                +         +
C           number string        -xxxx.xxxx-xxx(x)
C           component count CCNT 11111222223333444
C           (with at least 1 digit in the mantissa)
C
         subroutine ctonum
C
         integer   lastnb
         include  'ciftbx.sys'
         character test*22,c*1
         integer*4 m,nchar
         integer*4 ccnt,expn,msin,esin,ndec,ids,nmd
         integer*4 nms,ned,nef,nes
         double precision numb,sdev,ntemp,mant
         data test /'0123456789+.-()EDQedq '/
C
         numbtb=0.D0
         sdevtb=-1.D0
         numb=1.D0
         sdev=0.D0
         ccnt=0
         mant=0.D0
         expn=0.
         msin=+1
         esin=+1
         ndec=0
         ids=0
         nmd=0
         nms=0
         ned=0
         nef=0
         nes=0
         type_='char'
         posdec_=0
         esddig_=0
         if(long_.eq.1.and.
     *     index('0123456789',strg_(1:1)).eq.0) goto 500
         lzero_=.false.
         decp_=.false.
C
C....... Loop over the string and identify components
C
C        The scan works in phases
C          ccnt = 0   processing looking for first digit
C          ccnt = 1   processing before decimal point
C          ccnt = 2   processing after decimal point
C          ccnt = 3   processing exponent
C          ccnt = 4   processing standard deviation
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
         ntemp=m-1
         if (ndec.eq.0) then
           mant=mant*10.D0+ntemp
         else
           mant=mant+ntemp/10.D0**(ndec)
         endif
         nmd=nmd+1
         if(ccnt.eq.1.and.mant.ne.0.D0) ids=ids+1
         goto 400
220      if(ccnt.gt.3)  goto 240
         expn=expn*10+m-1
         goto 400
240      esddig_=esddig_+1
         ntemp=m-1
         sdev=sdev*10.D0+ntemp
         sdevtb=1.D0
         goto 400
C
C....... Process the characters    . + - ( ) E D Q
C
300      if(c.ne.'.')  goto 320
         decp_=.true.
         if(nchar.gt.1.and.mant.eq.0.d0) then
           if(strg_(nchar-1:nchar-1).eq.'0') lzero_=.true.
         endif
         if(ccnt.gt.1) goto 500
         posdec_=nchar
         ccnt=2
         goto 400
C
320      if(nmd.eq.0.and.m.gt.13) goto 500
         if(c.ne.'(')  goto 340
         if(posdec_.eq.0) posdec_=nchar
         ccnt=4
         goto 400
C
340      if(posdec_.eq.0.and.ccnt.gt.0) posdec_=nchar
         if(c.eq.')' .or. c.eq.' ')  goto 400
         if(ccnt.eq.3 .and. ned.gt.0) goto 500
         if(m.gt.13) then
           if (nef.gt.0) goto 500
           nef = nef+1
           ccnt = 3
           esin = 1
         else
           if(ccnt.gt.0) then
             if (nes.gt.0) goto 500
             nes = nes+1
             ccnt = 3
             esin = 12-m
           else
             if (nms.gt.0) goto 500
             nms = nms+1
             ccnt=1
             msin=12-m
           endif
         endif
C
400      continue
C
         if(posdec_.eq.0) posdec_=lastnb(strg_(1:long_))+1
C
C....... String parsed; construct the numbers
C
         expn=expn*esin
         if(expn+ids.gt.-minexp) then
           call warn(' Exponent overflow in numeric input')
           expn=-minexp-ids
         endif
         if(expn.lt.minexp) then
           call warn(' Exponent underflow in numeric input')
           expn=minexp
         endif
         if(expn-ndec.lt.0) numb=1./10.D0**abs(expn-ndec)
         if(expn-ndec.gt.0) numb=10.D0**(expn-ndec)
         if(sdevtb.gt.0.0) sdevtb=numb*sdev
         numb=1.D0
         if(expn.lt.0) numb=1./10.D0**abs(expn)
         if(expn.gt.0) numb=10.D0**(expn)
         ntemp=msin
         numbtb=numb*mant*ntemp
         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   krpp,kpp,lpp,mpp,npp,ir
         integer   tbxxrld
C
         irecd=irecd+1
         jchar=1
         if(irecd.eq.jrecd.and.
     *     irecd.gt.recbeg_.and.
     *     irecd.le.recend_)  goto 200
         if(irecd.le.min(lrecd,recend_))  goto 100
         irecd=min(lrecd,recend_)+1
         buffer(1:1)=' '
         lastch=0
         jchar=MAXBUF+1
         jrecd=-1
         flag='fini'
         goto 200
100      continue
         lpp=-1
         mpp=-1
         npp=kpp
         call tbxxflin(irecd,lip,kpp,mp,kip,ip,mip,mis)
         if (lip.eq.0) then
           buffer(1:1) = ' '
           lastch = 1
           go to 130
         endif
         do ir = 1,NUMPAGE
           if(iabs(mppoint(ir)).eq.kpp) then
             lpp = ir
             goto 120
           endif
           if(mppoint(ir).eq.0) then
             lpp=ir
           else
             if(iabs(iabs(mppoint(ir))-kpp)
     *         .gt.iabs(npp-kpp)) then
               mpp=ir
               npp=iabs(mppoint(ir))
             endif
           endif
         enddo
C
C        failed to find page as resident
C        remove a target page
C
         if(lpp.eq.-1)lpp=mpp
         if(lpp.eq.-1)lpp=1
		 if (mppoint(lpp).lt.0) then
		   write(dirdev,'(a)',rec=-mppoint(lpp)) pagebuf(lpp)
		 endif
         mppoint(lpp)=kpp
         read(dirdev,'(a)',rec=kpp) pagebuf(lpp)
120      lastch = tbxxrld(buffer,pagebuf(lpp)(mp:NUMCPP), .false.)
130      recn_=irecd
         jrecd=irecd
         flag=' '
200      return
         end
C
C
C
C
C
C
C >>>>>> Detab buffer into bufntb
C
         subroutine detab
C
         include   'ciftbx.sys'
         integer   icpos,itpos,ixpos,ixtpos
         if(jrecd.eq.jrect) return
         icpos=1
         itpos=1
         bufntb=' '
         if(lastch.gt.0) then
100      ixpos=index(buffer(icpos:lastch),tab)
         ixtpos=ixpos+itpos-1
         if(ixpos.gt.0.and.ixtpos.le.MAXBUF) then
           ixtpos=((ixtpos+7)/8)*8
           if(ixpos.gt.1) then
           bufntb(itpos:ixtpos)=
     *       buffer(icpos:ixpos+icpos-2)
           else
           bufntb(itpos:ixtpos)=' '
           endif
           itpos=ixtpos+1
           icpos=ixpos+icpos
           goto 100
         else
           bufntb(itpos:max(MAXBUF,itpos+lastch-icpos))=
     *       buffer(icpos:lastch)
         endif
         endif
         jrect=jrecd
         return
         end
C
C
C
C
C
C
C >>>>>> Write error message and exit.
C
         subroutine err(mess)
         character*(*) mess
         call cifmsg('error',mess)
         stop
         end
C
C
C
C
C
C
C >>>>>> Write warning message and continue.
C
         subroutine warn(mess)
         character*(*) mess
         call cifmsg('warning',mess)
         return
         end
C
C
C
C
C
C
C >>>>>> Write a message to the error device
C
         subroutine cifmsg(flag,mess)
C
         integer    lastnb
         include   'ciftbx.sys'
         character*(*) flag
         character*(*) mess
         character*(MAXBUF)  tline
         character*5   btype
         integer       ll,ls,ltry,ii,i
C
         btype = 'data_'
         if(save_) btype = 'save_'
         if(.not.glob_) then
         tline= ' ciftbx '//flag//': '
     *   //file_(1:longf_)//' '//btype
     *   //bloc_(1:max(1,lastnb(bloc_)))//' line:'
         else
         tline= ' ciftbx '//flag//': '
     *   //file_(1:longf_)//' global_'//' line:'
         endif
         ll = max(1,lastnb(tline))
         write(errdev,'(a,i7)')tline(1:ll),irecd
         ll=len(mess)
         ls=1
100      if(ll-ls.le.79) then
           write(errdev,'(1X,a)') mess(ls:ll)
           return
         else
           ltry = min(ll,ls+79)
           do ii = ls+1,ltry
           i = ltry-ii+ls+1
           if(mess(i:i).eq.' ') then
             write(errdev,'(1X,a)') mess(ls:i-1)
             ls=i+1
             if(ls.le.ll) go to 100
             return
           endif
           enddo
           write(errdev,'(1X,a)') mess(ls:ltry)
           ls=ltry+1
           if(ls.le.ll) go to 100
           return
         endif  
         end
C
C
C
C
C >>>>>> Create a named file.
C
         function pfile_(fname)
C
         logical   pfile_
         include   'ciftbx.sys'
         logical   test
         integer   lfname
         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_(1:longf_) = ' '
         lfname = len(fname)
         file_(1:lfname)=fname
         do 120 i=1,lfname
         if(file_(i:i).eq.' ') goto 140
120      continue
         i = lfname+1
140      if (i.gt.1) then
           inquire(file=file_(1:i-1),exist=test)
           pfile_=.false.
           longf_ = i-1
           if(test)            goto 200
         else
           file_ = ' '
           pfile_ = .true.
           longf_ = 1
         endif
C
C....... Open up a new CIF
C
         if (file_(1:1) .ne. ' ')  then 
         open(unit=outdev,file=file_(1:longf_),status='NEW',
     *                    access='SEQUENTIAL',
     *                    form='FORMATTED')
         precn_=0
         endif
         pfile_=.true.  
         pfilef='yes'
         nbloc=0
         pchar=1+lprefx
         pcharl=0
         obuf=prefx
         obuf(pchar:MAXBUF)=' '
200      ploopn = 0
         ploofc = 0
         ploopf = 'no '
         ptextf = 'no '
         plcat = ' '
         pdblok = ' '
         plhead(1) = ' '
         if (xmlout_) then
           call putstr('<?xml version="1.0"?>')
         endif
         return
         end


C
C
C
C
C
C <<<<<< Substitute item in data block XML translation
C
         function dsbst(oblok,xstring)
         include    'ciftbx.sys'
         character   oblok*(*)
         character   xstring*(*)
         character   dsbst*(MAXBUF)
         jj = 1
         dsbst = ' '
         do ii = 1,lastnb(xstring)
           if(xstring(ii:ii).ne.'%') then
             dsbst(jj:jj) = xstring(ii:ii)
             jj = jj+1
           else
             do kk = 1,lastnb(oblok)
               dsbst(jj:jj) = oblok(kk:kk)
               jj = jj+1
             enddo
           endif
         enddo
         return
         end

C
C
C
C
C
C >>>>>> Store a data block command in the CIF
C        Call with blank name to close current block only
C
         function pdata_(name) 
C
         logical   pdata_
         SAVE
         include  'ciftbx.sys'
         character name*(*),temp*(MAXBUF)
         character dbloc(100)*(NUMCHAR)
         character dsbst*(MAXBUF)
         integer   i
C
         pdata_=.true.
         if(ploopn.ne.0)     call eoloop
         if(ptextf.eq.'yes') call eotext
         if(psaveo) then
           pchar=-1
           if(pposval_.ne.0) then
             pchar=lprefx+1
             call putstr(' ')
             pchar=lprefx+pposval_
             pposval_=0
           endif
           if (xmlout_) then
             call putxc('save_',' ')
           else
             call putstr('save_')
           endif
           psaveo=.false.
         endif
         if (pdblok(1:1).ne.' ') then
           if (xmlout_) then
             if (xmdata.eq.0) then
               call putxc(pdblok,' ')
             else
               call putxc(dsbst(pdblok,xmlate(xmdata)),' ')
             endif
           endif
           pdblok=' '
         endif
         if(globo_) then
           pchar=-1
           temp='global_'
           pdblok='global_'
           psaveo=.false.
           goto 135
         endif
C
C....... Check for duplicate data name
C
         temp=name
         if(temp.eq.' ')        goto 200
         if(saveo_)             goto 130
         pdata_=.false.
         do 110 i=1,nbloc
         if(temp.eq.dbloc(i))   goto 130
110      continue
         pdata_ = .true.
         goto 125
C
C....... Save block name and put data_ statement
C
125      nbloc=nbloc+1
         if(nbloc.le.100) dbloc(nbloc)=temp
         pdblok = temp
130      pchar=-1
         temp='data_'//name
         if(saveo_) temp='save_'//name
         if(globo_) temp='global_'
         psaveo=saveo_
135      if(pposnam_.gt.0) then
           pchar=lprefx+1
           call putstr(' ')
           pchar=lprefx+pposnam_
           pposnam_=0
         endif
         if (xmlout_) then
           if (globo_) then
             call putxo('global_',' ')
           else
             if (xmdata.eq.0) then
               call putxo(pdblok,' ')
             else
               call putxo(dsbst(pdblok,xmlate(xmdata)),' ')
             endif
             if (saveo_) then
               call putxo('save_',' ')
             endif
           endif
         else
           call putstr(temp(1:lastnb(temp)))
         endif         
         pchar=lprefx
         plcat = ' '
         ploopn = 0
C
200      return
         end

C
C
C
C
C
C
C >>>>>> Process a name to extract the category and item
C
         subroutine tbxxpcat(name,type,flag,tflag,mycat,myxcat,
     *     item,xitem,nroot)
C
         character  name*(*),mycat*(*),item*(*),nroot*(*),type*4
         character  myxcat*(*),xitem*(*)
         include   'ciftbx.sys'
         character  xxxtemp*(NUMCHAR)
         logical    flag,tflag
         integer    lastnb,kpl,npl
         character  str1*(NUMCHAR), str2*(NUMCHAR)


         item  = name
         xitem = ' '
         nroot = name
         mycat = ' '
         myxcat = ' '
         flag = .true.
         tflag = .true.
         if(vcheck.eq.'yes') then
           kdc = 0
           call dcheck(name,type,flag,tflag)
           if (xdchk.ne.0) then
             kdc = dcindex(xdchk)
             if (xmindex(xdchk).ne.0) xitem = xmlate(xmindex(xdchk))
           endif
           if (aliaso_.and.xdchk.ne.0) then
             if (aroot(xdchk).ne.0) then
               nroot = dictag(aroot(xdchk))
               kdc = dcindex(aroot(xdchk))
             endif
           endif
           if (kdc.ne.0) then
             mycat = dcname(kdc)
             myxcat = ' '
             if (xmcind(kdc).ne.0) myxcat = xmlate(xmcind(kdc))
           endif
         else
           call tbxxcat(name,mycat,lmycat)
         endif
         kpl = lastnb(mycat)
         npl = lastnb(name)
         call tbxxnlc(str1, mycat)
         call tbxxnlc(str2, name)
         if (mycat(1:1).ne.' ' .and. name(1:1).eq.'_') then
           if(str1(1:kpl).eq.str2(2:kpl+1) .and. npl .gt. kpl+2 .and.
     *       (name(kpl+2:kpl+2).eq.'.' .or. 
     *       name(kpl+2:kpl+2).eq.'_') ) then
             item = name(kpl+3:npl)
           else
             item = name(2:npl)
           endif
         else
           if (mycat(1:1).eq.' ' .and. plcat(1:1).ne.' '
     *       .and. name(1:1).eq.'_') then
             call tbxxnlc(str1, plcat)
             kpl = lastnb(plcat)
             if(str1(1:kpl).eq.str2(2:kpl+1) .and. npl .gt. kpl+2 .and.
     *         (name(kpl+2:kpl+2).eq.'.' .or.
     *         name(kpl+2:kpl+2).eq.'_') ) then
               mycat = plcat
               item = name(kpl+3:npl)
             else
               item = name(2:npl)
             endif
           else
             item = name
             if (item(1:1).eq.'_') item = name(2:npl)
           endif
         endif
         if (xmlong_) then
           item = name
           if (item(1:1).eq.'_') item = name(2:npl)
         endif
         call nupcase(xxxtemp,mycat)
         mycat = xxxtemp
         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
         logical    pnumb_
         include   'ciftbx.sys'
         logical    flag,tflag
         character  name*(*),temp*(NUMCHAR)
         character  mycat*(NUMCHAR),item*(NUMCHAR)
         character  myxcat*(XMLCHAR),xitem*(XMLCHAR)
         real       numb,sdev
         double precision dnumb,dsdev,dprec
         integer    kmn
C
         pnumb_=.true.
         flag  =.true.
         tflag =.true.
         temp=name
         if(ptextf.eq.'yes') call eotext
C
         if(name(1:1).eq.' ')   goto 110
         call tbxxpcat(name,'numb',flag,tflag,mycat,myxcat,
     *     item,xitem,temp)
         pnumb_=flag
100      if(ploopn.ne.0)        call eoloop
         if (xmlout_) then
           if (plcat(1:1).ne.' ' .and. plcat.ne.mycat) then
             call putxc(plhead(1),plxhead(1))
             plhead(1) = ' '
             plxhead(1) = ' '
             call putxc(plcat,plxcat)
             plcat = ' '
             plxcat = ' '
           endif
         endif
         pchar=-1
         if(pposnam_.ne.0)pchar=pposnam_+lprefx
         if (xmlout_) then
           if ((plhead(1)(1:1).ne.' '.and.plhead(1).ne.item)
     *       .or. plcat.ne.mycat) then
             call putxc (plhead(1),plxhead(1)) 
             plhead(1) = ' '
             plxhead(1) = ' '
             if (plcat.ne.mycat) then
               call putxc(plcat,plxcat)
               plcat = mycat
               plxcat = myxcat
               call putxo(plcat,plxcat)
             endif
             call putxo (item,xitem)
           else
             if(plhead(1)(1:1).eq.' ') call putxo (item,xitem)
           endif
           plhead(1) = item
           plxhead(1) = xitem
         else
           call putstr(temp(1:lastnb(temp)))
         endif
         go to 120
C
110      if (xmlout_) then
           if (ploopn.gt.0) then
             kmn = mod(ploopc,ploopn)+2
             if (ploopn.gt.1.or.ploopf.eq.'yes') then
               call putxo(plhead(kmn),plxhead(kmn))
             endif
           endif
         endif
C
120      if(ploopf.eq.'yes') ploopc=0
         ploopf='no '
         dprec=decprc
         dnumb=numb
         dsdev=sdev
         call putnum(dnumb,dsdev,dprec)
         if(.not.flag) then
           if(.not.tabl_) pchar=lprefx+57
           if (xmlout_) then
             call putstr('<!-- not in dictionary -->')
           else
             call putstr('#< not in dictionary')
           endif
         endif
         if(.not.tflag) then
           if(.not.tabl_) pchar=lprefx+57
           if (xmlout_) then
             call putstr('<!-- not correct type -->')
           else
             call putstr('#< not correct type')
           endif
         endif
         if (xmlout_) then
           if (ploopn.gt.1 .and.ploopc.gt.0) then
             call putxc(plhead(ploopc+1),plxhead(ploopc+1))
           endif
         endif
C
150      pposnam_=0
         pposval_=0
         pposdec_=0
         pposend_=0
         pesddig_=0
         return
         end
C
C
C
C
C
C
C >>>>>> Put a double precision number into the CIF, perhaps 
C        with an esd appended
C
         function pnumd_(name,numb,sdev)
C
         logical    pnumd_
         include   'ciftbx.sys'
         logical    flag,tflag
         character  name*(*),temp*(NUMCHAR)
         character  mycat*(NUMCHAR),item*(NUMCHAR)
         character  myxcat*(XMLCHAR),xitem*(XMLCHAR)
         double precision numb,sdev
         integer    kmn
C
         pnumd_=.true.
         flag  =.true.
         tflag =.true.
         temp=name
         if(ptextf.eq.'yes') call eotext
C
         if(name(1:1).eq.' ')   goto 110
         call tbxxpcat(name,'numb',flag,tflag,mycat,myxcat,
     *     item,xitem,temp)
         pnumd_=flag
100      if(ploopn.ne.0)        call eoloop
         if (xmlout_) then
           if (plcat(1:1).ne.' ' .and. plcat.ne.mycat) then
             call putxc(plhead(1),plxhead(1))
             plhead(1) = ' '
             call putxc(plcat,plxcat)
             plcat = ' '
             plxcat = ' '
           endif
         endif
         pchar=-1
         if(pposnam_.ne.0)pchar=pposnam_+lprefx
         if (xmlout_) then
           if ((plhead(1)(1:1).ne.' '.and.plhead(1).ne.item)
     *       .or. plcat.ne.mycat) then
             call putxc (plhead(1),plxhead(1)) 
             plhead(1) = ' '
             plxhead(1) = ' '
             if (plcat.ne.mycat) then
               call putxc(plcat,plxcat)
               plcat = mycat
               plxcat = myxcat
               call putxo(plcat,myxcat)
             endif
             call putxo (item,xitem)
           else
             if(plhead(1)(1:1).eq.' ') call putxo (item,xitem)
           endif
           plhead(1) = item
           plxhead(1) = xitem
         else
           call putstr(temp(1:lastnb(temp)))
         endif
         go to 120
C
110      if (xmlout_) then
           if (ploopn.gt.0) then
             kmn = mod(ploopc,ploopn)+2
             if (ploopn.gt.1.or.ploopf.eq.'yes') then
               call putxo(plhead(kmn),plxhead(kmn))
             endif
           endif
         endif
C
120      if(ploopf.eq.'yes') ploopc=0
         ploopf='no '
         call putnum(numb,sdev,dpprc)
         if(.not.flag) then
           if(.not.tabl_) pchar=lprefx+57
           if (xmlout_) then
             call putstr('<!-- not in dictionary -->')
           else
             call putstr('#< not in dictionary')
           endif
         endif
         if(.not.tflag) then
           if(.not.tabl_) pchar=lprefx+57
           if (xmlout_) then
             call putstr('<!-- not correct type -->')
           else
             call putstr('#< not correct type')
           endif
         endif
         if (xmlout_) then
           if (ploopn.gt.1 .and.ploopc.gt.0) then
             call putxc(plhead(ploopc+1),plxhead(ploopc+1))
           endif
         endif
C
150      pposnam_=0
         pposval_=0
         pposdec_=0
         pposend_=0
         pesddig_=0
         return
         end
C
C
C
C
C
C
C >>>>>> Put a character string into the CIF.
C
         function pchar_(name,string)      
C
         logical    pchar_
         include   'ciftbx.sys'
         logical    flag,tflag
         character  name*(*),temp*(NUMCHAR),string*(*)
         character  mycat*(NUMCHAR),item*(NUMCHAR)
         character  myxcat*(XMLCHAR),xitem*(XMLCHAR)
         character  line*(MAXBUF),strg*(MAXBUF)
         integer    i, j, kfold
         integer    lstring,lqstring
C
         pchar_=.true.
         flag  =.true.
         tflag =.true.
         temp  =name
         lstring = lastnb(string)
         if (lstring .gt. MAXBUF) then
           call warn('Output CIF line longer than MAXBUF, truncated')
           lstring = MAXBUF
         endif
         if(ptextf.eq.'yes') call eotext
C
         if(name(1:1).eq.' ')   goto 110
         call tbxxpcat(name,'char',flag,tflag,mycat,myxcat,
     *     item,xitem,temp)
         pchar_=flag
100      if(ploopn.ne.0)        call eoloop
         if (xmlout_) then
           if (plcat(1:1).ne.' ' .and. plcat.ne.mycat) then
             call putxc(plhead(1),plxhead(1))
             plhead(1) = ' '
             plxhead(1) = ' '
             call putxc(plcat,plxcat)
             plcat = ' '
             plxcat = ' '
           endif
         endif
         pchar=-1
         if(pposnam_.gt.0) pchar=posnam_+lprefx
         if (xmlout_) then
           if ((plhead(1)(1:1).ne.' '.and.plhead(1).ne.item)
     *       .or. plcat.ne.mycat) then
             call putxc (plhead(1),plxhead(1)) 
             plhead(1) = ' '
             plxhead(1) = ' '
             if (plcat.ne.mycat) then
               call putxc(plcat,plxcat)
               plcat = mycat
               plxcat = myxcat
               call putxo(plcat,plxcat)
             endif
             call putxo (item,xitem)
           else
             if(plhead(1)(1:1).eq.' ') call putxo (item,xitem)
           endif
           plhead(1) = item
           plxhead(1) = xitem
         else
           call putstr(temp(1:lastnb(temp)))
         endif
         go to 120
C
110      if (xmlout_) then
           if (ploopn.gt.0) then
             kmn = mod(ploopc,ploopn)+2
             if (ploopn.gt.1.or.ploopf.eq.'yes') then
               call putxo(plhead(kmn),plxhead(kmn))
             endif
           endif
         endif
C
120      if(ploopf.eq.'yes') ploopc=0
         ploopf='no '
         if (xmlout_) then
           i = 1
           do ic = 1,lstring
            if ( string(ic:ic).eq.'&'
     *        .or. string(ic:ic).eq.'<'
     *        .or. string(ic:ic).eq.'>' ) then
              if(i.lt.MAXBUF) then
                line(i:i) = '&'
              endif
              if (i.lt.MAXBUF) then
                if( string(ic:ic).eq.'&' ) then
                  line(i:MAXBUF)='amp;'
                  i = i+4
                endif
                if( string(ic:ic).eq.'<' ) then
                  line(i:MAXBUF)='lt;'
                  i = i+3
                endif
                if( string(ic:ic).eq.'>' ) then
                  line(i:MAXBUF)='gt;'
                  i = i+3
                endif
              endif
              if (i.gt.MAXBUF+1) then
                i = MAXBUF+1
              endif
            else
              if(i.lt.MAXBUF) then
                line(i:i) = string(ic:ic)
                i = i+1
              endif
            endif
           enddo
           if (i.gt.1) i = i-1
           if (i.lt.MAXBUF) line(i+1:MAXBUF) = ' '
         else
           line=string
           i = lstring
         endif
130      if(pposval_.ne.0.and.pposend_.ge.pposval_)
     *      i=max(i,pposend_-pposval_+1)
         if(pfold_ .ne. 0 .and. lstring .gt. min(pfold_,line_) )
     *      go to 290
         if(pquote_.ne.' ')   go to 150
         do 140 j=i,1,-1
         if(line(j:j).eq.' ') go to 150
140      continue
         if((line(1:1).eq.'_' 
     *     .or. line(i:i).eq.'_'
     *     .or. line(1:1).eq.''''
     *     .or. line(1:1).eq.'"'
     *     .or. line(1:1).eq.';')
     *     .and.line(1:i).ne.'''.'''
     *     .and.line(1:i).ne.'''?'''
     *     .and.line(1:i).ne.'"."'
     *     .and.line(1:i).ne.'"?"') go to 150
         strg=line(1:i)
         goto 200
150      if(pquote_.eq.';')       go to 190
         if(line(1:i).eq.' '.and.nblanko_) then
           strg = '.'
           i = 1
           if(pposval_.ne.0) then
             pchar=pposval_+lprefx
           endif
           call putstr(strg(1:i))   
           go to 210
         endif
         if(pquote_.eq.'"')       go to 170
         do 160 j=1,i-1
         if(line(j:j).eq.''''.and.
     *     (line(j+1:j+1).eq.' '.or.line(j+1:j+1).eq.tab))
     *     goto 170
160      continue
165      strg=''''//line(1:i)//''''
         i=i+2
         pquote_=''''
         goto 200
170      do 180 j=1,i-1
         if(line(j:j).eq.'"'.and.
     *     (line(j+1:j+1).eq.' '.or.line(j+1:j+1).eq.tab))
     *     goto 190
180      continue
185      strg='"'//line(1:i)//'"'
         i=i+2
         pquote_='"'
         if(pfold_ .gt. 1 .and. i .gt. min(pfold_,line_) ) go to 290
         goto 200
190      pchar=-1
         if (xmlout_) then
           strg = '<![CDATA['//line(1:i)
           i = i+9
         else
           strg ='; '//line(1:i)
           i = i+2
         endif
         ptextf='yes'
         call putstr(strg(1:i))
         pchar=-1
         ptextf='no '
         if (xmlout_) then
           call putstr(']]>')
         else
           call putstr(';')
         endif
         pchar=lprefx
         call putstr(' ')
         strg =
     *    ' Converted pchar_ output to text for: '//string(1:lstring)
         call warn(strg)
         goto 210
C
200      if(pposval_.ne.0) then
           pchar=pposval_+lprefx
           if(pquote_.ne.' ') pchar=pchar-1
         endif
         call putstr(strg(1:i))   
210      if(.not.flag) then
           if(.not.tabl_) pchar=lprefx+57
           if (xmlout_) then
             call putstr('<!-- not in dictionary -->')
           else
             call putstr('#< not in dictionary')
           endif
         endif
         if((.not.tflag).and.line(1:i).ne.'.'.and.
     *     line(1:i).ne.'?'.and.pquote_.eq.' ') then
           if(.not.tabl_) pchar=lprefx+57
           if (xmlout_) then
             call putstr('<!-- not correct type -->')
           else
             call putstr('#< not correct type')
           endif
         endif
         if (xmlout_) then
           if (ploopn.gt.1 .and. ploopc.gt.0) then
             call putxc(plhead(ploopc+1),plxhead(ploopc+1))
           endif
         endif


250      pposval_=0
         pposdec_=0
         pposnam_=0
         pposend_=0
         pquote_=' '
         return
         
C
C        fold a string to min(pfold_,line_)
C
290      pchar=-1
         pquote_ = ';'
         if (xmlout_) then
           call putstr('<![CDATA[\\')
         else
           call putstr(';\\')
         endif
         kfold = min(pfold_,line_)
         call tbxxpfs(string(1:lstring),' ',kfold)
         pchar=-1
         ptextf='no '
         if (xmlout_) then
           call putstr(']]>')
         else
           call putstr(';')
         endif
         pchar=lprefx
         call putstr(' ')
         goto 210

         end
C
C
C
C
C
C >>>>>> Put a comment in the output CIF 
C
         function pcmnt_(string)     
C
         logical    pcmnt_
         include   'ciftbx.sys'
         character  string*(*), temp*(MAXBUF)
         character*1 slash
         integer lstring, kfold
C
         slash = '\\'
         lstring = lastnb(string)
         kfold = min(pfold_,line_)
         if(ptextf.eq.'yes') call eotext
         if(pposnam_.ne.0) pchar=pposnam_+lprefx
         if(string.eq.' '.or.
     *     (string.eq.char(0)) .or.
     *     (string.eq.tab.and.(.not.ptabx_))) then
           if(string.eq.' ') pchar=-1
           if (pquote_.eq.'#') then
             temp(1:1+lstring) = pquote_//string(1:lstring)
             call putstr(temp(1:1+lstring))
           else
             call putstr(string)
           endif
           if(string.eq.' ') call putstr(char(0))
         else
           if ((kfold .ne. 0) .and.
     *        ((xmlout_ .and. (max(pchar,1)+8+lstring.gt.kfold))
     *        .or.((.not.xmlout_) .and. 
     *        ((max(pchar,1)+lstring).gt.kfold)))) then
           if (xmlout_) then
             call putstr('<!-- '//slash)
             call tbxxpfs(string(1:lstring),' ',kfold)
           else
             call putstr('#'//slash)
             call tbxxpfs(string(1:lstring),"#",kfold)
           endif
           call putstr(char(0))
           else
           if (xmlout_) then
             temp(1:5) = '<!-- '
             ik = 6
             do ic = 1,lastnb(string)
               if (string(ic:ic).eq.'-'.and.
     *           temp(ik-1:ik-1).eq.'-'.and.
     *           ik.lt.MAXBUF-4) then
                 temp(ik:ik) = '\\'
                 ik = ik+1
               endif
               if (ik.lt.MAXBUF-4) then
                 temp(ik:ik) = string(ic:ic)
                 ik = ik+1
               endif
             enddo
             temp(ik:ik+3) = ' -->'
             ik = ik+4
             if (ik.lt.MAXBUF) temp(ik:MAXBUF) = ' '
           else
             temp='#'//string
           endif
           call putstr(temp(1:lastnb(temp)))
           call putstr(char(0))
           endif
         endif
         pcmnt_=.true.
         pposnam_=0
         if(string.ne.tab)pchar=lprefx+1
         return
         end
C
C
C
C
C
C
C
C >>>>>> Put a text sequence into the CIF.
C
         function ptext_(name,string)      
C
         logical    ptext_
         integer    lastnb
         include   'ciftbx.sys'
         logical    flag,tflag
         integer    ll,nsl
         character  name*(*),temp*(NUMCHAR),string*(*),store*(NUMCHAR)
         character  mycat*(NUMCHAR),item*(NUMCHAR)
         character  myxcat*(XMLCHAR),xitem*(XMLCHAR)
         character  temp2*(MAXBUF)
         character  slash*1
         integer    kmn
         integer    kfold
         data       store/'                                '/
C
         ptext_=.true.
         flag  =.true.
         tflag =.true.
         slash = '\\'
         ll=lastnb(string)
         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 120
C
110      if(ploopn.ne.0)        call eoloop
         call tbxxpcat(name,'char',flag,tflag,mycat,myxcat,
     *     item,xitem,temp)
         ptext_=flag
         if (xmlout_) then
           if (plcat(1:1).ne.' ' .and. plcat.ne.mycat) then
             call putxc(plhead(1),plxhead(1))
             plhead(1) = ' '
             plxhead(1) = ' '
             call putxc(plcat,plxcat)
             plcat = ' '
             plxcat = ' '
           endif
         endif
         pchar=-1
         if(pposnam_.ne.0) pchar=pposnam_+lprefx
         if (xmlout_) then
           if ((plhead(1)(1:1).ne.' '.and.plhead(1).ne.item)
     *       .or. plcat.ne.mycat) then
             call putxc (plhead(1),plxhead(1)) 
             plhead(1) = ' '
             if (plcat.ne.mycat) then
               call putxc(plcat,plxcat)
               plcat = mycat
               plxcat = myxcat
               call putxo(plcat,plxcat)
             endif
             call putxo (item,xitem)
           else
             if(plhead(1)(1:1).eq.' ') call putxo (item,xitem)
           endif
           plhead(1) = item
           plxhead(1) = xitem
         else
           call putstr(temp)
         endif
         if(.not.flag) then
           if(.not.tabl_) pchar=lprefx+57
           if (xmlout_) then
             call putstr('<!-- not in dictionary -->')
           else
             call putstr('#< not in dictionary')
           endif
         endif
         if(.not.tflag) then
           if(.not.tabl_) pchar=lprefx+57
           if (xmlout_) then
             call putstr('<!-- not correct type -->')
           else
             call putstr('#< not correct type')
           endif
         endif
         go to 130
C
120      if (xmlout_) then
           if (ploopn.gt.0) then
             kmn = mod(ploopc,ploopn)+2
             if (ploopn.gt.1.or.ploopf.eq.'yes') then
               call putxo(plhead(kmn),plxhead(kmn))
             endif
           endif
         endif
C
130      if(ploopf.eq.'yes') ploopc=0
         ploopf='no '
         ptextf='yes'
         store=temp
         if(string(1:1).eq.' '.and.ll.gt.1.and.pfold_.eq.0) then
           pchar=-1
           if (xmlout_) then
             temp2 = '<![CDATA['//string(2:ll)
           else
             temp2=';'//string(2:ll)
           endif
           call putstr(temp2(1:lastnb(temp2)))
           pchar=-1
           return
         endif
         pchar=-1
         if (xmlout_) then
           if (pfold_ .gt. 0) then
             call putstr('<![CDATA['//slash)
           else
             call putstr('<![CDATA[')
           endif
         else
           if (pfold_ .gt. 0) then
              temp2 = ';\\'
              call putstr(temp2(1:2))
           else
              call putstr(';')
           endif
         endif
         pchar=-1
         if(string.eq.' ' .and. pfold_ .eq. 0) return
150      pchar=-1
         kfold = 0
         if (pfold_ .gt. 0 ) kfold = pfold_
         if (line_ .gt. 0 .and. pfold_ .gt. line_) then
            kfold = line_
         endif
         if (kfold .gt. 0) then
           call tbxxpfs(string,' ',kfold)
         else 
           call putstr(string(1:max(1,ll)))
         endif
180      continue
         pchar=-1
         pposnam_=0
         pposval_=0
         pposdec_=0
         pposend_=0
         return
         end
C
C
C
C
C
C
C >>>>>> Put a folded string to the output CIF
C
         subroutine tbxxpfs(string,prefix,kfold)
C
         include   'ciftbx.sys'
         character *(*) string,prefix
         character *(MAXBUF) temp
         character *1 slash
         logical stabl
         integer kfold
         integer sploopn
         integer i, klow, khi, kpref, klen

         slash = '\\'
         sploopn = ploopn
         ploopn = -1
         stabl = tabl_
         tabl_ = .false.
         if (kfold .lt. 4) then
           call
     *     warn('Invalid attempt to fold output line, limit reset to 4')
           pfold_ = 4
           kfold = 4
         endif
         klen = lastnb(string)
         kpref = len(prefix)
         if (prefix.eq.' ') kpref=0
         klow = 1
 100     khi = klen
         if (khi.gt.klow+kfold-1-kpref) then
           khi = klow+kfold-1-kpref-1
           do i = khi,klow+1,-1
             if(string(i:i).eq.' ') then
               khi = i
               go to 120
             endif
           enddo
 120       if (kpref.gt.0) then
             temp(1:kpref+khi-klow+2) = prefix//string(klow:khi)//slash
           else
             temp(1:kpref+khi-klow+2) = string(klow:khi)//slash
           endif
           pchar = -1
           call putstr(temp(1:kpref+khi-klow+2))
           call putstr(char(0))
           klow = khi+1
           go to 100
         else
           if (string(khi:khi).eq.slash) then
             if (khi.lt.klow+kfold-1-kpref) then
                if (kpref.gt.0) then
                  temp(1:kpref+khi-klow+2) =
     *              prefix//string(klow:khi)//slash
                  pchar = -1
                  call putstr(temp(1:kpref+khi-klow+2))
                  call putstr(char(0))
                  pchar = -1
                  call putstr(prefix)
                else
                  temp(1:khi-klow+2) = string(klow:khi)//slash
                  pchar = -1
                  call putstr(temp(1:khi-klow+2))
                  pchar = -1
                  call putstr(' ')
                endif
                call putstr(char(0))
             else
                if (kpref.gt.0) then
                  temp(1:kpref+khi-klow+1) = prefix//string(klow:khi)
                  pchar = -1
                  call putstr(temp(1:kpref+khi-klow+1))
                  call putstr(char(0))
                  temp(1:kpref+2) = prefix//slash//slash
                  pchar = -1
                  call putstr(temp(1:kpref+2))
                  call putstr(char(0))
                  call putstr(prefix)
                else
                  pchar = -1
                  call putstr(string(klow:khi))
                  call putstr(char(0))
                  pchar = -1
                  call putstr(slash//slash)
                  call putstr(char(0))
                  call putstr(' ')
                endif
                call putstr(char(0))
                pchar = -1
             endif
           else
             pchar = -1
             if (kpref.gt.0) then
               temp(1:kpref+khi-klow+1)=prefix//string(klow:khi)
               call putstr(temp(1:kpref+khi-klow+1))
             else
               call putstr(string(klow:khi))
             endif
             call putstr(char(0))
           endif
         endif
         pchar = -1
         ploopn = sploopn
         tabl_ = stabl
         return
         end
C
C
C
C
C
C
C >>>>>> Put a loop_ data name into the CIF.
C
         function ploop_(name)      
C
         logical    ploop_
         integer    kdc,kpc,kpl,npl
         include   'ciftbx.sys'
         logical    flag,tflag
         character  name*(*), temp*(NUMCHAR), mycat*(NUMCHAR)
         character  myxcat*(XMLCHAR),xitem*(XMLCHAR)
         character  item*(NUMCHAR), str*(NUMCHAR)
         character  shead*(NUMCHAR),xshead*(XMLCHAR)
C
         ploop_=.true.
         flag  =.true.
         if(ptextf.eq.'yes')    call eotext
         if(ploopn.ne.0. and. ploopf.ne.'yes'
     *     .and. name(1:1).eq.' ') then
           call eoloop
         endif
         temp = ' '
         mycat = ' '
         item = ' '
         shead = plhead(1)
         xshead = plxhead(1)
         str = ' '
         if(name(1:1).eq.' ')   goto 100
C
         call tbxxpcat(name,'    ',flag,tflag,mycat,myxcat,
     *     item,xitem,str)
         ploop_ = flag
         if (ploopn.ne.0. and. ploopf.ne.'yes') then
           if (plcat.eq.mycat) then
             plcat = ' '
             call eoloop
             plcat = mycat
             plxcat = myxcat
           else
             call eoloop
           endif
         endif
         if (xmlout_) then
           if (plcat(1:1).ne.' '.and.ploopn.eq.0) then
             call putxc(plhead(1),plxhead(1))
             plhead(1) = ' '
             plxhead(1) = ' '
             shead = ' '
             xshead = ' '
             if (plcat.ne.mycat) then
               call putxc(plcat,plxcat)
               plcat = ' '
               plxcat = ' '
             endif
           endif
         endif
         if(tabl_.and.pposnam_.eq.0) then
           temp='    '//str
         else
           temp=str
         endif
         plhead(max(ploopn,0)+2) = item
         plxhead(max(ploopn,0)+2) = xitem
100      if(ploopn.ne.0)        goto 120
         ploopf='yes'
         pchar=-1
         if(pposval_.ne.0) then
           pchar=lprefx+1
           call putstr(' ')
           pchar=pposval_+lprefx
         else
           if(pposnam_.ne.0) then
             pchar=lprefx+1
             call putstr(' ')
             pchar=pposnam_+lprefx+1
           endif
         endif
         if (xmlout_) then
           if (shead(1:1).ne.' ') then
             call putxc (shead,xshead) 
           endif
         else
           call putstr('loop_')
         endif
         pchar=-1
         if(name(1:1).eq.' ') then
           ploopn=-1
           plhead(1) = ' '
           plxhead(1) = ' '
           return
         endif
120      if(ploopn.le.0) then
           if (xmlout_.and.plcat.ne.mycat) then
             call putxc(plcat,plxcat)
             plcat = mycat
             plxcat = myxcat
             call putxo(mycat,myxcat)
           endif
         else
           if(xmlout_ .and. plcat.ne.mycat) then
             kpl = lastnb(plcat)
             if(mycat(1:1).eq.' ') then
                mycat = '(none)'
                myxcat = '_NONE_ '
             endif
             npl = lastnb(mycat)
             kpc = pchar
             call putstr('<!--  mixed categories '//plcat(1:kpl)
     *                      //' and '//mycat(1:npl)//' -->')
             pchar = kpc
           endif
         endif
         if(pposnam_.ne.0) pchar=pposnam_+lprefx
         if (.not. xmlout_) then
           call putstr(temp(1:lastnb(temp)))
         endif
         if(flag)               goto 130
         if(.not.tabl_) pchar=lprefx+57
         if (xmlout_) then
           call putstr('<!-- '//temp(1:lastnb(temp))//
     *     ' not in dictionary -->')
         else
           call putstr('#< not in dictionary')
         endif
130      pchar=lprefx+1
         ploopn=max(ploopn,0)+1
         ploopc = 0
C
150      return
         end
C
C
C
C
C
C >>>>>> Create or clear a prefix string
C        Any change in the length of the prefix string flushes
C        pending text, if any,  loops and partial output lines
C
         function prefx_(strg,lstrg)
C
         logical    prefx_
         include   'ciftbx.sys'
         character  strg*(*)
         integer    lstrg,mxline
C
         mxline=MAXBUF
         if(line_.gt.0) mxline=min(line_,MAXBUF)
         if(lstrg.ne.lprefx.and.pcharl.gt.0) then
           pchar=-1
           call putstr(' ')
         endif
         if (lstrg.le.0) then
           prefx=' '
           if(pchar.ge.lprefx+1)pchar=pchar-lprefx
           lprefx=0
         else
           if(lstrg.gt.mxline) then
             call warn(' Prefix string truncated')
           endif
           prefx=strg
           if(pchar.ge.lprefx+1)pchar=pchar-lprefx+lstrg
           obuf(1:min(mxline,lstrg))=prefx
           lprefx=lstrg
           if(mxline-lprefx.lt.NUMCHAR) then
             call warn(' Output prefix may force line overflow')
           endif
         endif
         prefx_=.true.
         return
         end
C
C
C
C
C
C
C >>>>>> Close the CIF
C
         subroutine close_
C
         include   'ciftbx.sys'
         character  dsbst*(MAXBUF)
C
         if(ptextf.eq.'yes') call eotext
         if(ploopn.ne.0)     call eoloop
         if (xmlout_) then
           if (plhead(1)(1:1).ne.' ') 
     *       call putxc(plhead(1),plxhead(1))
           if (plcat(1:1).ne.' ') call putxc(plcat,plxcat)
           if (pdblok(1:1).ne.' ')  then
             if (xmdata.eq.0) then
               call putxc(pdblok,' ')
             else
               call putxc(dsbst(pdblok,xmlate(xmdata)),' ')
             endif
           endif
         endif
         pdblok = ' '
         plcat = ' '
         plxcat = ' '
         plhead(1) = ' '  
         plxhead(1) = ' ' 
         if(pcharl.ge.lprefx+1) then
           pchar=-1
           call putstr(' ')
         endif
         if (file_(1:1) .ne. ' ') then
           file_(1:longf_) = ' '
           longf_ = 1
           close(outdev)
           precn_=0
         endif
         return
         end
C
C
C >>>>>  Clean out characters not valid for an XML name
C
C        An XML name may begin with a letter, '_' or ':'
C        and may contain letters, digits, '_', ':', '.' or '-'
C
C        Note that the full Unicode character set would also permit
C        combining characters and extender characters, but these
C        have no representation in a 128 character ASCII set
C
C
         function xmncln(xstring,lstr)
         logical xmncln
         character*(*) xstring
         integer lstr, ii, ix
         character*10 chkstr1
         character*28 chkstr2
         character*28 chkstr3
         character*1 c
         data chkstr1/'0123456789'/
         data chkstr2/'_:ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
         data chkstr3/'abcdefghijklmnopqrstuvwxyz.-'/
         xmncln = .true.
         do ii = 1,lstr
           c = xstring(ii:ii)
           if (c.eq.' ') return
           ix = index(chkstr2,c)
           if (ix.eq.0) then
             ix = index(chkstr3,c)
             if (ix.eq.0.and.ii.gt.1) then
               ix = index(chkstr1,c)
             endif
             if(ix.eq.0.or.(ix.gt.26.and.ii.eq.1)) then
               xstring(ii:ii) = '_'
               xmncln = .false.
             endif
           endif
         enddo
         return
         end




C
C
C >>>>>> Put out the given string as an xml open tag
C
C        Note that the string may have embedded blanks and
C        parameters.  The second argument is an optional
C        translation to be used if non-blank.
C
         subroutine putxo(string,xstring)
C
         integer lastnb
         include 'ciftbx.sys'
         character sbuf*(MAXBUF)
         character*(*) string, xstring
         integer ik
         logical xmncln

         if (string(1:1).eq.' ') return
         sbuf(1:1) = '<'
         if (xstring(1:1).eq.' ') then
           ik = lastnb(string)
           sbuf(2:ik+1)=string(1:ik)
         else
           ik = lastnb(xstring)
           sbuf(2:ik+1)=xstring(1:ik)
         endif
         sbuf(ik+2:ik+2) = '>'
         pchar = -1
         if (.not.xmncln(sbuf(2:ik+1),ik)) then
           call warn(' XML required remapping for '//sbuf(2:ik+1))
         endif
         call putstr(sbuf(1:ik+2))
         return
         end 


C
C
C >>>>>> Put out the given string as an xml close tag
C
C        Note that the string may have embedded blanks and
C        parameters.  Only the first token will be used for close.
C        The second argument is an optional translation to be
C        used if non-blank
C
         subroutine putxc(string, xstring)
C
         integer lastnb
         include 'ciftbx.sys'
         character sbuf*(MAXBUF)
         character*(*) string, xstring
         integer ik
         logical xmncln

         if (string(1:1).eq.' ') return
         sbuf(1:2) = '</'
         if (xstring(1:1).eq.' ') then
           do ik = 1,len(string)
             if (string(ik:ik).eq.' ') go to 100
           enddo
           ik = len(string)+1
 100       ik = ik-1
           sbuf(3:ik+2)=string(1:ik)
         else
           do ik = 1,len(xstring)
             if (xstring(ik:ik).eq.' ') go to 200
           enddo
           ik = len(xstring)+1
 200       ik = ik-1
           sbuf(3:ik+2)=xstring(1:ik)
         endif
         sbuf(ik+3:ik+3) = '>'
         if (.not.xmncln(sbuf(3:ik+2),ik)) then
           call warn(' XML required remapping for '//sbuf(3:ik+2))
         endif
         pchar = -1
         call putstr(sbuf(1:ik+3))
         return
         end 

C
C
C
C
C
C >>>>>> Put the string into the output CIF buffer 
C
         subroutine putstr(string)     
C
         integer    lastnb
         include   'ciftbx.sys'
         SAVE
         character  string*(*),temp*(MAXBUF),bfill*(MAXBUF)
         character  temp2*(MAXBUF)
         integer    i,ii,mxline,ioffst,ifree,icpos,itpos
         integer    ixpos,ixtpos,it,im,kbin,kpass
         integer    lstring
         logical    pflush,waslop
         data       waslop /.false./

C
         bfill = ' '
         lstring = min(MAXBUF,lastnb(string))
         mxline=MAXBUF
         if(line_.gt.0) mxline=min(line_,MAXBUF)
         if(pfold_.gt.0) then
           if (pfold_ .lt. lprefx+lstring) then
             call warn('Invalid value of pfold_, reset')
             pfold = min(line_,lprefx+lstring)
           endif
           mxline=min(mxline,pfold_)
         endif
         temp(1:lstring)=string
         temp2=temp
         pflush=.false.
         if(pchar.lt.0) pflush=.true.
C
         do 100 i=lstring,1,-1
         if(temp(i:i).eq.' ')              goto 100
         if(ptabx_.and.temp(i:i).eq.tab) goto 100
         goto 110
100      continue
         i=0
         it=i
C
C....... Organise the output of loop_ items
C
110      if(i.eq.0)             goto 130
         if(i.eq.1.and.string.eq.tab) goto 130
         if(i.eq.1.and.string.eq.char(0)) then
           pcharl=MAXBUF
           goto 200
         endif           
         if((.not.xmlout_).and.temp(1:1).eq.'#')   goto 130
         if(xmlout_.and.temp(1:1).eq.'<') go to 130
         if(ploopf.eq.'yes')    goto 130
         if(ptextf.eq.'yes')    goto 130
         if(ploopn.le.0)        goto 130
         ploopc=ploopc+1
         if(align_.or.tabl_) then
           if(ploopc.gt.ploopn) then
             if(pcharl.gt.lprefx) pflush=.true.
             ploopc=1
             if(pchar.gt.0) pchar=lprefx+1
           endif
           if(pchar.lt.0)    goto 130
           if(tabl_) then
           kbin=(mxline-lprefx)/8
           if(ploopn.lt.kbin) then
             if(kbin/(ploopn+1).gt.1) then
             pchar=9+lprefx+
     *         (ploopc-1)*8*(kbin/(ploopn+1))
             else
             pchar=1+lprefx+
     *         (ploopc-1)*8*(kbin/ploopn)
             endif
           else
             if(ploopc.le.kbin) then
               pchar=1+lprefx+(ploopc-1)*8
             else
               kpass=(ploopc-kbin-1)/(kbin-1)+1
               pchar=2*kpass+1+lprefx+
     *           mod(ploopc-kbin-1,kbin-1)*8
             endif
           endif
           else
             if(ptabx_) then
             icpos=1
             itpos=1
120          ixpos = 0
             if (icpos.le.i) ixpos=index(temp(icpos:i),tab)
             ixtpos=(pchar+itpos-1+ixpos)
             ixtpos=((ixtpos+7)/8)*8
             if(ixpos.gt.0) then
               if(ixpos.gt.1) then
                 temp2(itpos:ixtpos-pchar+1)=temp(icpos:ixpos-1)
               else
                 temp2(itpos:ixtpos-pchar+1)=' '
               endif
               icpos=ixpos+1
               itpos=ixtpos+2-pchar
               if(icpos.le.i) goto 120
               it=itpos-1
             else
               if(icpos.le.i) then
                 temp2(itpos:itpos+i-icpos)=temp(icpos:i)
                 it=itpos+i-icpos
               endif
             endif
             endif
             if((pchar+i).gt.mxline+1.or.
     *          (ptabx_.and.pchar+it.gt.mxline+1)) then
               if(pcharl.gt.lprefx)pflush=.true.
               pchar=lprefx+1
             endif
           endif
         else
           if(ploopc.le.ploopn)   goto 130
           ploopc=1
         endif
C
C....... Is the buffer full and needs flushing?
C
130      if(i.eq.1.and.string.eq.tab) then
           if(pcharl.gt.lprefx) then
             if(obuf(pcharl:pcharl).eq.' ') pcharl=pcharl-1
           endif
         endif
         if(pchar.le.pcharl.and.pcharl.gt.lprefx) pflush=.true.
         pchar=max(lprefx+1,pchar)
         if((ploopf.eq.'yes'.or.ploopn.le.0).and.tabl_)
     *     pchar=((pchar-lprefx+6)/8)*8+1+lprefx
         if(ptabx_) then
         icpos=1
         itpos=1
135      ixpos=0
         if(icpos.le.i) ixpos=index(temp(icpos:i),tab)
         ixtpos=(pchar+itpos-1+ixpos)
         ixtpos=((ixtpos+7)/8)*8
         if(ixpos.gt.0) then
           if(ixpos.gt.1) then
             temp2(itpos:ixtpos-pchar+1)=temp(icpos:ixpos-1)
           else
             temp2(itpos:ixtpos-pchar+1)=' '
           endif
           icpos=ixpos+1
           itpos=ixtpos+2-pchar
           if(icpos.le.i) goto 135
           it=itpos-1
         else
           if(icpos.le.i) then
             temp2(itpos:itpos+i-icpos)=temp(icpos:i)
             it=itpos+i-icpos
           endif
         endif
         endif
         if((pchar+i).gt.mxline+1.or.
     *     (ptabx_.and.pchar+it.gt.mxline+1)) then
            pflush=.true.
            pchar=mxline+1-i
            if (xmlout_) pchar = 1
            pchar=max(lprefx+1,pchar)
         endif
         if(.not.pflush)  goto 150
140      if(pcharl.gt.lprefx) then
           if(waslop.or.(.not.tabl_)) goto 145
           ioffst=0
           pcharl=max(lastnb(obuf(1:pcharl)),lprefx+1)
           ifree=mxline-pcharl
           if(ifree.gt.0) then
           im=numtab+2
           if(numtab.gt.0.and.numtab.le.MAXTAB) then
             if(obuf(itabp(numtab):itabp(numtab)).eq.'#')
     *         im=im-1
           endif
           if(ifree.ge.16.and.im.lt.4.and.
     *       (obuf(1+lprefx:1+lprefx).ne.'#'
     *        .and.((.not.xmlout_).or.(
     *             obuf(1+lprefx:1+lprefx).ne.'<'
     *        .and.obuf(1+lprefx:1+lprefx).ne.']'))
     *        .and.obuf(1+lprefx:1+lprefx).ne.';'
     *        .and.obuf(1+lprefx:1+lprefx).ne.'_'
     *        .and.obuf(1+lprefx:1+lprefx).ne.' '
     *        .and.obuf(1+lprefx:5+lprefx).ne.'data_'
     *        .and.obuf(1+lprefx:5+lprefx).ne.'save_'
     *        .and.obuf(1+lprefx:5).ne.'loop_')) then
             temp(1+lprefx:pcharl)=obuf(1+lprefx:pcharl)
             obuf(1+lprefx:pcharl+8)=
     *         bfill(1:8)//temp(1+lprefx:pcharl)
             ioffst = 8
             ifree=ifree-8
             pcharl=pcharl+8
           endif
           do ii=1,min(MAXTAB,numtab)
             icpos=itabp(ii)+ioffst
             if(icpos.gt.pcharl)   goto 145
             if(im.lt.4) then
             itpos=(max(icpos-lprefx,
     *         ii*(mxline-lprefx)/im)+6)/8
             itpos=itpos*8+1+lprefx
             else
             itpos=(max(icpos-lprefx,
     *         ii*(mxline-lprefx)/im)+4)/6
             itpos=itpos*6+1+lprefx
             endif
             if((obuf(icpos:icpos).eq.''''.or.
     *          obuf(icpos:icpos).eq.'"').and.
     *          itpos.gt.icpos) itpos=itpos-1
             if(itpos-icpos.gt.ifree) itpos=icpos+ifree
             if(itpos.gt.icpos) then
               temp(1:pcharl-icpos+1)=
     *           obuf(icpos:pcharl)
               if(i.lt.numtab) then
                 ixpos=itabp(ii+1)+ioffst
                 if(ixpos.gt.icpos+itpos-icpos+1) then
                   if(obuf(ixpos-(itpos-icpos+1):ixpos-1).eq.
     *               bfill(1:itpos-icpos+1)) then
                     temp(ixpos-itpos+1:pcharl-itpos+1)=
     *               obuf(ixpos:pcharl)
                     pcharl=pcharl-(itpos-icpos)
                   endif
                 endif
               endif
               obuf(icpos:pcharl+itpos-icpos)=
     *           bfill(1:itpos-icpos)//temp(1:pcharl-icpos+1)
               ifree=ifree-(itpos-icpos)
               ioffst=ioffst+itpos-icpos
               pcharl=pcharl+itpos-icpos
             endif
             if(ifree.le.0)      goto 145
           enddo
           endif
145        pcharl=max(1,lastnb(obuf))
           write(outdev,'(a)') obuf(1:pcharl)
         else
           if(precn_.gt.0) then
           if(lprefx.gt.0) then
           write(outdev,'(a)') obuf(1:lprefx)
           else
           write(outdev,'(a)')
           endif
           else
           precn_=precn_-1
           endif
         endif
         waslop=.false.
         precn_=precn_+1
         do ii = 1,MAXTAB
           itabp(ii)=0
         enddo
         numtab=0
         if(lprefx.gt.0) then
           obuf=prefx(1:lprefx)
         else
           obuf=' '
         endif
C
C....... Load the next item into the buffer
C
150      pcharl=pchar+i
         if(ptabx_) pcharl=pchar+it
         waslop= ploopf.eq.'no '.and.ploopn.gt.0.and.align_
         if(i.eq.0) then
           if(pcharl.eq.lprefx+1.and.
     *       obuf(lprefx+1:lprefx+1).eq.' ') pcharl=pcharl-1
             pchar=pcharl+1
           goto 200
         endif
         if(ptabx_) then
           obuf(pchar:pcharl)=temp2(1:it)
         else
           if(string.eq.tab) pcharl=pcharl-1
           obuf(pchar:pcharl)=string(1:i)
         endif
         if(pchar.gt.1+lprefx) then
           numtab=numtab+1
           if(numtab.le.MAXTAB) itabp(numtab)=pchar
         endif
         pchar=pcharl+1
         if(pchar.gt.mxline+2) then
           if (pfold_.eq.0) then
             call warn(' Output CIF line longer than line_')
           else
             call warn(' Output CIF line longer than line_ or pfold_')
           endif
         endif
C
200      return
         end
C
C
C
C
C
C >>>>>> Convert the number and esd to string nnnn(m), limited
C        by relative precision prec
C
         subroutine putnum(numb,sdev,prec)  
C
         include   'ciftbx.sys'
         character  string*30,temp*30,c*1,sfmt*8
         double precision numb,sdev,prec,xxnumb,xsdev,slog
         integer    i,iexp,ifp,ii,jj,j,jlnz,jn,kexp,m,ixsdev,islog
         integer    kdecp,ibexp,lexp
C
         kdecp=0
         if (sdev.gt.abs(numb)*prec) then
           if (iabs(esdlim_).ne.esdcac) then
C
C            determine the number of digits set by esdlim_
C
             if (iabs(esdlim_).lt.9 .or.iabs(esdlim_).gt.99999) then
               call warn(' Invalid value of esdlim_ reset to 19')
               esdlim_ = 19
             endif
C
C            determine the number of esd digits
C
             esddigx = 1.+alog10(float(iabs(esdlim_)))
             esdcac = iabs(esdlim_)
           endif
C
C          if esdlim_ < 0, validate pesddig_
C
           if (esdlim_.lt. 0 )then
             if (pesddig_.lt.0 .or. pesddig_.gt.5) then
               call warn(' Invalid value of pesddig_ reset to 0')
               pesddig_ = 0
             endif
           endif
C
C          determine kexp, the power of 10 necessary
C          to present sdev as an integer in the range
C          (esdlim_/10,esdlim_] or [1,-esdlim_] if esdlim_ < 0
C
           slog = dlog10(sdev)
           islog = slog+1000.
           islog = islog-1000
           kexp = -islog+esddigx
C
C          Adjust exponent kexp, so that sdev*10**kexp
C          is in the interval (esdlim_/10,esdlim_] or [1,-esdlim_]
C
 20        if (kexp.lt.minexp) then
             call warn(' Underflow of esd')
             ixsdev = 0
             go to 30
           endif
           if (kexp.gt.-minexp) then
             call warn(' Overflow of esd')
             ixsdev = 99999
             go to 30
           endif
           xsdev = sdev*10.D0**kexp
           ixsdev = xsdev+.5
           if (ixsdev.gt.iabs(esdlim_)) then
             kexp = kexp -1
             go to 20
           endif
           if (ixsdev.lt.(iabs(esdlim_)+5)/10) then
             kexp = kexp+1
             go to 20
           endif
C
C          lexp holds the number of trailing zeros which may be
C          sacrificed in the esd if the number itself has 
C          trailing zeros in the fraction which is permitted if
C          esdlim_ is negative
C
C          If esdlim_ is negative and pesddig_ is .gt.0,
C          pesddig_ will be used to force the number of digits
C          in which case lexp has the number of digits that
C          must be sacrificed (lexp > 0) or zeros to add (lexp < 0)
C           
           lexp=0
           if(esdlim_.lt.0) then
             if(pesddig_.gt.0) then
25             continue
               if(ixsdev*10**(-lexp).ge.10**(pesddig_))then
                 if(lexp.gt.0)
     *             ixsdev=ixsdev-5*10**(lexp-1)
                 ixsdev=ixsdev+5*10**lexp
                 lexp=lexp+1
                 goto 25
               endif
               if(ixsdev.lt.10**(pesddig_-1+lexp)
     *           .and.lexp.gt.0) then
                 if(ixsdev*10**(-lexp).le.iabs(esdlim_))then
                   lexp =lexp-1
                   if(lexp.ge.0) then
                     ixsdev=ixsdev-5*10**lexp
                   endif
                   if(lexp.gt.0) then
                     ixsdev=ixsdev+5*10**(lexp-1)
                   endif
                   goto 25
                 endif
               endif
               kexp=kexp-lexp
               ixsdev = ixsdev/(10**lexp)
               lexp=0
             else
             do ii = 1,4
               if(mod(ixsdev,10**ii).ne.0) go to 30
               lexp = ii
             enddo
             endif
           endif
C
C          We need to present the number to the same scaling
C          at first, but will adjust to avoid Ennn notation
C          if possible
C
 30        xxnumb = dabs(numb)*10.d0**kexp+.5
           if(xxnumb*prec .gt.1.D0) then
             call warn(' ESD less than precision of machine')
             ixsdev=0
           endif
           if(numb.lt.0.d0) xxnumb = -xxnumb
           write(string,ndpfmt)xxnumb
           if(xxnumb.lt.1.d0 .and. xxnumb.ge.0.d0)  
     *        string='                         0.0E0'
           if(xxnumb.gt.-1.d0 .and. xxnumb.lt.0.d0) 
     *        string='                        -0.0E0'
C
C          Extract the power of 10
C
           iexp = 0
           ibexp = 0
           do ii = 0,4
             i = 30-ii
             c = string(i:i)
             m = index('0123456789',c)
             if (m.gt.0) then
               iexp = iexp+(m-1)*10**(ii-ibexp)
             else
               if (c.eq.' ') then
                 ibexp = ibexp+1
               else
               if (c.eq.'-') iexp=-iexp
               goto 40
               endif
             endif
           enddo
           call err(' Internal error in putnum')
C
C          Scan the rest of the string shifting the
C          decimal point to get an integer
C
40         ifp = 0
           j=1
           do ii = 1,i-1
           c = string(ii:ii)
           if (c.ne.' ')then
             m=index('0123456789+-',c)
             if(m.ne.0) then
               temp(j:j)=c
               if(j.gt.1.or.c.ne.'0')j=j+1
               if(j.eq.3.and.temp(1:2).eq.'-0')j=j-1
               if(ifp.ne.0)then
                 iexp=iexp-1
                 if(iexp.le.0) goto 50
               endif
             else
               if(c.eq.'.') then
                 ifp=1
                 if(iexp.le.0) goto 50
               endif
             endif
           endif
           enddo
C
C          The string from 1 to j-1 has an integer
C          If iexp < 0, we present a 0.  If iexp > 0
C          we pad with zeros
C
50         if(j.eq.2 .and. temp(1:1).eq.'-') then
              temp(1:2)='-0'
              j=3
              iexp=0
           endif
           if(j.eq.1 .or .iexp.lt.0) then
             temp(1:1)='0'
             j=2
             iexp = 0
             if(xxnumb.lt.0.d0) then
               temp(1:2)='-0'
               j=3
             endif
           endif
           if (iexp.gt.0) then
             do ii = 1,iexp
             temp(j:j)='0'
             j=j+1
             enddo
             iexp=0
           endif
           string=temp(1:j-1)
C
C          We have the number for which the presentation
C          would be nnnnnE-kexp.  If kexp is gt 0, we can
C          decrease it and introduce a decimal point
C
           jj=0
           if(index('0123456789',temp(1:1)).eq.0) jj=1
           if(kexp.gt.0.and.kexp.lt.j-jj+8) then
             if(kexp.lt.j-1) then
               if(plzero_ .and.
     *           j-1-kexp.eq.1.and.temp(1:1).eq.'-') then
                 string=temp(1:j-1-kexp)//'0.'//
     *             temp(j-kexp:j-1)
                 j=j+2
               else
                 string=temp(1:j-1-kexp)//'.'//
     *           temp(j-kexp:j-1)
                 j=j+1
               endif
               kexp = 0
             else
               if(jj.ne.0)string(1:1)=temp(1:1)
               if(plzero_) then
                 string(1+jj:2+jj)='0.'
                 do ii=1,kexp-(j-1-jj)
                   string(2+jj+ii:2+jj+ii)='0'
                 enddo
                 string(3+jj+(kexp-(j-1-jj)):30)=
     *             temp(1+jj:j-1)
                 j=j+2+kexp-(j-1-jj)
               else
                 string(1+jj:1+jj)='.'
                 do ii=1,kexp-(j-1-jj)
                   string(1+jj+ii:1+jj+ii)='0'
                 enddo
                 string(2+jj+(kexp-(j-1-jj)):30)=
     *             temp(1+jj:j-1)
                 j=j+1+kexp-(j-1-jj)
               endif
               kexp=0
             endif
           endif
           kdecp=index(string(1:j-1),'.')
           if(kdecp.gt.0.and.kdecp.lt.j-1.and.lexp.gt.0) then
             jj=0
             do ii = 1,min(lexp,j-1-kdecp)
               c = string(j-ii:j-ii)
               if(c.ne.'0') goto 60
               jj=jj+1
             enddo
60           j=j-jj
             ixsdev=ixsdev/10**jj
             if(.not.pdecp_.and.string(j-1:j-1).eq.'.') then
               j=j-1
               kdecp=0
             endif
           endif
           if(kdecp.eq.0) then
             kdecp=j
             if(pdecp_) then
               if(plzero_.and.
     *           (j.eq.1 .or. (j.eq.2.and.string(1:1).eq.'-'))) then
                 string(j:j)='0'
                 j=j+1
               endif
               string(j:j)='.'
               j=j+1
             endif
           endif
           if(kexp.ne.0) then
             write(temp(1:5),'(i5)') -kexp
             string(j:j)='E'
             j=j+1
             do ii=1,5
               c=temp(ii:ii)
               if(c.ne.' ') then
                 string(j:j)=c
                 j=j+1
               endif
             enddo
           endif
C
C          if there is a standard deviation
C          append it in parentheses
C
           if(ixsdev.ne.0) then
             write(temp(1:5),'(i5)') ixsdev
             string(j:j)='('
             j=j+1
             do ii=1,5
               c=temp(ii:ii)
               if(c.ne.' ') then
                 string(j:j)=c
                 j=j+1
               endif
             enddo
             string(j:j)=')'
             j=j+1
           endif
         else
C
C          There is no standard deviation, just write numb
C          But limit to the digits implied by prec
C
           slog = dlog10(min(.1D0,max(prec,dpprc)))
           islog = slog+1000.5
           islog = islog-1000
           kexp = -islog
           write(sfmt,'(5h(D30.,i2,1h))') kexp
           write(temp,sfmt)numb
C
C          Now have the number in the form 
C          [sign][0].nnnnnnnnDeee
C          which, while sufficient, is not neat
C          we reformat for the case 0<=eee<=kexp
C
C
C          Extract the power of 10
C
           iexp = 0
           ibexp = 0
           do ii = 0,4
             i = 30-ii
             c = temp(i:i)
             m = index('0123456789',c)
             if (m.gt.0) then
               iexp = iexp+(m-1)*10**(ii-ibexp)
             else
               if (c.eq.' ') then
                 ibexp = ibexp+1
               else
               if (c.eq.'-') iexp=-iexp
               goto 140
               endif
             endif
           enddo
           call err(' Internal error in putnum')
C
C          Scan the rest of the string shifting the
C          decimal point to get a number with exponent 0,
C          if possible
C
140        ifp = 0
           j=1
           do ii = 1,i-1
           jn=ii
           c = temp(ii:ii)
           if (c.ne.' ')then
             m=index('0123456789+-',c)
             if(m.ne.0) then
               string(j:j)=c
               if(j.gt.1.or.c.ne.'0')j=j+1
               if(j.eq.3.and.string(1:2).eq.'-0')j=j-1
               if(ifp.ne.0)then
                 iexp=iexp-1
                 if(iexp.le.0) goto 150
               endif
             else
               if(c.eq.'.') then
                 ifp = -1
                 if(iexp.le.0) goto 150
               endif
             endif
           endif
           enddo
150        if(plzero_ .and.
     *       (j.eq.1 .or.(j.eq.2.and.string(1:1).eq.'-'))) then
             string(j:j)='0'
             j=j+1
           endif
           string(j:j)='.'
           ifp = j
           j = j+1
           jlnz = j-1
155        do ii = jn+1,i-1
             c = temp(ii:ii)
             if (c.ne.' ')then
               m=index('0123456789',c)
               if(m.ne.0) then
                 string(j:j)=c
                 j=j+1
                 if(m.ne.1)jlnz=j
                 if(m.eq.1.and.ifp.ge.1.and.
     *             pposdec_.ne.0.and.pposend_.ne.0) then
                   if(j-1-ifp-min(iexp,0).le.pposend_-pposdec_)
     *               jlnz=j
                 endif
               else
                 goto 160
               endif
             endif
           enddo
160        j=jlnz
           if(j.eq.1) then
            string(1:1)='0'
            j=2
           endif
           if(iexp.lt.0.and.iexp.gt.-7.and.ifp.lt.j-1.and.
     *       ifp.ne.0.and.j-ifp-iexp.le.kexp) then
             temp(1:ifp)=string(1:ifp)
             do ii = 1,-iexp
               temp(ifp+ii:ifp+ii) = '0'
             enddo
             temp(ifp-iexp+1:j-iexp-1) = string(ifp+1:j-1)
             j = j-iexp
             iexp=0
             string(1:j-1) = temp(1:j-1)
           endif
           kdecp=index(string(1:j-1),'.')
           if(kdecp.eq.0) then
             kdecp=j
             if(pdecp_) then
               string(kdecp:kdecp)='.'
               j=j+1
             endif
           endif
           if(iexp.ne.0) then
             write(temp(1:5),'(i5)')iexp
             string(j:j)='E'
             j=j+1
             do ii=1,5
               c=temp(ii:ii)
               if(c.ne.' ') then
                 string(j:j)=c
                 j=j+1
               endif
             enddo
           endif
         endif
C
         if(j.lt.1) then
           string(1:1)='0'
           j=2
         endif
         if(kdecp.lt.1)kdecp=j
         if(pposdec_.ne.0) then
           pchar=lprefx+pposdec_-kdecp+1
         else
           if(pposval_.ne.0)pchar=lprefx+pposval_
         endif
         call putstr(string(1:j-1))
         return
         end
C
C
C
C
C
C >>>>>> Check dictionary for data name validation    
C
         subroutine dcheck(name,type,flag,tflag)
C
         include   'ciftbx.sys'
         logical    flag,tflag
         integer    nln
         character  name*(*),temp*(NUMCHAR),
     *              type*4
C
         flag=.true.
         tflag=.true.
         nln = min(len(name),len(temp))
         call tbxxnlc(temp(1:nln),name)
         call hash_find(temp(1:nln),
     *     dicnam,dicchain,NUMDICT,ndict,dichash,NUMHASH,xdchk)
         if(xdchk.eq.0) goto 150
         if(tcheck.eq.'no ')          goto 200
         if(type.eq.dictyp(xdchk))    goto 200
         if(type.eq.'    ')           goto 200
         if(dictyp(xdchk).eq.'text' .and. type.eq.'char') goto 200
         if(dictyp(xdchk).eq.'char' .and. type.eq.'numb') goto 200
         tflag=.false.
         goto 200
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
         if(ptextf.ne.'yes') then
           call warn(' Out-of-sequence call to end text block')
           return
         endif
         ptextf='no '
         pchar=-1
         if (xmlout_) then
           call putstr(']]>')
           if (ploopn.gt.1) then
             call putxc(plhead(ploopc+1),plxhead(ploopc+1))
           endif
           if (ploopn.le.0) then
             call putxc(plhead(1),plxhead(1))
             plhead(1) = ' '
             plxhead(1) = ' '
           endif
         else
           call putstr(';')
         endif
         call putstr(char(0))
         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.-1) then
           if (xmlout_) then
             plcat = ' '
             plxcat = ' '
             plhead(1) = 'DUMMY'
             plxhead(1) = ' '
           else
             call putstr('_DUMMY')
           endif
           ploopn=1
           ploopc=0
           call warn(
     *       ' Missing: missing loop_ name set as _DUMMY')
         endif
         if (xmlout_ .and. ploopn.eq.1 .and. 
     *     ploopf.ne.'yes') then
           call putxc(plhead(2),plxhead(2))
         endif
         if(ploopn.eq.ploopc)     goto 200
         do i=ploopc+1,ploopn
         if (xmlout_) then
           call putxo(plhead(i+1),plxhead(1+1))
           call putstr('DUMMY')
           call putxc(plhead(i+1),plxhead(i+1))
         else
           call putstr('DUMMY')
         endif
         enddo
         call warn(    
     *         ' Missing: missing loop_ items set as DUMMY')
         plhead(1) = ' '
         plxhead(1) = ' '
C
200      ploopc=0
         ploopn=0
         if (xmlout_) then
           call putxc(plhead(1),plxhead(1))
           plhead(1) = ' '
           call putxc(plcat,plxcat)
           plcat = ' '
         endif
         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 recbeg_    /1/
         data recend_    /0/
         data loopct     /0/
         data nhash      /0/
         data ndict      /0/
         data nname      /0/
         data nbloc      /0/
         data ploopn     /0/
         data ploopc     /0/
         data xmnxlat    /0/
         data xmdata     /0/
         data ploopf     /'no '/
         data ptextf     /'no '/
         data pfilef     /'no '/
         data testfl     /'no '/
         data textfl     /'no '/
         data vcheck     /'no '/
         data tcheck     /'no '/
         data catchk     /'yes'/
         data parchk     /'yes'/
         data align_     /.true./
         data append_    /.false./
         data tabl_      /.true./
         data tabx_      /.true./
         data ptabx_     /.true./ 
         data text_      /.false./
         data loop_      /.false./
         data ndcname    /0/
         data ncname     /0/
         data save_      /.false./
         data saveo_     /.false./
         data psaveo     /.false./
         data glob_      /.false./
         data globo_     /.false./
         data alias_     /.true./
         data aliaso_    /.false./
         data nblank_    /.false./
         data nblanko_   /.false./
         data decp_      /.false./
         data pdecp_     /.false./
         data lzero_     /.false./
         data plzero_    /.false./
         data xmlout_    /.false./
         data catkey     /NUMDICT*.false./
         data xmlong_    /.true./
         data dchash     /NUMHASH*0/
         data dichash    /NUMHASH*0/
         data dhash      /NUMHASH*0/
         data dcchain    /NUMDICT*0/
         data aroot      /NUMDICT*0/
         data keychain   /NUMDICT*0/
         data ccatkey    /NUMDICT*0/
         data cindex     /NUMBLOCK*0/
         data line_      /80/
         data lastch     /0/
         data dictype_   /' '/
         data dicname_   /' '/
         data dicver_    /' '/
         data diccat_    /' '/
         data tagname_   /' '/
         data plcat      /' '/
         data plhead     /NUMLP1*' '/
         data prefx      /' '/
         data file_      /' '/
         data longf_     /1/
         data tbxver_    /'CIFtbx version 3.0.4  1 Sep 2006'/
         data lprefx     /0/
         data esdlim_    /19/
         data esddig_    /0/
         data pesddig_   /0/
         data esdcac     /19/
         data esddigx    /2/
         data esdfmt     /'(e12.2)'/
         data edpfmt     /'(d12.2)'/
         data ndpfmt     /'(d30.14)'/
         data decprc     /1.e-6/
         data dpprc      /1.d-14/
         data decmin     /1.e-37/
         data dpmin      /1.d-307/
         data minexp     /-307/
         data itabp      /MAXTAB*0/
         data jrect      /-1/
         data numtab     /0/
         data recn_      /0/
         data precn_     /0/
         data posnam_    /0/
         data posval_    /0/
         data posdec_    /0/
         data posend_    /0/
         data pposnam_   /0/
         data pposval_   /0/
         data pposdec_   /0/
         data pposend_   /0/
         data quote_     /' '/
         data pquote_    /' '/
         data unfold_     /.false./
         data fold_      /.false./
         data pfold_     /0/
         data ibkmrk     /MAXBOOK*-1,MAXBOOK*-1,
     *                    MAXBOOK*-1,MAXBOOK*-1/
         data lnametb    /1/
         data nametb     /' '/

         end
C
C
C       change the following include to include 'clearfp_sun.f'
C       for use on a SUN
C
        include 'clearfp.f'