source: trunk/import_cif.tcl @ 286

Last change on this file since 286 was 286, checked in by toby, 11 years ago

# on 2000/09/26 17:57:10, toby did:
change processing of ' & " for element symbol & element type
report error when a data name is used more than once in a block

  • Property rcs:author set to toby
  • Property rcs:date set to 2000/09/26 17:57:10
  • Property rcs:lines set to +27 -4
  • Property rcs:rev set to 1.3
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 18.5 KB
Line 
1# $Id: import_cif.tcl 286 2009-12-04 23:03:31Z toby $
2
3#-------------------------------------------------
4# define info used in addcmds.tcl
5set description "Crystallographic Information File (CIF)"
6set extensions .cif
7set procname ReadCIFFile
8#-------------------------------------------------
9
10proc ReadCIFFile {filename} {
11    global expgui
12    set fp [open $filename r]
13    pleasewait "Reading CIF file"         
14    set blocks [ParseCIF $filename]
15    if {$blocks == ""} {
16        donewait
17        MyMessageBox -parent . -type ok -icon warning \
18                -message "Note: no valid CIF blocks were read from file $filename"
19        return 
20    }
21    set allblocks {}
22    set coordblocks {}
23    # search each block for coordinate
24    for {set i 1} {$i <= $blocks} {incr i} {
25        lappend allblocks $i
26        global block$i
27        set flag 1
28        foreach id {_atom_site_fract_x _atom_site_fract_y _atom_site_fract_z} {
29            if {[array name block$i $id] == ""} {set flag 0}
30        }
31        if $flag {lappend coordblocks $i}
32    }
33    donewait
34    if {$coordblocks == ""} {
35        MyMessageBox -parent . -type ok -icon warning \
36                -message "Note: CIF $filename contains no coordinates"
37        return
38    }
39    set expgui(choose) [lindex $coordblocks 0]
40    # there is more than one appropriate block
41    if {[llength $coordblocks] > 1} {
42        catch {destroy .choose}
43        toplevel .choose
44        wm title .choose "Choose CIF Block"
45        grid [label .choose.0 -text \
46                "More than one block in CIF $filename\ncontains coordinates.\nSelect the block to use" \
47                ] -row 0 -column 0 -columnspan 2
48        set row 0
49        foreach i $coordblocks {
50            incr row
51            set name ""
52            catch {set name [set block${i}(data_)]}
53            grid [radiobutton .choose.$row -value $i \
54                    -text "block $i ($name)" -variable expgui(choose)] \
55                    -row $row -column 0 -sticky w
56        }
57        grid [button .choose.browse -text CIF\nBrowser -command \
58                "BrowseCIF [list $allblocks] [list $coordblocks] .choose.cif" \
59                ] -row 1 -rowspan $row -column 1 
60        grid [button .choose.ok -text OK -command "destroy .choose"] \
61                -row [incr row] -column 0 -columnspan 2
62        tkwait window .choose
63    }
64
65    set i $expgui(choose)
66    # get the space group
67    set spg {}
68    set msg {}
69    catch {
70        set spg [set block${i}(_symmetry_space_group_name_h-m)]
71        regsub -all {'} $spg {} spg
72        # see if this space group exists in the table
73        set fp [open [file join $expgui(scriptdir) spacegrp.ref] r]
74        while {[gets $fp line] >= 0} {
75            if {[string trim $spg] == [lindex $line 8]} {
76                close $fp
77                break
78                set fp {}
79            }
80        }       
81        if {$fp != ""} {
82            close $fp
83            set msg "Warning: the Space Group ($spg) may not be correctly specified for GSAS"
84        }
85    }
86    set cell {}
87    foreach var {_cell_length_a _cell_length_b _cell_length_c \
88            _cell_angle_alpha _cell_angle_beta _cell_angle_gamma} {
89        # leave blank any unspecified data items
90        set val {}
91        catch {set val [set block${i}($var)]}
92        lappend cell [lindex [ParseSU $val] 0]
93    }
94   
95    set atomlist {}
96    set lbllist {}
97    catch {
98        set lbllist [set block${i}(_atom_site_label)]
99    }
100    set uisolist {}
101    catch {
102        set uisolist [set block${i}(_atom_site_u_iso_or_equiv)]
103        set Uconv 1
104    }
105    if {$uisolist == ""} {
106        set uisolist [set block${i}(_atom_site_b_iso_or_equiv)]
107        set Uconv [expr 1/(8*3.14159*3.14159)]
108    }
109    set occlist {}
110    catch {
111        set occlist [set block${i}(_atom_site_occupancy)]
112    }
113    set typelist {}
114    catch {
115        set typelist [set block${i}(_atom_site_type_symbol)]
116    }
117    foreach x [set block${i}(_atom_site_fract_x)] \
118            y [set block${i}(_atom_site_fract_y)] \
119            z [set block${i}(_atom_site_fract_z)] \
120            lbl $lbllist uiso $uisolist occ $occlist type $typelist {
121        # should not be any quotes, but remove them, if there are
122        foreach var {lbl type} {
123            foreach char {' \"} {
124                set q {\\}
125                append q $char
126                set hidden [regsub -all $q [set $var] \200 $var]
127                if {[string index [set $var] 0] == $char} {
128                    regsub -all $char [set $var] {} $var
129                }
130                if {$hidden} {regsub -all \200 [set $var] $char $var}
131            }
132        }
133        # CIF specifies types as Cu2+; GSAS uses Cu+2
134        if {[regexp {([A-Za-z]+)([1-9])([+-])} $type junk elem sign val]} {
135            set type ${elem}${val}$sign
136        }
137        # if type is missing, attempt to parse an element in the label
138        if {$type == "" && $lbl != ""} {
139            regexp {[A-Za-z][A-Za-z]?} $lbl type
140        }
141        # get rid of standard uncertainies
142        foreach var {x y z occ uiso} {
143            catch {
144                set $var [lindex [ParseSU [set $var]] 0]
145            }
146        }
147        # convert Biso to Uiso (if needed)
148        if {$Uconv != 1} {
149            catch {set $uiso [expr $Uconv*$uiso]}
150        }
151        lappend atomlist [list $lbl $x $y $z $type $occ $uiso]
152    }
153
154    # clean up -- get rid of the CIF arrays
155    for {set i 1} {$i <= $blocks} {incr i} {
156        unset block$i
157    }
158    return "[list $spg] [list $cell] [list $atomlist] [list $msg]"
159}
160
161# ParseCIF reads and parses a CIF file putting the contents of
162# each block into arrays block1, block2,... in the caller's level
163#    the name of the block is saved as blockN(data_)
164# data names and items are saved as blockN(_data_name) = {data item}
165#    data items are not reformatted, thus quotes, semicolons & newlines
166#    are included in the data item string
167#    CIF names are converted to lower case
168# for looped data names, the data items are included in a list:
169#    blockN(_cif_name) = {item1 "item2 with spaces" item3 ...}
170# the contents of each loop are saved as blockN(loop_M)
171#
172# The proc returns the number of blocks that have been read or a
173#    null string if the file cannot be opened
174#
175# This parser does some error checking [errors are reported in blockN(error)]
176#    but the parser could get confused if the CIF has invalid syntax
177#
178proc ParseCIF {filename} {
179    if [catch {
180        set fp [open $filename r]
181    }] {return ""}
182
183    set blocks 0
184    set EOF 1
185    set line {}
186    set dataname {}
187    # line counter (for error messages)
188    set linenum 0
189    # this flags where we are w/r a loop_
190    #    -1 not in a loop
191    #     0 reading a loop header (data names)
192    #     1 reading the data items in a loop
193    set loopflag -1
194    set loopnum -1
195    # loop over tokens
196    while {$EOF} {
197        # read the next line, unless we have a holdover from the previous
198        if {[string length [string trim $line]] <= 0} {
199            incr linenum
200            if {[gets $fp line] < 0} {set EOF 0}
201        }
202        # flag if the string \' has been replaced
203        set hidden 0
204        set trimline [string trim $line]
205        set firstchar [string index $trimline 0]
206       
207        if {[string length $trimline] <= 0} {
208            # the line is blank
209            set line {}
210            continue
211        }
212       
213        if {$firstchar == "#"} {
214            # this is a comment
215            set line {}
216            continue
217        }
218       
219        if {[string tolower [string range $trimline 0 4]] == "data_"} {
220            # this is the beginning of a data block
221            incr blocks
222            # are there other tokens on this line?
223            if {[set pos [string first { } $trimline]] == -1} {
224                set blockname [string range $trimline 5 end]
225                set line {}
226            } else {
227                set blockname [string range $trimline 5 [expr $pos-1]]
228                set line [string range $trimline $pos end]
229            }
230            global block$blocks
231            catch {unset block$blocks}
232            set block${blocks}(data_) $blockname
233            set loopnum -1
234           
235            if {$line == ""} continue
236            if {$dataname != ""} {
237                # this is an error -- data_ block where a data item is expected
238                append block${blocks}(errors) "No data item was found for $dataname near line $linenum\n"
239                set dataname {}
240            }
241        }
242       
243        if {$firstchar == "_"} {
244            # this is a cif data name
245            if {$dataname != ""} {
246                # this is an error -- data name where a data item is expected
247                append block${blocks}(errors) "No data item was found for $dataname near line $linenum\n"
248            }
249            # parse it out & convert it to lower case
250            if {[set pos [string first { } $trimline]] == -1} {
251                # nothing else is on this line
252                set dataname [string tolower $trimline]
253                set line {}
254            } else {
255                # There other tokens on this line
256                set dataname [string range $trimline 0 [expr $pos-1]]
257                set line [string tolower [string range $trimline $pos end]]
258            }
259           
260            if {$loopflag == 0} {
261                # in a loop header, save the names in the loop list
262                lappend looplist $dataname
263                set block${blocks}(loop_${loopnum}) $looplist
264                # clear the array element for the data item
265                # -- should not be needed for a valid CIF but if a name is used
266                # -- twice in the same block, want to wipe out the 1st data
267                catch {
268                    if {[set block${blocks}($dataname)] != ""} {
269                        # this is an error -- repeated data name
270                        append block${blocks}(errors) \
271                                "Data item $dataname is repeated near line $linenum\n"
272                    }   
273                    set block${blocks}($dataname) {}
274                }
275                set dataname {}
276            } elseif {$loopflag > 0} {
277                # in a loop body, so the loop is over
278                set loopflag -1
279            }
280            continue
281        }
282       
283        if {[string tolower [string range $trimline 0 4]] == "loop_"} {
284            set loopflag 0
285            incr loopnum
286            set looplist {}
287            set block${blocks}(loop_${loopnum}) {}
288            # save any other tokens on this line
289            set line [string range $trimline 5 end]
290            continue
291        }
292
293        # keywords not matched, must be some type of data item
294        set item {}
295       
296        if {[string index $line 0] == ";"} {
297            # multiline entry with semicolon termination
298            set item $line
299            # read lines until we get a naked semicolon
300            while {$EOF} {
301                incr linenum
302                if {[gets $fp line] < 0} {set EOF 0}
303                if {[string index $line 0] == ";"} {
304                    append item "\n;"
305                    # make sure the line has a blank in front, so
306                    # a semicolon in col 2 is not treated as a quote character
307                    set line " [string range $line 1 end]"
308                    break
309                }
310            }
311            if {[string trim $line] == ""} {set line ""}
312        } elseif {$firstchar == {"}} {
313            # a quoted string
314            # hide any \" sequences in a non-ASCII character (\201)
315            set hidden [regsub -all {\\"} $trimline \201 trimline]
316            # parse out the quoted string, save the remainder
317            if {![regexp {("[^"]*")(.*)} $trimline junk item line]} {
318                # this is an error -- no end-quote was found
319                set item $line
320                set line {}
321                append block${blocks}(errors) "The quoted string on line $linenum does not have a close quote ([string trim $item])\n"
322            }
323        } elseif {$firstchar == {'}} {
324            # a quoted string
325            # hide any \' sequences in a non-ASCII character (\200)
326            set hidden [regsub -all {\\'} $trimline \200 trimline]
327            # parse out the quoted string, save the remainder
328            if {![regexp {('[^']*')(.*)} $trimline junk item line]} {
329                # this is an error -- no end-quote was found
330                set item $line
331                set line {}
332                append block${blocks}(errors) "The quoted string on line $linenum does not have a close quote ([string trim $item])\n"
333            }
334        } else {
335            # must be a single space-delimited value
336            set pos [string first { } $trimline]
337            if {$pos < 0} {
338                # and the only thing left on the line
339                set item $trimline
340                set line {}
341            } else {
342                # save the rest of the line
343                set line [string range $trimline $pos end]
344                incr pos -1
345                set item [string range $trimline 0 $pos]
346            }
347        }
348       
349        # a data item has been read
350        # fix the hidden characters, if any
351        if $hidden {
352            regsub -all \200 $item {\\'} item
353            regsub -all \201 $item {\\"} item
354        }
355
356        # store the data item
357        if {$loopflag >= 0} {
358            # if in a loop, increment the loop element counter to select the
359            # appropriate array element
360            incr loopflag
361            set i [expr ($loopflag - 1) % [llength $looplist]]
362            lappend block${blocks}([lindex $looplist $i]) $item
363        } elseif {$dataname == ""} {
364            # this is an error -- a data item where we do not expect one
365            append block${blocks}(errors) "The string \"$item\" on line $linenum was unexpected\n"
366        } else {
367            catch {
368                if {[set block${blocks}($dataname)] != ""} {
369                    # this is an error -- repeated data name
370                    append block${blocks}(errors) \
371                            "Data item $dataname is repeated near line $linenum\n"
372                }
373            }
374            set block${blocks}($dataname) $item
375            set dataname ""
376        }
377    }
378    close $fp
379    return $blocks
380}
381
382# this proc creates a hierarchical CIF browser
383# note that the BWidget package is required
384proc BrowseCIF {blocklist "selected {}" "frame .cif"} {
385
386    if [catch {package require BWidget}] {
387        tk_dialog $frame {No BWidget} \
388                "Sorry, the CIF Browser requires the BWidget package" \
389                warning 0 Continue
390        return
391    }
392    if {$selected == ""} {set selected $blocklist}
393    catch {destroy $frame}
394    toplevel $frame 
395    wm title $frame "CIF Browser"
396
397    set pw    [PanedWindow $frame.pw -side top]
398    grid $pw -sticky news -column 0 -row 0 
399    grid columnconfigure $frame 0 -weight 1
400    grid rowconfigure $frame 0 -minsize 250 -weight 1
401
402    # create a left hand side pane for the hierarchical tree
403    set pane  [$pw add -weight 1]
404    set sw    [ScrolledWindow $pane.lf \
405            -relief sunken -borderwidth 2]
406    set tree  [Tree $sw.tree \
407            -relief flat -borderwidth 0 -width 15 -highlightthickness 0 \
408            -redraw 1]
409    grid $sw
410    grid $sw -sticky news -column 0 -row 0 
411    grid columnconfigure $pane 0 -minsize 275 -weight 1
412    grid rowconfigure $pane 0 -weight 1
413    $sw setwidget $tree
414   
415    # create a right hand side pane to show the value
416    set pane [$pw add -weight 1]
417    set sw   [ScrolledWindow $pane.sw \
418            -relief sunken -borderwidth 2]
419    pack $sw -fill both -expand yes -side bottom
420    set lb [ScrollableFrame::create $sw.lb -width 250]
421    $sw setwidget $lb
422
423    set num 0
424    foreach n $blocklist {
425        global block$n
426        # make a list of data names in loops
427        set looplist {}
428        foreach loop [array names block$n loop_*] {
429            eval lappend looplist [set block${n}($loop)]
430        }
431        # put the block name
432        set blockname [set block${n}(data_)]
433        set open 0
434        if {[lsearch $selected $n] != -1} {set open 1}
435        $tree insert end root block$n -text "_data_$blockname" \
436                -open $open -image [Bitmap::get copy]
437        # loop over the names in each block
438        foreach name [array names block$n _*] {
439            # don't include looped names
440            if {[lsearch $looplist $name] == -1} {
441                $tree insert end block$n [incr num] -text $name \
442                        -image [Bitmap::get folder] -data block$n
443            }
444        }
445        foreach loop [array names block$n loop_*] {
446            $tree insert end block$n block${n}$loop -text $loop \
447                    -image [Bitmap::get file] -data "block$n loop"
448            foreach name [set block${n}($loop)] {
449                $tree insert end block${n}$loop [incr num] -text $name \
450                        -image [Bitmap::get folder] -data "block$n $loop"
451            }
452        }
453        foreach name [array names block$n errors] {
454            $tree insert end block$n [incr num] -text $name \
455                    -image [Bitmap::get undo] -data block$n
456        }
457    }
458    $tree bindImage <1> "showCIFvalue $tree $sw"
459    $tree bindText <1> "showCIFvalue $tree $sw"
460    grid [button $frame.c -text Close -command "destroy $frame"] -column 0 -row 1
461}
462
463# used in BrowseCIF in response to the spinbox
464# show the contents of a loop
465proc ShowLoopVar {array loop frame sb} {
466    global $array
467    set looplist [set ${array}($loop)]
468    set index [$sb getvalue]
469    set i 0
470    foreach var $looplist {
471        incr i
472        [$frame.$i getframe].l config \
473                -text [lindex [set ${array}($var)] $index]
474    }
475}
476
477# used in BrowseCIF in response to the clicking on a CIF dataname
478# shows the contents data name or a loop
479proc showCIFvalue {tree sw name} {
480    set data [$tree itemcget $name -data]
481    set text [$tree itemcget $name -text]
482
483    # delete old contents of frame
484    set frame [$sw.lb getframe]
485    eval destroy [grid slaves $frame]
486    # reset the scrollbars
487    $sw.lb xview moveto 0
488    $sw.lb yview moveto 0
489    # leave room for a scrollbar
490    grid columnconfig $frame 0 -minsize [expr \
491            [winfo width [winfo parent $frame]] - 20]
492    if {$data == ""} {
493        return
494    }
495   
496    #
497    if {[llength $data] == 2} {
498        global [lindex $data 0]
499        if {[lindex $data 1] == "loop"} {
500            set looplist [set [lindex $data 0]($text)]
501            # get number of elements for first name
502            set names [llength [set [lindex $data 0]([lindex $looplist 0])]]
503            set sb $frame.spin
504            grid [SpinBox $sb -range "1 $names 1" \
505                    -label "Loop\nelement #" -labelwidth 10 -width 10 \
506                    -command    "ShowLoopVar [lindex $data 0] $text $frame $sb" \
507                    -modifycmd  "ShowLoopVar [lindex $data 0] $text $frame $sb"] \
508                    -column 0 -row 0 -sticky w
509            set i 0
510            foreach var $looplist {
511                incr i
512                grid [TitleFrame $frame.$i -text $var -side left] \
513                        -column 0 -row $i -sticky ew
514                pack [label [$frame.$i getframe].l -anchor w -justify left] -side left
515            }
516            ShowLoopVar [lindex $data 0] $text $frame $sb
517        } else {
518            grid [TitleFrame $frame.0 -text $text -side left] \
519                    -column 0 -row 0 -sticky ew
520            set row 0
521            set frame0 [$frame.0 getframe]
522            grid columnconfig $frame0 2 -weight 1
523            foreach name [set [lindex $data 0]($text)] {
524                incr row
525                grid [label $frame0.a$row -justify left -text $row]\
526                        -sticky w -column 0 -row $row
527                grid [label $frame0.b$row -bd 2 -relief groove \
528                        -justify left -anchor w -text $name]\
529                        -sticky new -column 1 -row $row 
530            }
531        }
532    } else {
533        # unlooped data name
534        global [lindex $data 0]
535        grid [TitleFrame $frame.0 -text $text -side left] \
536                -column 0 -row 0 -sticky ew
537        pack [label [$frame.0 getframe].l -anchor w -justify left\
538                -text [set ${data}($text)]] -side left
539    }
540}
541
542# Parse a number in CIF, that may include a SU (ESD) value
543# note that this routine will ignore spaces, quotes & semicolons
544proc ParseSU {value} {
545    # if there is no SU just return the value
546    if {[string first "(" $value] == -1} {
547        return $value
548    }
549    # is there a decimal point?
550    if [regexp {([-+]?[0-9]*\.)([0-9]*)\(([0-9]+)\)} $value junk a b err] {
551        set ex [string length $b]
552        return [list ${a}${b} [expr {pow(10.,-$ex)*$err}]]
553    }
554    if [regexp {([-+]?[0-9]*)\(([0-9]+)\)} $value junk a err] {
555        return [list ${a} $err]
556    }
557    tk_dialog .err {ParseSU Error} \
558            "ParseSU: Error processing value $value" \
559            warning 0 Continue
560}
561
562# a stand-alone routine for testing. Select, read and browse a CIF
563proc Read_BrowseCIF {} {
564    global tcl_platform
565    if {$tcl_platform(platform) == "windows"} {
566        set filetypelist {
567            {"CIF files" .CIF} {"All files" *}
568        }
569    } else {
570        set filetypelist {
571            {"CIF files" .CIF} {"CIF files" .cif} {"All files" *}
572        }
573    }   
574    set file [tk_getOpenFile -parent . -filetypes $filetypelist]
575    if {$file == ""} return
576    if {![file exists $file]} return
577    # plasewait and donewait are defined in gsascmds.tcl and may not be present
578    catch {pleasewait "Reading CIF file"}
579    set blocks [ParseCIF $file]
580    if {$blocks == ""} {
581        donewait
582        MessageBox -parent . -type ok -icon warning \
583                -message "Note: no valid CIF blocks were read from file $filename"
584        return
585    }
586    catch {donewait}
587    set allblocks {}
588    for {set i 1} {$i <= $blocks} {incr i} {
589        lappend allblocks $i
590    }
591    if {$allblocks != ""} {
592        BrowseCIF $allblocks "" .cif
593        # wait for the window to close
594        tkwait window .cif
595    } else {
596        puts "no blocks read"
597    }
598    # clean up -- get rid of the CIF arrays
599    for {set i 1} {$i <= $blocks} {incr i} {
600        global block$i
601        unset block$i
602    }
603}
Note: See TracBrowser for help on using the repository browser.