source: trunk/import_cif.tcl @ 377

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

# on 2001/04/03 19:13:29, toby did:
support cifs w/o _atom_site_u_iso_or_equiv or _atom_site_b_iso_or_equiv
fix bug: always set data item names to lc

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