C
C CIFtbx README FIRST Information
C -------------------------------
C (Version July 17 1994)
C
C This file contains the complete set of source decks and test data
C needed to implement and test the CIFtbx Tool Box routines.
C
C
C Here is the recommended procedure for implementing and testing CIFtbx.
C
C
C 1. Use your editor to separate the different parts of the file into
C individual files in your workspace. Each part is partitioned by
C a line containing "---cut here---". Use your editor to search for
C these lines. Each part is carefully labelled and indicates the
C recommended filename for the separated file. On some machines
C these filenames may need to be altered to suit the OS or compiler.
C
C The partitions are as follows:
C
C part filename description
C
C 1 ciftbx.f CIFtbx fortran source
C 2 ciftbx.sys CIFtbx common for inclusion into ciftbx.f
C 3 ciftbx.cmn CIFtbx common for inclusion into applications
C 4 tbx_ex.f example application used to test ciftbx.f
C 5 test.cif example CIF used by tbx_ex.f
C 6 test.req example request file used by tbx_ex.f
C 7 test.prt print file output from tbx_ex.f run
C 8 test.out CIF output by the tbx_ex.f run
C
C
C 2. Once you have separated out these files, list 'ciftbx.f' and 'tbx_ex.f'
C in particular (all if possible!) and carefully read the descriptions
C in the front of these files. Remember that 'tbx_ex.f' is only an
C example of a CIF application -- it shows how some basic CIF operations
C can be performed, but it is not necessarily sensible or typical of what
C an actual application would look like!
C
C
C 3. You are now ready to implement the tool box and the test application.
C Here are the recommended steps for a unix system. Vary this according
C to the requirements of your OS and compiler. ***Note*** to execute
C the supplied example application 'tbx_ex.f' identically to the test
C outputs supplied, a copy of the CIF Core Dictionary 'cifdic.c91' must
C be present in your work area. If it is not the tests will proceed with
C a warning message but no validations checks will occur. A copy of the
C dictionary 'cifdic.c91' can be obtained from 'syd@crystal.uwa.edu.au'.
C
C
C (a) compile 'tbx_ex.f' [note that provided the fortran "include"
C function is available to you, the files 'ciftbx.f', 'ciftbx.sys'
C and 'ciftbx.cmn' will be automatically opened and processed by
C this single operation]
C
C (b) link 'tbx_ex.o' as the executable file 'tbx_ex.x'
C
C (c) execute 'tbx_ex.x' so that the input file is 'test.req' connected
C to device 5 (stdin) and the list file 'test.lst' is connected to
C device 6 (stdout). The input CIF 'test.cif' and the output CIF
C 'test.new' will be automatically opened. For a unix OS the command
C will look like this: 'tbx_ex.x < test.req > test.lst'
C
C (d) to check that the test has been successful, compare the files that
C you have generated 'test.lst' with the supplied 'test.prt', and
C 'test.new' with 'test.out'. They should be identical.
C
C (e) if you have any problems with this process please report them to
C Syd Hall [em: syd@crystal.uwa.edu.au fx: 61(9)3801118].
C
C 4. You are now ready to implement CIFtbx for your software applications.
C Note that it more efficient to compile 'ciftbx.f' separately and add
C 'ciftbx.o' at link time. Note that the line "include 'ciftbx.cmn'"
C MUST appear at the start of any routine invoking the CIFtbx commands.
C
C
C-------------------------cut here------------------------------------------
C
C
C \ | / /##| @@@@ @ @@@@@ | |
C \|/ STAR /###| @ @ @ __|__ |
C ----*---- /####| @ @ @@@@ | |___ __ __
C /|\ /#####| @ @ @ | | \ \/
C / | \ |#####| @@@@ @ @ \___/ \___/ __/\__
C |#####|________________________________________________
C ||#####| ___________________ |
C __/|_____||#####|________________|&&&&&&&&&&&&&&&&&&&|| |
C<\\\\\\\\_ |_____________________________|&&&& Jul 17 94 &&&&|| |
C \| ||#####|________________|&&&&&&&&&&&&&&&&&&&||__________|
C |#####|
C |#####|
C |#####|
C /#######\
C |#########|
C ====
C ||
C A tool box of fortran routines for manipulating CIF data.
C ||
C ||
C The latest program source and information is available from:
C ||
C Em: syd@crystal.uwa.edu.au ,-_|\ Sydney R. Hall
C sendcif@crystal.uwa.edu.au / \ Crystallography Centre
C Fx: +61 9 380 1118 || --> *_,-._/ University of Western Australia
C Ph: +61 9 380 2725 || v Nedlands 6009, AUSTRALIA
C ||
C_____________________||_____________________________________________________
C
C
C GENERAL TOOLS
C
C
C init_ Sets the device numbers of files. (optional)
C [logical function always returned .true.]
C
C Set output CIF device (def=2)
C
C Set direct access formatted
C scratch device number (def=3)
C
C Set error message device (def=6)
C
C
C
C dict_ Requests a CIF dictionary be used for various data checks.
C [logical function returned as .true. is the name dictionary
C was opened; and if the check codes are recognisable.]
C
C A CIF dictionary in DDL format
C
C The codes specifying the types of
C checks to be applied to the CIF.
C
C 'valid' data name validation check.
C 'dtype' data item data type check.
C
C___________________________________________________________________________
C
C
C CIF ACCESS TOOLS ("the get_ing commands")
C
C
C
C open_ Opens the CIF containing the required data.
C [logical function returned .true. if CIF opened]
C
C
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 A blank name signals that the next
C encountered block is used (the block
C name is stored in the variable bloc_).
C
C
C
C test_ Identify the data attributes of the named data item.
C [logical function returned as .true. if the item is present or
C .false. if it is not. The data attributes are stored in the
C the common variables type_ and list_.
C
C list_ is an integer variable containing the sequential number
C of the loop block in the data block. If the item is not within
C a loop structure this value will be zero.
C
C type_ is a character*4 variable with the possible values:
C 'numb' for number data
C 'char' for character data
C 'text' for text data
C 'null' if data missing or '?']
C
C Name of the data item to be tested.
C
C
C
C name_ Get the next data name in the current data block.
C [logical function returned as .true. if a new data name exists
C in the current data block, and .false. when the end of the data
C block is reached.]
C
C 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 Name of the number sought.
C
C Returned number.
C
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
C Name of the string sought.
C
C Returned string is of length long_.
C
C
C____________________________________________________________________________
C
C
C
C CIF CREATION TOOLS ("the put_ing commands")
C
C
C
C pfile_ Create a file with the specified file name.
C [logical function returned as .true. if the file is opened.
C The value will be .false. if the file already exists.]
C
C
C
C
C
C pdata_ Put a data block command into the created CIF.
C [logical function returned as .true. if the block is created.
C The value will be .false. if the block name already exists.]
C
C
C
C
C
C ploop_ Put a loop_ data name into the created CIF.
C [logical function returned as .true. if the invocation
C conforms with the CIF logical structure.]
C
C
C
C
C
C pchar_ Put a character string into the created CIF.
C [logical function returned as .true. if the name is unique,
C AND, if dict_ is invoked, is a name defined in the dictionary,
C AND, if the invocation conforms to the CIF logical structure.]
C
C If the name is blank, do not output name.
C
C A character string of 80 chars or less.
C
C
C
C pnumb_ Put a number and its esd into the created CIF.
C [logical function returned as .true. if the name is unique,
C AND, if dict_ is invoked, is a name defined in the dictionary,
C AND, if the invocation conforms to the CIF logical structure.]
C
C If the name is blank, do not output name.
C
C Number to be inserted.
C
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 the name is blank, do not output name.
C
C A character string of 80 chars or less.
C
C
C
C close_ Close the creation CIF. MUST be used if pfile_ is used.
C [subroutine call]
C
C
C____________________________________________________________________________
C
C
C
C....The CIF tool box also provides variables for data access control:
C
C
C text_ Logical variable signals if another text line is present.
C
C loop_ Logical variable signals if another loop packet is present.
C
C bloc_ Character*32 variable: the current block name.
C
C strg_ Character*80 variable: the current data item.
C
C type_ Character*4 variable: the data type code (see test_).
C
C list_ Integer variable: the loop block number (see test_).
C
C long_ Integer variable: the length of the data string in strg_.
C
C file_ Character*80 variable: the filename of the current file.
C
C longf_ Integer variable: the length of the filename in file_.
C
C align_ Logical variable signals alignment of loop_ lists during
C the creation of a CIF. The default is .true.
C
C
C_____________________________________________________________________________
C
C
C >>>>>> Set the device numbers.
C
function init_(devcif,devout,devdir,deverr)
C
include 'ciftbx.sys'
logical init_
integer devcif,devout,devdir,deverr
C
init_=.true.
cifdev=devcif
outdev=devout
dirdev=devdir
errdev=deverr
return
end
C
C
C
C
C
C >>>>>> Read a CIF dictionary and prepare for checks
C
function dict_(fname,checks)
C
include 'ciftbx.sys'
logical dict_,data_,open_,char_
character locase*80
character fname*(*),checks*(*)
character temp*24,codes(4)*5,name*80
integer idict,i,j
data codes /'valid','dtype',' ',' '/
C
C....... Open and store the dictionary
C
if(nname.gt.0) call err(' dict_ must precede open_')
dict_=open_(fname)
if(.not.dict_) goto 500
dictfl='yes'
C
C....... Are the codes OK
C
temp=checks
i=0
120 i=i+1
if(i.ge.24) goto 200
if(temp(i:i).eq.' ') goto 120
do 150 j=1,4
if(temp(i:i+4).eq.codes(j)) goto 170
150 continue
dict_=.false.
goto 500
170 i=i+4
if(j.eq.1) vcheck='yes'
if(j.eq.2) tcheck='yes'
goto 120
C
C....... Loop over data blocks; extract _name's, _type etc.
C
200 if(.not.data_(' ')) goto 400
idict=ndict+1
Cdbg WRITE(6,*) ndict,bloc_
C
250 if(.not.char_('_name',name))goto 200
ndict=ndict+1
if(ndict.gt.1000) call err(' cifdic names > 1000')
dicnam(ndict)=locase(name(1:long_))
if(loop_) goto 250
C
if(tcheck.eq.'no ') goto 200
if(.not.char_('_type',name))call err(' _type line missing')
do 270 i=idict,ndict
270 dictyp(i)=name(1:4)
goto 200
C
400 close(dirdev)
if(tcheck.eq.'yes') vcheck='yes'
dictfl='no '
Cdbg WRITE(6,'(i5,3x,a,2x,a)') (i,dicnam(i),dictyp(i),i=1,ndict)
500 return
end
C
C
C
C
C
C >>>>>> Open a CIF and copy its contents into a direct access file.
C
function open_(fname)
C
include 'ciftbx.sys'
logical open_,test
character fname*(*)
integer case,i
C
jchar=80
nrecd=0
lrecd=0
case=ichar('a')-ichar('A')
tab=char(05)
if(case.lt.0) goto 100
tab=char(09)
C
C....... Make sure the CIF is available to open
C
100 file_=fname
do 120 i=1,80
if(file_(i:i).eq.' ') goto 140
120 continue
140 longf_=i-1
inquire(file=file_(1:longf_),exist=test)
open_=test
if(.not.open_) goto 200
C
C....... Open up the CIF and a direct access formatted file as scratch
C
open(unit=cifdev,file=fname,status='OLD',access='SEQUENTIAL',
* form='FORMATTED')
open(unit=dirdev,status='SCRATCH',access='DIRECT',
* form='FORMATTED',recl=80)
C
C....... Copy the CIF to the direct access file
C
160 read(cifdev,'(a)',end=180) buffer
nrecd=nrecd+1
write(dirdev,'(a)',rec=nrecd) buffer
Cdbg WRITE(6,'(i5,1x,a)') nrecd,buffer(1:70)
goto 160
C
180 lrecd=0
close(cifdev)
200 return
end
C
C
C
C
C
C >>>>>> Store the data names and pointers for the requested data block
C
function data_(name)
C
include 'ciftbx.sys'
logical data_
character name*(*),flag*4,temp*32,ltype*4
character locase*80
integer ndata,idata,nitem,npakt,i,j
C
jchar=80
jrecd=0
nname=0
ndata=0
nitem=0
idata=0
iname=0
loopct=0
loopnl=0
ltype=' '
data_=.false.
loop_=.false.
text_=.false.
irecd=lrecd
lrecd=nrecd
if(name(1:1).ne.' ') irecd=0
C
C....... Find the requested data block in the file
C
100 call getstr
if(type_.eq.'fini') goto 500
if(type_.ne.'text') goto 120
110 call getlin(flag)
if(buffer(1:1).ne.';') goto 110
call getlin(flag)
goto 100
120 if(type_.ne.'data') goto 100
if(name.eq.' ') goto 150
if(strg_(6:long_).ne.name) goto 100
150 data_=.true.
bloc_=strg_(6:long_)
C
C....... Get the next token and identify
C
200 call getstr
Cdbg WRITE(6,*) ltype,type_,loop_,nitem,ndata,idata,irecd,lrecd
C
if(ltype.ne.'name') goto 201
if(type_.eq.'numb') goto 203
if(type_.eq.'char') goto 203
if(type_.eq.'text') goto 203
if(type_.eq.'name'.and.loop_) goto 204
call err(' Illegal tag/value construction')
201 if(ltype.ne.'valu') goto 204
if(type_.eq.'numb') goto 202
if(type_.eq.'char') goto 202
if(type_.eq.'text') goto 202
goto 204
202 if(nitem.gt.0) goto 205
call err(' Illegal tag/value construction')
203 ltype='valu'
goto 205
204 ltype=type_
C
205 if(type_.eq.'name') goto 206
if(type_.eq.'loop') goto 210
if(type_.eq.'data') goto 210
if(type_.ne.'fini') goto 220
206 if(loop_) goto 270
210 if(nitem.eq.0) goto 215
C
C....... End of loop detected; save pointers
C
npakt=idata/nitem
if(npakt*nitem.ne.idata) call err(' Item miscount in loop')
loopni(loopct)=nitem
loopnp(loopct)=npakt
nitem=0
idata=0
215 if(type_.eq.'name') goto 270
if(type_.eq.'data') goto 300
if(type_.eq.'fini') goto 300
C
C....... Loop_ line detected; incr loop block counter
C
loop_=.true.
loopct=loopct+1
if(loopct.gt.50) call err(' Number of loop_s > 50')
goto 200
C
C....... This is the data item; store char position and length
C
220 loop_=.false.
if(nitem.gt.0) idata=idata+1
if(nname.eq.ndata) goto 230
ndata=ndata+1
if(iloop(ndata).gt.1) goto 225
krecd=irecd
kchar=jchar-long_-1
225 dtype(ndata)=type_
drecd(ndata)=krecd
dchar(ndata)=kchar
if(nloop(ndata).gt.0) goto 230
nloop(ndata)=0
iloop(ndata)=long_
C
C....... Skip text lines if present
C
230 if(type_.ne.'text') goto 200
dchar(ndata)=0
if(nloop(ndata).eq.0) iloop(ndata)=80
250 call getlin(flag)
if(buffer(1:1).eq.';') goto 200
if(flag.eq.'fini') call err(' Unexpected end of data')
goto 250
C
C....... This is a data name; store name and loop parameters
C
270 nname=nname+1
if(nname.gt.500) call err(' Number of data names > 500')
dname(nname)=locase(strg_(1:long_))
lloop(nname)=0
nloop(nname)=0
iloop(nname)=0
if(.not.loop_) goto 200
nitem=nitem+1
if(nitem.gt.20) call err(' Items per loop packet > 20')
nloop(nname)=loopct
iloop(nname)=nitem
goto 200
C
C....... Are names checked against dictionary?
C
300 if(dictfl.eq.'yes') goto 500
if(vcheck.eq.'no ') goto 500
C
do 350 i=1,nname
temp=dname(i)
do 330 j=1,ndict
if(temp.ne.dicnam(j)) goto 330
if(tcheck.eq.'no ') goto 350
if(dtype(i).eq.dictyp(j)) goto 350
write(errdev,'(2a,1x,2a)') ' Warning: type ',dtype(i),temp,
* ' different to dictionary!'
goto 350
330 continue
write(errdev,'(3a)') ' Warning: data name ',temp,
* ' not in dictionary!'
350 continue
C
C....... End of data block; tidy up loop storage
C
500 lrecd=irecd-1
loop_=.false.
loopct=0
if(ndata.ne.nname) call err(' Syntax construction error')
C
Cdbg WRITE(6,'(a)')
Cdbg * ' data name type recd char loop leng'
Cdbg WRITE(6,'(a,1x,a,4i5)') (dname(i),dtype(i),drecd(i),dchar(i),
Cdbg * nloop(i),iloop(i),i=1,nname)
Cdbg WRITE(6,'(3i5)') (i,loopni(i),loopnp(i),i=1,loopct)
C
return
end
C
C
C
C
C
C
C >>>>>> Get the attributes of data item associated with data name
C
function test_(temp)
C
include 'ciftbx.sys'
logical test_
character temp*(*),name*32
character locase*80
C
testfl='yes'
name=locase(temp)
test_=.true.
if(testfl.eq.'no ') goto 100
if(name.eq.nametb) goto 200
100 call getitm(name)
200 list_ =loopnl
if(type_.eq.'null') test_=.false.
return
end
C
C
C
C
C
C
C >>>>>> Get the next data name in the data block
C
function name_(temp)
C
include 'ciftbx.sys'
logical name_
character temp*(*)
C
name_=.false.
temp=' '
iname=iname+1
if(iname.gt.nname) goto 100
name_=.true.
temp=dname(iname)
100 return
end
C
C
C
C
C
C
C >>>>>> Extract a number data item and its standard deviation
C
function numb_(temp,numb,sdev)
C
include 'ciftbx.sys'
logical numb_
character temp*(*),name*32
character locase*80
real numb,sdev
C
name=locase(temp)
if(testfl.eq.'no ') goto 100
if(name.eq.nametb) goto 150
C
100 call getitm(name)
C
150 numb_=.false.
if(type_.ne.'numb') goto 200
numb_=.true.
numb =numbtb
if(sdevtb.ge.0.0) sdev=sdevtb
C
200 testfl='no '
return
end
C
C
C
C
C
C
C >>>>>> Extract a character data item.
C
function char_(temp,strg)
C
include 'ciftbx.sys'
logical char_
character temp*(*),name*32
character strg*(*),flag*4
character locase*80
C
name=locase(temp)
if(testfl.eq.'yes') goto 100
if(.not.text_) goto 120
100 if(name.eq.nametb) goto 150
C
120 call getitm(name)
C
150 char_=.true.
text_=.false.
strg=strg_(1:long_)
if(type_.eq.'char') goto 200
char_=.false.
if(type_.ne.'text') goto 200
char_=.true.
call getlin(flag)
if(buffer(1:1).eq.';') goto 200
text_=.true.
strg_=buffer
C
200 testfl='no '
return
end
C
C
C
C
C
C >>>>> Convert name string to lower case
C
function locase(name)
C
include 'ciftbx.sys'
character locase*80
character temp*80,name*(*)
character low*26,cap*26,c*1
data cap /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
data low /'abcdefghijklmnopqrstuvwxyz'/
C
temp=name
do 100 i=1,80
c=temp(i:i)
if(c.eq.' ') goto 200
j=index(cap,c)
if(j.ne.0) temp(i:i)=low(j:j)
100 continue
200 locase=temp
return
end
C
C
C
C
C
C >>>>>> Get the data item associated with the tag.
C
subroutine getitm(name)
C
include 'ciftbx.sys'
SAVE
character name*(*),lname(20)*32
character fhash*3,flag*4
integer phash(20),ihash
integer loopch(21),loopln(21),looprd(21)
integer iitem,nitem,npakt
integer kchar,loopi,i
data fhash/'no '/
C
C....... Find requested dataname in hash list
C
nametb=name
if(name(1:1).eq.'_') goto 100
type_='null'
long_=1
goto 1000
100 if(.not.loop_) goto 150
fhash='no '
do 120 ihash=1,nhash
if(lname(ihash).eq.nametb) goto 170
120 continue
if(nhash.eq.20) goto 150
fhash='yes'
C
C....... Else find requested dataname in full list
C
150 do 160 iname=1,nname
if(dname(iname).eq.nametb) goto 180
160 continue
type_='null'
long_=1
goto 1000
C
C....... Update the hash table if need be
C
170 iname=phash(ihash)
180 if(fhash.eq.'no ') goto 190
nhash=nhash+1
phash(nhash)=iname
lname(nhash)=name
190 if(nloop(iname).le.0) goto 500
C
C....... Process loop packet if first item request
C
if(nloop(iname).ne.loopnl) goto 200
if(lloop(iname).lt.loopct) goto 300
if(loop_) goto 230
200 loop_=.true.
nhash=0
loopct=0
loopnl=nloop(iname)
nitem=loopni(loopnl)
npakt=loopnp(loopnl)
irecd=drecd(iname)-1
call getlin(flag)
jchar=max(0,dchar(iname)-1)
C error jchar=dchar(iname)-1
Cdbg if(jchar.lt.0) write(6,'(" dchar ",i5)') jchar
do 220 i=1,nname
220 lloop(i)=0
goto 240
C
C....... Read a packet of loop items
C
230 irecd=looprd(nitem+1)-1
call getlin(flag)
jchar=loopch(nitem+1)
Cdbg if(jchar.lt.0) write(6,'(" loopch",i5)') jchar
240 iitem=0
250 iitem=iitem+1
if(iitem.le.nitem) goto 255
loopch(iitem)=jchar
looprd(iitem)=irecd
goto 270
255 call getstr
loopch(iitem)=jchar-long_
loopln(iitem)=long_
looprd(iitem)=irecd
if(type_.ne.'text') goto 250
260 call getlin(flag)
if(buffer(1:1).ne.';') goto 260
call getlin(flag)
goto 250
270 loopct=loopct+1
if(loopct.lt.npakt) goto 300
loop_=.false.
C
C....... Point to the loop data item
C
300 lloop(iname)=lloop(iname)+1
loopi=iloop(iname)
irecd=looprd(loopi)-1
call getlin(flag)
long_=loopln(loopi)
kchar=loopch(loopi)
goto 550
C
C....... Point to the non-loop data item
C
500 irecd=drecd(iname)-1
call getlin(flag)
kchar=dchar(iname)+1
long_=iloop(iname)
loop_=.false.
loopct=0
loopnl=0
C
C....... Place data item into variable string and make number
C
550 type_=dtype(iname)
strg_(1:long_)=buffer(kchar:kchar+long_-1)
if(type_.eq.'numb') call ctonum
if(type_.eq.'text') strg_(1:1)=' '
if(long_.eq.1.and.strg_(1:1).eq.'?') type_='null'
C
1000 return
end
C
C
C
C
C
C
C
C >>>>>> Read the next string from the file
C
subroutine getstr
C
include 'ciftbx.sys'
integer i
character c*1,num*13,flag*4
data num/'0123456789+-.'/
C
100 jchar=jchar+1
if(jchar.le.80) goto 150
C
C....... Read a new line
C
110 call getlin(flag)
type_='fini'
if(flag.eq.'fini') goto 500
C
C....... Test if the new line is the start of a text sequence
C
if(buffer(1:1).ne.';') goto 150
type_='text'
jchar=81
long_=80
goto 500
C
C....... Process this character in the line
C
150 c=buffer(jchar:jchar)
if(c.eq.' ') goto 100
if(c.eq.tab) goto 100
if(c.eq.'#') goto 110
if(c.eq.'''') goto 300
if(c.eq.'"') goto 300
if(c.ne.'_') goto 200
type_='name'
goto 210
C
C....... Test if the start of a number or a character string
C
200 type_='numb'
if(index(num,c).eq.0) type_='char'
210 do 250 i=jchar,80
if(buffer(i:i).eq.' ') goto 400
if(buffer(i:i).eq.tab) goto 400
250 continue
i=81
goto 400
C
C....... Span quoted character string
C
300 type_='char'
jchar=jchar+1
do 320 i=jchar,80
if(buffer(i:i).eq.c) goto 400
320 continue
call err('Quoted string not closed')
C
C....... Store the string for the getter
C
400 long_=i-jchar
strg_(1:long_)=buffer(jchar:i-1)
jchar=i
Cdbg if(jchar.lt.0) write(6,'(" i ",i5)') jchar
if(type_.ne.'char') goto 500
if(strg_(1:5).eq.'data_') type_='data'
if(strg_(1:5).eq.'loop_') type_='loop'
C
500 return
end
C
C
C
C
C
C
C >>>>>> Convert a character string into a number and its esd
C
C number string -xxxx.xxxx+xxx(x)
C component count CCNT 11111222223333444
C
subroutine ctonum
C
include 'ciftbx.sys'
character test*15,c*1
integer*4 m,nchar
integer*4 ccnt,mant,expn,msin,esin,ndec
real numb,sdev
data test /'0123456789+.-()'/
C
numbtb=0.
sdevtb=-1.
numb=1.
sdev=0.
ccnt=0
mant=0
expn=0.
msin=+1
esin=+1
ndec=0
type_='char'
C
C....... Loop over the string and identify components
C
do 400 nchar=1,long_
C
c=strg_(nchar:nchar)
m=index(test,c)
if(m.eq.0) goto 500
if(m.gt.10) goto 300
C
C....... Process the digits
C
if(ccnt.eq.0) ccnt=1
if(ccnt.eq.2) ndec=ndec+1
if(ccnt.gt.2) goto 220
mant=mant*10+m-1
goto 400
220 if(ccnt.gt.3) goto 240
expn=expn*10+m-1
goto 400
240 sdev=sdev*10.+float(m-1)
sdevtb=1.
goto 400
C
C....... Process the characters . + - ( ) E D
C
300 if(c.ne.'.') goto 320
if(ccnt.gt.1) goto 500
ccnt=2
goto 400
C
320 if(c.ne.'(') goto 340
ccnt=4
goto 400
C
340 if(c.eq.'E') m=10
if(c.eq.'D') m=10
if(ccnt.eq.3) goto 500
if(ccnt.gt.0) goto 360
ccnt=1
msin=12-m
goto 400
360 ccnt=3
esin=12-m
C
400 continue
C
C....... String parsed; construct the numbers
C
expn=expn*esin-ndec
if(abs(expn).gt.21) expn=sign(21,expn)
if(expn.lt.0) numb=1./10.**abs(expn)
if(expn.gt.0) numb=10.**expn
if(sdevtb.gt.0.0) sdevtb=numb*sdev
numbtb=numb*float(mant*msin)
type_='numb'
C
500 return
end
C
C
C
C
C
C
C >>>>>> Read a new line from the direct access file
C
subroutine getlin(flag)
C
include 'ciftbx.sys'
character flag*4
C
irecd=irecd+1
if(irecd.eq.jrecd) goto 200
if(irecd.le.lrecd) goto 100
flag='fini'
goto 200
100 read(dirdev,'(a)',rec=irecd) buffer
jchar=1
jrecd=irecd
flag=' '
200 return
end
C
C
C
C
C
C
C >>>>>> Write error message and exit.
C
subroutine err(mess)
C
include 'ciftbx.sys'
character mess*(*)
C
write(errdev,'(5a,i5)') ' ciftbx error in ',
* file_(1:longf_),' data_',bloc_,' line',irecd
write(errdev,'(1X,a)') mess
stop
end
C
C
C
C
C >>>>>> Create a named file.
C
function pfile_(fname)
C
include 'ciftbx.sys'
logical pfile_,test
integer i
character fname*(*)
C
C....... Test if a file by this name is already open.
C
if(pfilef.eq.'yes') call close_
pfilef='no '
file_=fname
do 120 i=1,80
if(file_(i:i).eq.' ') goto 140
120 continue
140 inquire(file=file_(1:i-1),exist=test)
pfile_=.false.
if(test) goto 200
C
C....... Open up a new CIF
C
open(unit=outdev,file=fname,status='NEW',access='SEQUENTIAL',
* form='FORMATTED')
pfile_=.true.
pfilef='yes'
nbloc=0
200 return
end
C
C
C
C
C
C >>>>>> Store a data block command in the CIF
C
function pdata_(name)
C
include 'ciftbx.sys'
logical pdata_
character name*(*),temp*32
character dbloc(100)*32
integer i
C
if(ploopn.gt.0) call eoloop
if(ptextf.eq.'yes') call eotext
C
C....... Check for duplicate data name
C
temp=name
pdata_=.false.
do 120 i=1,nbloc
if(temp.eq.dbloc(i)) goto 200
120 continue
C
C....... Save block name and put data_ statement
C
nbloc=nbloc+1
if(nbloc.le.100) dbloc(nbloc)=temp
pchar=81
temp='data_'//name
call putstr(temp)
pchar=81
call putstr(' ')
pdata_=.true.
C
200 return
end
C
C
C
C
C
C
C >>>>>> Put a number into the CIF, perhaps with an esd appended
C
function pnumb_(name,numb,sdev)
C
include 'ciftbx.sys'
logical pnumb_,flag
character name*(*),temp*32
real numb,sdev
C
pnumb_=.true.
flag =.true.
temp=name
if(ptextf.eq.'yes') call eotext
C
if(name(1:1).eq.' ') goto 120
if(vcheck.eq.'no ') goto 100
call dcheck(temp,'numb',flag)
pnumb_=flag
100 if(ploopn.gt.0) call eoloop
pchar=81
call putstr(temp)
pchar=35
C
120 ploopf='no '
call putnum(numb,sdev)
if(flag) goto 150
pchar=60
call putstr('#< not in dictionary')
C
150 return
end
C
C
C
C
C
C
C >>>>>> Put a character string into the CIF.
C
function pchar_(name,string)
C
include 'ciftbx.sys'
logical pchar_,flag
character name*(*),temp*32,string*(*)
character line*80,strg*80
integer i,j
C
pchar_=.true.
flag =.true.
temp=name
if(ptextf.eq.'yes') call eotext
C
if(name(1:1).eq.' ') goto 110
if(vcheck.eq.'no ') goto 100
call dcheck(temp,'numb',flag)
pchar_=flag
100 if(ploopn.gt.0) call eoloop
pchar=81
call putstr(temp)
pchar=35
C
110 ploopf='no '
line=string
do 120 i=80,2,-1
if(line(i:i).ne.' ') goto 130
120 continue
130 do 140 j=i,1,-1
if(line(j:j).eq.' ') goto 150
140 continue
strg=line(1:i)
goto 200
150 do 160 j=1,i
if(line(j:j).eq.'''')goto 170
160 continue
strg=''''//line(1:i)//''''
goto 200
170 strg='"'//line(1:i)//'"'
C
200 call putstr(strg)
if(flag) goto 250
pchar=60
call putstr('#< not in dictionary')
250 return
end
C
C
C
C
C
C
C >>>>>> Put a text sequence into the CIF.
C
function ptext_(name,string)
C
include 'ciftbx.sys'
logical ptext_,flag
character name*(*),temp*32,string*(*),store*32
data store/' '/
C
ptext_=.true.
flag =.true.
ploopf='no '
temp=name
if(ptextf.eq.'no ') goto 100
if(temp.eq.store) goto 150
call eotext
C
100 if(name(1:1).ne.' ') goto 110
if(ptextf.eq.'yes') goto 150
goto 130
C
110 if(ploopn.gt.0) call eoloop
if(vcheck.eq.'no ') goto 120
call dcheck(name,'char',flag)
ptext_=flag
120 pchar=81
call putstr(temp)
if(flag) goto 130
pchar=60
call putstr('#< not in dictionary')
130 pchar=81
call putstr(' ')
ptextf='yes'
store=temp
write(outdev,'(a)') ';'
150 write(outdev,'(a)') string
return
end
C
C
C
C
C
C
C >>>>>> Put a loop_ data name into the CIF.
C
function ploop_(name)
C
include 'ciftbx.sys'
logical ploop_,flag
character name*(*),temp*32
C
ploop_=.true.
flag =.true.
if(ptextf.eq.'yes') call eotext
if(name(1:1).eq.' ') goto 150
C
temp=' '//name
if(ploopf.eq.'no ') call eoloop
if(vcheck.eq.'no ') goto 100
call dcheck(name,' ',flag)
ploop_=flag
100 if(ploopn.gt.0) goto 120
ploopf='yes'
pchar=81
call putstr(' ')
pchar=81
call putstr('loop_')
pchar=81
120 call putstr(temp)
if(flag) goto 130
pchar=60
call putstr('#< not in dictionary')
130 pchar=81
ploopn=ploopn+1
C
150 return
end
C
C
C
C
C
C
C >>>>>> Close the CIF
C
subroutine close_
C
include 'ciftbx.sys'
C
if(ptextf.eq.'yes') call eotext
if(ploopn.gt.0) call eoloop
pchar=81
call putstr(' ')
close(outdev)
return
end
C
C
C
C
C
C >>>>>> Put the string into the output CIF buffer
C
subroutine putstr(string)
C
include 'ciftbx.sys'
SAVE
character string*(*),temp*80,obuf*80
integer ichar,i
data ichar /0/
C
temp=string
do 100 i=80,1,-1
if(temp(i:i).ne.' ') goto 110
100 continue
C
C....... Organise the output of loop_ items
C
110 if(i.eq.0) goto 130
if(ploopf.eq.'yes') goto 130
if(ploopn.eq.0) goto 130
ploopc=ploopc+1
if(ploopc.le.ploopn) goto 130
ploopc=1
if(.not.align_) goto 130
pchar=81
C
C....... Is the buffer full and needs flushing?
C
130 if(pchar.lt.ichar) goto 140
if(pchar+i.le.80) goto 150
pchar=1
140 if(ichar.gt.0) write(outdev,'(a)') obuf(1:ichar)
obuf=' '
C
C....... Load the next item into the buffer
C
150 ichar=pchar+i
if(i.eq.0) goto 200
obuf(pchar:ichar)=string(1:i)
pchar=ichar+1
C
200 return
end
C
C
C
C
C
C >>>>>> Convert the number and esd to string nnnn(m)
C
subroutine putnum(numb,sdev)
C
include 'ciftbx.sys'
character string*60,digit*9,temp*20
real numb,sdev
integer i,j
data digit /'123456789'/
C
write(string,'(2f30.10)') numb,sdev
do 120 i=1,30
if(string(i:i).ne.' ') goto 140
120 continue
140 if(sdev.lt.0.0000001) goto 240
C
C....... Numbers with standard deviations
C
do 160 j=31,60
if(index(digit,string(j:j)).gt.0) goto 200
160 continue
200 if(j.lt.50) goto 220
temp=string(i:j-30)//'('//string(j:j)//')'
goto 300
220 temp=string(i:19)//'('//string(j:49)//')'
goto 300
C
C....... Numbers without standard deviations
C
240 do 250 j=21,30
if(string(j:j).ne.'0') goto 260
250 continue
260 if(j.gt.26) goto 280
temp=string(i:26)
goto 300
280 temp=string(i:19)
C
300 call putstr(temp)
return
end
C
C
C
C
C
C >>>>>> Check dictionary for data name validation
C
subroutine dcheck(name,type,flag)
C
include 'ciftbx.sys'
logical flag
character name*(*),temp*32,type*4
integer i
C
flag=.true.
temp=name
do 100 i=1,ndict
if(temp.ne.dicnam(i)) goto 100
if(tcheck.eq.'no ') goto 200
if(type.eq.dictyp(i)) goto 200
goto 150
100 continue
150 flag=.false.
200 continue
return
end
C
C
C
C
C
C >>>>>> End of text string
C
subroutine eotext
C
include 'ciftbx.sys'
C
ptextf='no '
call putstr(';')
pchar=80
return
end
C
C
C
C
C
C >>>>>> End of loop detected; check integrity and tidy up pointers
C
subroutine eoloop
C
include 'ciftbx.sys'
integer i
C
if(ploopn.eq.0) goto 200
if(ploopn.eq.ploopc) goto 200
do 150 i=1,ploopc
150 call putstr('DUMMY')
write(errdev,'(a)')
* ' Missing: missing loop_ items set as DUMMY'
C
200 ploopc=0
ploopn=0
return
end
C
C
C
C
C
C
C >>>>>> Set common default values
C
block data
C
include 'ciftbx.sys'
data cifdev /1/
data outdev /2/
data dirdev /3/
data errdev /6/
data loopct /0/
data nhash /0/
data ndict /0/
data nname /0/
data nbloc /0/
data ploopn /0/
data ploopc /0/
data ploopf /'no '/
data ptextf /'no '/
data pfilef /'no '/
data testfl /'no '/
data vcheck /'no '/
data tcheck /'no '/
data align_ /.true./
data text_ /.false./
data loop_ /.false./
end
C
C
C--------cut here------------------------------------------------------------
C
C
C >>>>>> Common declararations 'ciftbx.sys'
C
C For inclusion in 'ciftbx.f'
C
C
C Flag if test_ last called (yes/no )
character testfl*3
C Name of current data item
character nametb*32
C Tab character for this machine
character tab*1
C Character buffer for reading lines
character buffer*80
C Dictionary validation check
character vcheck*3
C Dictionary data type check
character tcheck*3
C Dictionary being processed flag
character dictfl*3
C Dictionary data names
character dicnam(1000)*32
C Dictionary data types
character dictyp(1000)*4
C Data names in data block
character dname(500)*32
C Data type of data item
character dtype(500)*4
C Flag signalling output CIF open
character pfilef*3
C Flag signalling loop_ being loaded
character ploopf*3
C Flag signalling text being loaded
character ptextf*3
C Record number containing data item
integer drecd(500)
C Character position of item in record
integer dchar(500)
C Loop block number (0 for non-loop)
integer nloop(500)
C Item count in loop packet
integer iloop(500)
C Loop line counter; initially zero
integer lloop(500)
C Number of items per packet in each loop
integer loopni(50)
C Number of packets per loop
integer loopnp(50)
C Number of of items in current loop packet
integer ploopc
C Number of of items in output loop packet
integer ploopn
C Number of current loop block
integer loopnl
C Count of packets in current loop
integer loopct
C Number of data names in hash table
integer nhash
C Number of data names in data block
integer nname
C Current number of data name in block
integer iname
C Number of dictionary names
integer ndict
C Number of records in CIF
integer nrecd
C Record number of requested line
integer irecd
C Record number of current line
integer jrecd
C Last record number of current block
integer lrecd
C Character pointer of current input line
integer jchar
C Character pointer of output CIF line
integer pchar
C Number of data block names stored
integer nbloc
C Device number of input CIF
integer cifdev
C Device number of direct access file
integer dirdev
C Device number of error message file
integer errdev
C Device number of output CIF
integer outdev
C Returned number
real numbtb
C Returned standard deviation
real sdevtb
C
common/tbxc/ buffer,dname,dtype,tab,dicnam,dictyp,dictfl,
* nametb,testfl,vcheck,tcheck,
* pfilef,ploopf,ptextf
C
common/tbxi/ nrecd,drecd,irecd,lrecd,dchar,ndict,outdev,
* nloop,iloop,lloop,loopct,loopni,loopnp,loopnl,
* nname,nhash,cifdev,dirdev,errdev,jchar,pchar,
* iname,ploopn,ploopc,nbloc,jrecd
C
common/tbxr/ numbtb,sdevtb
C
C
C
C Align loop active flag (true/false)
logical align_
C Text active flag (true/false)
logical text_
C Loop active flag (true/false)
logical loop_
C Length of current data item in strg_
integer long_
C Loop block number of current item
integer list_
C Length of current filename in file_
integer longf_
C Name of current data block
character bloc_*32
C Character image of current data item
character strg_*80
C File name of current CIF
character file_*80
C Data item type
character type_*4
C
common/tbuc/ strg_,bloc_,file_,type_
C
common/tbui/ list_,long_,longf_
C
common/tbul/ loop_,text_,align_
C
C
C--------cut here------------------------------------------------------------
C
C
C >>>>>> Common declararations 'ciftbx.cmn'
C
C For inclusion in user applications
C
C
C Logical function init_
logical init_
C Logical function dict_
logical dict_
C Logical function open_
logical open_
C Logical function data_
logical data_
C Logical function test_
logical test_
C Logical function name_
logical name_
C Logical function numb_
logical numb_
C Logical function char_
logical char_
C Logical function pfile_
logical pfile_
C Logical function pdata_
logical pdata_
C Logical function pchar_
logical pchar_
C Logical function pnumb_
logical pnumb_
C Logical function ptext_
logical ptext_
C Logical function ploop_
logical ploop_
C Align loop active flag (true/false)
logical align_
C Text active flag (true/false)
logical text_
C Loop active flag (true/false)
logical loop_
C Length of current data item in strg_
integer long_
C Loop block number of current item
integer list_
C Length of current filename in file_
integer longf_
C Name of current data block
character bloc_*32
C Character image of current data item
character strg_*80
C File name of current CIF
character file_*80
C Data item type
character type_*4
C
common/tbuc/ strg_,bloc_,file_,type_
C
common/tbui/ list_,long_,longf_
C
common/tbul/ loop_,text_,align_
C
C
C--------cut here-------------------------------------------------------------
C
C
C
C CIF Tool Box Application 'tbx_ex.f'
C ------------------------
C Version: July 17 1994
C
C
C This file contains four separate examples of how to apply the
C the CIF tool box 'CIFtbx'. These are simple software tools for
C accessing and creating data in CIF format. A description of the
C CIFtbx functions and user-accessible system variables is given
C at the start of the tool box source file 'ciftbx.f'.
C
C A full description of a CIF is given in the paper Hall, Allen
C and Brown (1991) Acta Cryst. A47 pp655-685.
C
C Communications about the application of the CIF tool box may be
C directed to: Syd Hall fx:61(9)3801118 em:syd@crystal.uwa.edu.au
C
C The examples shown below extract data from the supplied CIF
C 'test.cif'. The third example reads a list of data requests from
C a supplied file 'test.req'. As distributed, 'tbx_ex.f' attaches
C 'test.cif' to device 1, a scratch direct access file to device 3
C and the error message file to device 6 (i.e. stdout). The fourth
C example creates a new CIF called 'test.new'. This output file is
C attached to device 2. On some machines these may not be suitable
C device numbers and they may be changed within the application
C with the init_ call.
C
C The print file for this application is assumed to be stdout (i.e.
C device number 6). The dictionary checking option dict_ has been
C invoked in these examples. In this case the standard Core
C dictionary file 'cifdic.c91' has been used [note that other
C dictionaries may be added by repetitive invocation of dict_]. If
C it is not present a warning message will be issued and the run
C will proceed without data name validation.
C
C
C The user should note that most CIFtbx tools are logical functions.
C If their invocation succeeds they are returned with value .true.
C otherwise .false. This means that for each invocation the program
C can take appropriate action. For example if a request to open_ a
C specific CIF fails, the program can exit, or try another CIF. The
C same philosophy applies to data_ and all CIFtbx functions. However,
C if a function discovers a logical construction error in the CIF,
C the whole process will stop with an error message.
C
C
C
C Note the following requirements for any CIFtbx application.
C
C....... The tool box fortran source file 'ciftbx.f' must be included
C once in the application source (as shown below), OR the object
C file 'ciftbx.o' must be included in the link process.
C
include 'ciftbx.f'
C
C
C....... The tool box common variable file 'ciftbx.cmn' must be present
C at the start of EACH routine using the CIFtbx functions.
C
include 'ciftbx.cmn'
C
C
C
logical f1,f2,f3
character*32 name
character*80 line
character*4 label(6)
character*26 alpha
real cela,celb,celc,siga,sigb,sigc
real x,y,z,u,sx,sy,sz,su
real numb,sdev,dum
real xf(6),yf(6),zf(6),uij(6,6)
integer i,j,nsite
data alpha /'abcdefghijklmnopqrstuvwxyz'/
data cela,celb,celc,siga,sigb,sigc/6*0./
data x,y,z,u,sx,sy,sz,su/8*0./
data xf,yf,zf,uij/54*0./
C
C
C
C........................... Example 1 .......................................
C
C
C This example illustrates how to extract non-loop and loop items.
C Note carefully how the logical functions numb_ and char_ signal if
C the request has been successful or not. Note how the logical variables
C text_ and loop_ are used to control the text lines and the data loops.
C
C
C
C....... Assign the CIFtbx files
C
f1 = init_( 1, 2, 3, 6 )
C
C....... Request dictionary validation check
C
if(dict_('cifdic.c91','valid')) goto 100
write(6,'(/a/)') ' Requested Core dictionary not present'
C
C....... Open the CIF to be accessed
C
100 name='test.cif'
write(6,'(/2a/)') ' Read data from CIF ',name
if(open_(name)) goto 120
write(6,'(a///)') ' >>>>>>>>> CIF cannot be opened'
stop
C
C....... Assign the data block to be accessed
C
120 if(data_(' ')) goto 130
write(6,'(/a/)') ' >>>>>>> No data_ statement found'
stop
130 write(6,'(/a,a/)') ' Access items in data block ',bloc_
C
C
C....... Extract some cell dimensions; test all is OK
C
f1 = numb_('_cell_length_a', cela, siga)
f2 = numb_('_cell_length_b', celb, sigb)
f3 = numb_('_cell_length_c', celc, sigc)
if(.not.(f1.and.f2.and.f3))
* write(6,'(a)') ' Cell dimension(s) missing!'
write(6,'(/a,3f10.4)') ' Cell ',cela,celb,celc
write(6,'(a,3f10.4/)') ' ',siga,sigb,sigc
C
C
C....... Extract space group notation (expected char string)
C
f1 = char_('_symmetry_space_group_name_Hall', name)
write(6,'(a,a/)') ' Space group ',name(1:long_)
C
C
C....... Get the next name in the CIF and print it out
C
f1 = name_(name)
write(6,'(a,a/)') ' Next data name in CIF is ',name
C
C
C....... List the audit record (possible text line sequence)
C
write(6,'(a/)') ' Audit record'
140 f1 = char_('_audit_update_record', line)
write(6,'(a)') line
if(text_) goto 140
C
C
C....... Extract atom site data in a loop
C
write(6,'(/a/)') ' Atom sites'
160 f1 = char_('_atom_site_label', name)
f2 = numb_('_atom_site_fract_x', x, sx)
f2 = numb_('_atom_site_fract_y', y, sy)
f2 = numb_('_atom_site_fract_z', z, sz)
f3 = numb_('_atom_site_U_iso_or_equiv', u, su)
write(6,'(1x,a4,8f8.4)') name,x,y,z,u,sx,sy,sz,su
if(loop_) goto 160
C
C
C
C
C........................... Example 2 .......................................
C
C
C
C In this example two separate data blocks are accessed. The first
C contains looped publication authors and text addresses. The second
C part of this example shows how data from two different loops may
C be merged. Remember that data items from different loops may NOT
C be accessed simultaneously, as this causes the CIFtbx loop counters
C to be reset to the start of the loop (see Example 3).
C
C
C
C....... List the author addresses from publication data block
C
if(data_('publication'))
* write(6,'(//a,a/)') ' Access items in data block ',bloc_
write(6,'(/a)') ' Author list'
C
210 f1 = char_('_publ_author_name', line)
write(6,'(/1x,a)') line(1:long_)
C
220 f1 = char_('_publ_author_address', line)
if(line(1:10).eq.' ') goto 230
write(6,'(1x,a)') line(1:50)
230 if(text_) goto 220
if(loop_) goto 210
C
C
C....... Read and store the atom site data from other data block
C
f1 = data_('mumbo_jumbo')
write(6,'(///a,a/)') ' Access items in data block ',bloc_
C
nsite = 0
240 nsite = nsite+1
f1 = char_('_atom_site_label', label(nsite))
f2 = numb_('_atom_site_fract_x', xf(nsite), sx)
f2 = numb_('_atom_site_fract_y', yf(nsite), sy)
f2 = numb_('_atom_site_fract_z', zf(nsite), sz)
do 250 i=1,6
250 uij(nsite,i)=0.0
if(loop_) goto 240
C
C....... Read the Uij loop and store in the site list
C
260 f1 = char_('_atom_site_aniso_label', name)
do 270 i=1,nsite
if(label(i).eq.name) goto 280
270 continue
write(6,'(a)') ' Label mismatch between atom lists'
280 f1 = numb_('_atom_site_aniso_U_11', uij(i,1), dum)
f1 = numb_('_atom_site_aniso_U_22', uij(i,2), dum)
f1 = numb_('_atom_site_aniso_U_33', uij(i,3), dum)
f1 = numb_('_atom_site_aniso_U_12', uij(i,4), dum)
f1 = numb_('_atom_site_aniso_U_13', uij(i,5), dum)
f1 = numb_('_atom_site_aniso_U_23', uij(i,6), dum)
if(loop_) goto 260
C
C....... List the atom site data
C
write(6,'(/a/)') ' Atom coordinates and Uij'
do 290 i=1,nsite
if(uij(i,1).gt.0.0001) goto 285
write(6,'(1x,a,3f8.4)') label(i),xf(i),yf(i),zf(i)
goto 290
285 write(6,'(1x,a,9f8.4)') label(i),xf(i),yf(i),zf(i),
* (uij(i,j),j=1,6)
290 continue
C
C
C
C
C........................... Example 3 .......................................
C
C
C This example serves to illustrate how a general list of data requests
C may be handled. The logical function test_ is used to identify the
C nature of the requested data item, and then numb_ and char_ are invoked
C when applicable. The supplied list of requests on 'test.req' is not of
C particular significance. They are intentionally jumbled up to show what
C happens if a non-loop item is called within a loop [WARNING: CIFtbx
C interprets this as a signal to end the loop and the next call for a loop
C item will extract data from its first packet! Look at the output listing
C to see what happens.]
C
C
C
C....... Loop over the data request file
C
open(unit=8,file='test.req',status='old')
300 read(8,'(a)',end=400) name
C
f1 = test_(name)
write(6,'(/a,3x,a,2i5)') name,type_,long_,list_
C
if(type_.ne.'numb') goto 320
f1 = numb_(name, numb, sdev)
write(6,'(2f10.4)') numb,sdev
goto 300
C
320 if(type_.ne.'char') goto 340
f1 = char_(name, line)
write(6,'(a)') line(1:long_)
goto 300
C
340 if(type_.ne.'text') goto 300
350 f1 = char_(name, line)
write(6,'(a)') line
if(text_) goto 350
goto 300
C
C
C
C
C........................... Example 4 .......................................
C
C
C
C In this example a new CIF is created. Note that it will not overwrite
C an existing CIF of the same name. Note also that reading and existing
C CIF and writing a new CIF is possible at the same time, so that it is
C feasible to use these tools to update or modify and existing CIF.
C
C
C
C....... Open a new CIF
C
400 if(pfile_('test.new')) goto 450
write(6,'(//a/)') ' Output CIF by this name exists already!'
goto 500
C
C....... Insert a data block code
C
450 f1 = pdata_('whoops_a_daisy')
C
C....... Enter various single data items to show how
C
f1 = pchar_('_audit_creation_method','using CIFtbx')
f1 = pchar_('_audit_creation_extra1','using_CIFtbx')
f1 = pchar_('_audit_creation_extra2',"Terry O'Connell")
f1 = pchar_('_audit_creation_extra3','Terry O"Connell')
C
f1 = ptext_('_audit_creation_record',' Text data may be ')
f1 = ptext_('_audit_creation_record',' entered like this')
f1 = ptext_('_audit_creation_record',' or in a loop.')
C
f1 = pnumb_('_cell_measurement_temperature', 293., 0.)
f1 = pnumb_('_cell_volume', 1759.0, 13.)
f1 = pnumb_('_cell_length_junk', 8.75353553524313,0.)
f1 = pnumb_('_cell_length_c', 19.737, .003)
C
C....... Enter some looped data
C
f1 = ploop_('_atom_type_symbol')
f1 = ploop_('_atom_type_oxidation_number')
f1 = ploop_('_atom_type_number_in_cell')
do 470 i=1,10
f1 = pchar_(' ',alpha(1:i))
f1 = pnumb_(' ',float(i),float(i)*0.1)
470 f1 = pnumb_(' ',float(i)*8.64523,0.)
C
C....... Do it again but as contiguous data with text data
C
f1 = ploop_('_atom_type_symbol')
f1 = ploop_('_atom_type_oxidation_number')
f1 = ploop_('_some_silly_text')
do 480 i=1,3
f1 = pchar_(' ',alpha(1:i))
f1 = pnumb_(' ',float(i),float(i)*0.1)
480 f1 = ptext_(' ',' Hi Ho the diddly oh!')
C
500 call close_
stop
end
C
C
C--------cut here------------------------------------------------------------
C
data_mumbo_jumbo
_audit_creation_date 91-03-20
_audit_creation_method from_xtal_archive_file_using_CIFIO
_audit_update_record
; 91-04-09 text and data added by Tony Willis.
91-04-15 rec'd by co-editor with diagram as manuscript HL7.
91-04-17 adjustments based on first referees report.
91-04-18 adjustments based on second referee's report.
;
_chemical_name_systematic
trans-3-Benzoyl-2-(tert-butyl)-4-(iso-butyl)-1,3-oxazolidin-5-one
_chemical_formula_moiety 'C18 H25 N O3'
_chemical_formula_sum 'C18 H25 N O3'
_chemical_formula_weight 303.40
_chemical_melting_point ?
####_cell_length_a 5.959(1)
_cell_length_b 14.956(1)
_cell_length_c 19.737(3)
_cell_angle_alpha 90
_cell_angle_beta 90
_cell_angle_gamma 90
_cell_volume 1759.0(3)
_cell_formula_units_Z 4
_cell_measurement_temperature 293
_cell_measurement_reflns_used 25
_cell_measurement_theta_min 25
_cell_measurement_theta_max 31
_symmetry_cell_setting orthorhombic
_symmetry_space_group_name_H-M 'P 21 21 21'
_symmetry_space_group_name_Hall P_2ac_2ab
loop_
_atom_type_symbol
_atom_type_oxidation_number
_atom_type_number_in_cell
_atom_type_scat_dispersion_REAL #<< capitals to test case insensitivity
_atom_type_scat_dispersion_imag
_atom_type_scat_source
S 0 6 .319 .557 Int_Tab_Vol_III_p202_Tab._3.3.1a
O 0 6 .047 .032 Cromer,D.T._&_Mann,J.B._1968_AC_A24,321.
C 0 20 .017 .009 Cromer,D.T._&_Mann,J.B._1968_AC_A24,321.
RU 0 1 -.105 3.296 Cromer,D.T._&_Mann,J.B._1968_AC_A24,321.
loop_
_atom_site_label
_atom_site_fract_x
_atom_site_fract_y
_atom_site_fract_z
_atom_site_U_iso_or_equiv
_atom_site_thermal_displace_type
_atom_site_calc_flag
_atom_site_calc_attached_atom
_atom_site_type_symbol
s .20200 .79800 .91667 .030(3) Uij ? ? s
o .49800 .49800 .66667 .02520 Uiso ? ? o
c1 .48800 .09600 .03800 .03170 Uiso ? ? c
loop_
_atom_site_aniso_label
_atom_site_aniso_U_11
_atom_site_aniso_U_22
_atom_site_aniso_U_33
_atom_site_aniso_U_12
_atom_site_aniso_U_13
_atom_site_aniso_U_23
_atom_site_aniso_type_symbol
s .035(4) .025(3) .025(3) .013(1) .00000 .00000 s
loop_ _blat1 _blat2 1 2 3 4 5 6 a b c d 7 8 9 0
data_publication
loop_
_publ_author_name #ActaC
_publ_author_address #ActaC
'Furber, Mark'
;
Research School of Chemistry
Australian National University
GPO Box 4
Canberra, A.C.T.
Australia 2601
;
'Mander, Lewis N.'
;
Research School of Chemistry
Australian National University
GPO Box 4
Canberra, A.C.T.
Australia 2601
;
'Patrick, Graham L.'
;
Research School of Chemistry
Australian National University
GPO Box 4
Canberra, A.C.T.
Australia 2601
;
'Willis, Anthony C.'
;
Research School of Chemistry
Australian National University
GPO Box 4
Canberra, A.C.T.
Australia 2601
;
#----------------------------cut here-------------------------------------------
_audit_creation_date
_audit_creation_method
_audit_update_record
_chemical_name_systematic
_chemical_formula_moiety
_chemical_formula_sum
_chemical_formula_weight
_chemical_melting_point
_cell_length_a
_cell_length_b
_cell_length_c
_cell_angle_alpha
_cell_angle_beta
_cell_angle_gamma
_cell_volume
_cell_formula_units_Z
_cell_measurement_temperature
_cell_measurement_reflns_used
_cell_measurement_theta_min
_cell_measurement_theta_max
_blat2
_blat1
_blat2
_blat1
_blat2
_blat1
_blat2
_blat1
_blat2
_blat1
_symmetry_cell_setting
_symmetry_space_group_name_H-M
_symmetry_space_group_name_Hall
_atom_type_symbol
_atom_type_oxidation_number
_atom_type_number_in_cell
_atom_type_scat_dispersion_real
_atom_type_scat_dispersion_imag
_atom_type_scat_source
_atom_type_symbol
_atom_type_oxidation_number
_atom_type_number_in_cell
_atom_type_number_in_cell
_atom_type_oxidation_number
_atom_type_scat_dispersion_real
_atom_site_label
_atom_site_fract_x
_atom_site_fract_y
_atom_site_fract_z
_atom_site_U_iso_or_equiv
_atom_site_thermal_displace_type
_atom_site_calc_flag
_atom_site_calc_attached_atom
_atom_site_type_symbol
_atom_site_type_symbol
_atom_site_type_symbol
_atom_site_type_symbol
_rubish_here
_atom_site_type_symbol
_atom_site_type_symbol
_atom_site_type_symbol
_symmetry_space_group_name_Hall
_atom_site_type_symbol
_atom_site_type_symbol
_atom_site_type_symbol
_atom_site_type_symbol
_atom_site_aniso_label
_atom_site_aniso_U_11
_atom_site_aniso_U_22
_atom_site_aniso_U_33
_atom_site_aniso_U_12
_atom_site_aniso_U_13
_atom_site_aniso_U_23
_atom_site_aniso_type_symbol
_atom_site_aniso_U_12
_atom_site_aniso_U_12
_atom_site_aniso_U_12
#----------------------------cut here-------------------------------------------
Read data from CIF test.cif
Warning: data name _blat1 not in dictionary!
Warning: data name _blat2 not in dictionary!
Access items in data block mumbo_jumbo
Cell dimension(s) missing!
Cell 0.0000 14.9560 19.7370
0.0000 0.0010 0.0030
Space group P_2ac_2ab
Next data name in CIF is _atom_type_symbol
Audit record
91-04-09 text and data added by Tony Willis.
91-04-15 rec'd by co-editor with diagram as manuscript HL7.
91-04-17 adjustments based on first referees report.
91-04-18 adjustments based on second referee's report.
Atom sites
s 0.2020 0.7980 0.9167 0.0300 0.0000 0.0000 0.0000 0.0030
o 0.4980 0.4980 0.6667 0.0252 0.0000 0.0000 0.0000 0.0030
c1 0.4880 0.0960 0.0380 0.0317 0.0000 0.0000 0.0000 0.0030
Access items in data block publication
Author list
Furber, Mark
Research School of Chemistry
Australian National University
GPO Box 4
Canberra, A.C.T.
Australia 2601
Mander, Lewis N.
Research School of Chemistry
Australian National University
GPO Box 4
Canberra, A.C.T.
Australia 2601
Patrick, Graham L.
Research School of Chemistry
Australian National University
GPO Box 4
Canberra, A.C.T.
Australia 2601
Willis, Anthony C.
Research School of Chemistry
Australian National University
GPO Box 4
Canberra, A.C.T.
Australia 2601
Warning: data name _blat1 not in dictionary!
Warning: data name _blat2 not in dictionary!
Access items in data block mumbo_jumbo
Atom coordinates and Uij
s 0.2020 0.7980 0.9167 0.0350 0.0250 0.0250 0.0130 0.0000 0.0000
o 0.4980 0.4980 0.6667
c1 0.4880 0.0960 0.0380
_audit_creation_date char 8 0
91-03-20
_audit_creation_method char 34 0
from_xtal_archive_file_using_CIFIO
_audit_update_record text 80 0
91-04-09 text and data added by Tony Willis.
91-04-15 rec'd by co-editor with diagram as manuscript HL7.
91-04-17 adjustments based on first referees report.
91-04-18 adjustments based on second referee's report.
_chemical_name_systematic char 65 0
trans-3-Benzoyl-2-(tert-butyl)-4-(iso-butyl)-1,3-oxazolidin-5-one
_chemical_formula_moiety char 12 0
C18 H25 N O3
_chemical_formula_sum char 12 0
C18 H25 N O3
_chemical_formula_weight numb 6 0
303.4000 0.0000
_chemical_melting_point null 1 0
_cell_length_a null 1 0
_cell_length_b numb 9 0
14.9560 0.0010
_cell_length_c numb 9 0
19.7370 0.0030
_cell_angle_alpha numb 2 0
90.0000 0.0030
_cell_angle_beta numb 2 0
90.0000 0.0030
_cell_angle_gamma numb 2 0
90.0000 0.0030
_cell_volume numb 9 0
1759.0000 0.3000
_cell_formula_units_Z numb 1 0
4.0000 0.3000
_cell_measurement_temperature numb 3 0
293.0000 0.3000
_cell_measurement_reflns_used numb 2 0
25.0000 0.3000
_cell_measurement_theta_min numb 2 0
25.0000 0.3000
_cell_measurement_theta_max numb 2 0
31.0000 0.3000
null 1 0
_blat2 numb 1 4
2.0000 0.3000
_blat1 numb 1 4
1.0000 0.3000
_blat2 numb 1 4
4.0000 0.3000
_blat1 numb 1 4
3.0000 0.3000
_blat2 numb 1 4
6.0000 0.3000
_blat1 numb 1 4
5.0000 0.3000
_blat2 char 1 4
b
_blat1 char 1 4
a
_blat2 char 1 4
d
_blat1 char 1 4
c
null 1 4
_symmetry_cell_setting char 12 0
orthorhombic
_symmetry_space_group_name_H-M char 10 0
P 21 21 21
_symmetry_space_group_name_Hall char 9 0
P_2ac_2ab
null 1 0
_atom_type_symbol char 1 1
S
_atom_type_oxidation_number numb 1 1
0.0000 0.3000
_atom_type_number_in_cell numb 1 1
6.0000 0.3000
_atom_type_scat_dispersion_real numb 4 1
0.3190 0.3000
_atom_type_scat_dispersion_imag numb 4 1
0.5570 0.3000
_atom_type_scat_source char 32 1
Int_Tab_Vol_III_p202_Tab._3.3.1a
_atom_type_symbol char 1 1
O
_atom_type_oxidation_number numb 1 1
0.0000 0.3000
_atom_type_number_in_cell numb 1 1
6.0000 0.3000
_atom_type_number_in_cell numb 1 1
6.0000 0.3000
_atom_type_oxidation_number numb 1 1
0.0000 0.3000
_atom_type_scat_dispersion_real numb 4 1
0.0170 0.3000
null 1 1
null 1 1
_atom_site_label char 1 2
s
_atom_site_fract_x numb 6 2
0.2020 0.3000
_atom_site_fract_y numb 6 2
0.7980 0.3000
_atom_site_fract_z numb 6 2
0.9167 0.3000
_atom_site_U_iso_or_equiv numb 7 2
0.0300 0.0030
_atom_site_thermal_displace_type char 3 2
Uij
_atom_site_calc_flag null 1 2
_atom_site_calc_attached_atom null 1 2
_atom_site_type_symbol char 1 2
s
_atom_site_type_symbol char 1 2
s
_atom_site_type_symbol char 1 2
s
_atom_site_type_symbol char 1 2
s
_rubish_here null 1 2
_atom_site_type_symbol char 1 2
o
_atom_site_type_symbol char 1 2
o
_atom_site_type_symbol char 1 2
o
_symmetry_space_group_name_Hall char 9 0
P_2ac_2ab
_atom_site_type_symbol char 1 2
s
_atom_site_type_symbol char 1 2
s
_atom_site_type_symbol char 1 2
s
_atom_site_type_symbol char 1 2
s
null 1 2
_atom_site_aniso_label char 1 3
s
_atom_site_aniso_U_11 numb 7 3
0.0350 0.0040
_atom_site_aniso_U_22 numb 7 3
0.0250 0.0030
_atom_site_aniso_U_33 numb 7 3
0.0250 0.0030
_atom_site_aniso_U_12 numb 7 3
0.0130 0.0010
_atom_site_aniso_U_13 numb 6 3
0.0000 0.0010
_atom_site_aniso_U_23 numb 6 3
0.0000 0.0010
_atom_site_aniso_type_symbol char 1 3
s
_atom_site_aniso_U_12 numb 7 3
0.0130 0.0010
_atom_site_aniso_U_12 numb 7 3
0.0130 0.0010
_atom_site_aniso_U_12 numb 7 3
0.0130 0.0010
#------------------------------cut here---------------------------------------
data_whoops_a_daisy
_audit_creation_method 'using CIFtbx'
_audit_creation_extra1 using_CIFtbx #< not in dictionary
_audit_creation_extra2 "Terry O'Connell" #< not in dictionary
_audit_creation_extra3 'Terry O"Connell' #< not in dictionary
_audit_creation_record #< not in dictionary
;
Text data may be
entered like this
or in a loop.
;
_cell_measurement_temperature 293
_cell_volume 1759(13)
_cell_length_junk 8.753535 #< not in dictionary
_cell_length_c 19.736(3)
loop_
_atom_type_symbol
_atom_type_oxidation_number
_atom_type_number_in_cell
a 1.0(1) 8.645230
ab 2.0(2) 17.290460
abc 3.0(3) 25.935691
abcd 4.0(4) 34.580921
abcde 5.0(5) 43.226150
abcdef 6.0(6) 51.871383
abcdefg 7.0(6) 60.516613
abcdefgh 8.0(8) 69.161842
abcdefghi 9.0(9) 77.807075
abcdefghij 10(1) 86.452301
loop_
_atom_type_symbol
_atom_type_oxidation_number
_some_silly_text #< not in dictionary
a 1.0(1)
;
Hi Ho the diddly oh!
;
ab 2.0(2)
;
Hi Ho the diddly oh!
;
abc 3.0(3)
;
Hi Ho the diddly oh!
;
#------------------------------cut here---------------------------------------