source: trunk/import_cif.tcl @ 280

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

# on 2000/09/24 04:41:00, toby did:
CIF coordinate import routine, includes CIF Browser

  • Property rcs:author set to toby
  • Property rcs:date set to 2000/09/24 04:41:00
  • Property rcs:rev set to 1.1
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 14.0 KB
Line 
1# $Id: import_cif.tcl 280 2009-12-04 23:03:25Z 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 values
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        regsub -all {'} $lbl {} lbl
123        regsub -all {'} $type {} type
124        # CIF specifies types as Cu2+; GSAS uses Cu+2
125        if {[regexp {([A-Za-z]+)([1-9])([+-])} $type junk elem sign val]} {
126            set type ${elem}${val}$sign
127        }
128        # if type is missing, attempt to parse an element in the label
129        if {$type == "" && $lbl != ""} {
130            regexp {[A-Za-z][A-Za-z]?} $lbl type
131        }
132        # get rid of standard uncertainies
133        foreach var {x y z occ uiso} {
134            catch {
135                set $var [lindex [ParseSU [set $var]] 0]
136            }
137        }
138        # convert Biso to Uiso (if needed)
139        if {$Uconv != 1} {
140            catch {set $uiso [expr $Uconv*$uiso]}
141        }
142        lappend atomlist [list $lbl $x $y $z $type $occ $uiso]
143    }
144
145    # clean up -- get rid of the CIF arrays
146    for {set i 1} {$i <= $blocks} {incr i} {
147        unset block$i
148    }
149    return "[list $spg] [list $cell] [list $atomlist] [list $msg]"
150}
151
152# ParseCIF reads and parses a CIF file putting the contents of
153# each block into arrays block1, block2,... in the caller's level
154#    the name of the block is saved as blockN(data_)
155# data items are saved as blockN(_cif_name) = value
156#    values are not reformatted, thus quotes, semicolons & newlines
157#    are included in the value string
158# for looped data items, the values are included in a list:
159#    blockN(_cif_name) = {value list ...}
160# the contents of each loop are saved as blockN(loop_M)
161#
162# the proc returns the number of blocks that have been read or a
163# null string if the file cannot be opened
164proc ParseCIF {filename} {
165    if [catch {
166        set fp [open $filename r]
167    }] {return ""}
168
169    set blocks 0
170    set EOF 1
171    set line {}
172    set loopflag -1
173    # loop over tokens
174    while {$EOF} {
175        if {[string length [string trim $line]] <= 0} {
176            if {[gets $fp line] < 0} {set EOF 0}
177        }
178        set hidden 0
179        set trimline [string trim $line]
180        set firstchar [string index $trimline 0]
181       
182        if {[string length $trimline] <= 0} {
183            # the line is blank
184            set line {}
185            continue
186        } 
187       
188        if {$firstchar == "#"} {
189            # this is a comment
190            set line {}
191            continue
192        } 
193       
194        if {[string tolower [string range $trimline 0 4]] == "data_"} {
195            # this is the beginning of a data block
196            incr blocks
197            # are there other tokens on this line?
198            if {[set pos [string first { } $trimline]] == -1} {
199                set blockname [string range $trimline 5 end]
200                set line {}
201            } else {
202                set blockname [string range $trimline 5 [expr $pos-1]]
203                set line [string range $trimline $pos end]
204            }
205            global block$blocks
206            catch {unset block$blocks}
207            set block${blocks}(data_) $blockname
208            set loopnum -1
209           
210            if {$line == ""} continue
211            set dataname {}
212        }
213       
214        if {$firstchar == "_"} {
215            # this is a data item
216            # are there other tokens on this line?
217            if {[set pos [string first { } $trimline]] == -1} {
218                set dataname $trimline
219                set line {}
220            } else {
221                set dataname [string range $trimline 0 [expr $pos-1]]
222                set line [string range $trimline $pos end]
223            }
224           
225            if {$loopflag == 0} {
226                # in a loop header, save the names in the loop
227                lappend looplist $dataname
228                set block${blocks}(loop_${loopnum}) $looplist
229                # clear the data item -- should not be needed, but...
230                set block${blocks}($dataname) {}
231                set dataname {}
232            } elseif {$loopflag > 0} {
233                # in a loop body, so the loop is over
234                set loopflag -1
235            }
236            continue
237        }
238       
239        if {[string tolower [string range $trimline 0 4]] == "loop_"} {
240            set loopflag 0
241            incr loopnum
242            set looplist {}
243            set block${blocks}(loop_${loopnum}) {}
244            # save any other tokens on this line
245            set line [string range $trimline 5 end]
246            continue
247        }
248
249        # keywords not matched, must be some type of value item
250        set item {}
251       
252        # multiline entry with semicolon termination
253        if {[string index $line 0] == ";"} {
254            set item $line
255            # read lines until we get a naked semicolon
256            while {$EOF} {
257                if {[gets $fp line] < 0} {set EOF 0}
258                append item \n $line
259                if {[string index $line 0] == ";" && \
260                        [string trim [string range $line 1 end]] == ""} break
261            }
262            set line {}
263        } elseif {$firstchar == {'}} {
264            # hide any \' sequences in a non-ASCII character
265            set hidden [regsub -all {\\'} $trimline \200 trimline]
266            regexp {('[^']*')(.*)} $trimline junk item line
267        } else {
268            set pos [string first { } $trimline]
269            if {$pos < 0} {
270                set item $trimline
271                set line {}
272            } else {
273                set line [string range $trimline $pos end]
274                incr pos -1
275                set item [string range $trimline 0 $pos]
276            }
277        }
278       
279        # a data value has been read
280        if $hidden {
281            regsub -all \200 $item {\\'} item
282        }
283
284        # if in a loop, increment the loop element counter
285        if {$loopflag >= 0} {
286            incr loopflag
287            set i [expr ($loopflag - 1) % [llength $looplist]]
288            lappend block${blocks}([lindex $looplist $i]) $item
289        } else {
290            set block${blocks}($dataname) $item
291        }
292    }
293    close $fp
294    return $blocks
295}
296
297# this proc creates a hierarchical CIF browser
298# note that the BWidget package is required
299proc BrowseCIF {blocklist "selected {}" "frame .cif"} {
300
301    if [catch {package require BWidget}] {
302        tk_dialog $frame {No BWidget} \
303                "Sorry, the CIF Browser requires the BWidget package" \
304                warning 0 Continue
305        return
306    }
307    if {$selected == ""} {set selected $blocklist}
308    catch {destroy $frame}
309    toplevel $frame 
310    wm title $frame "CIF Browser"
311
312    set pw    [PanedWindow $frame.pw -side top]
313    grid $pw -sticky news -column 0 -row 0 
314    grid columnconfigure $frame 0 -weight 1
315    grid rowconfigure $frame 0 -minsize 250 -weight 1
316
317    # create a left hand side pane for the hierarchical tree
318    set pane  [$pw add -weight 1]
319    set sw    [ScrolledWindow $pane.lf \
320            -relief sunken -borderwidth 2]
321    set tree  [Tree $sw.tree \
322            -relief flat -borderwidth 0 -width 15 -highlightthickness 0 \
323            -redraw 1]
324    grid $sw
325    grid $sw -sticky news -column 0 -row 0 
326    grid columnconfigure $pane 0 -minsize 275 -weight 1
327    grid rowconfigure $pane 0 -weight 1
328    $sw setwidget $tree
329   
330    # create a right hand side pane to show the value
331    set pane [$pw add -weight 1]
332    set sw   [ScrolledWindow $pane.sw \
333            -relief sunken -borderwidth 2]
334    pack $sw -fill both -expand yes -side bottom
335    set lb [ScrollableFrame::create $sw.lb -width 250]
336    $sw setwidget $lb
337
338    set num 0
339    foreach n $blocklist {
340        global block$n
341        # make a list of data items in loops
342        set looplist {}
343        foreach loop [array names block$n loop_*] {
344            eval lappend looplist [set block${n}($loop)]
345        }
346        # put the block name
347        set blockname [set block${n}(data_)]
348        set open 0
349        if {[lsearch $selected $n] != -1} {set open 1}
350        $tree insert end root block$n -text "_data_$blockname" \
351                -open $open -image [Bitmap::get copy]
352        # loop over the items in each block
353        foreach item [array names block$n _*] {
354            # don't include looped items
355            if {[lsearch $looplist $item] == -1} {
356                $tree insert end block$n [incr num] -text $item \
357                        -image [Bitmap::get folder] -data block$n
358            }
359        }
360        foreach loop [array names block$n loop_*] {
361            $tree insert end block$n block${n}$loop -text $loop \
362                    -image [Bitmap::get file] -data "block$n loop"
363            foreach item [set block${n}($loop)] {
364                $tree insert end block${n}$loop [incr num] -text $item \
365                        -image [Bitmap::get folder] -data "block$n $loop"
366            }
367        }
368    }
369    $tree bindImage <1> "showCIFvalue $tree $sw"
370    $tree bindText <1> "showCIFvalue $tree $sw"
371    grid [button $frame.c -text Close -command "destroy $frame"] -column 0 -row 1
372}
373
374# used in BrowseCIF in response to the spinbox
375# show the contents of a loop
376proc ShowLoopVar {array loop frame sb} {
377    global $array
378    set looplist [set ${array}($loop)]
379    set index [$sb getvalue]
380    set i 0
381    foreach var $looplist {
382        incr i
383        [$frame.$i getframe].l config \
384                -text [lindex [set ${array}($var)] $index]
385    }
386}
387
388# used in BrowseCIF in response to the clicking on a CIF dataname
389# shows the contents data item or a loop
390proc showCIFvalue {tree sw item} {
391    set data [$tree itemcget $item -data]
392    set text [$tree itemcget $item -text]
393
394    # delete old contents of frame
395    set frame [$sw.lb getframe]
396    eval destroy [grid slaves $frame]
397    # reset the scrollbars
398    $sw.lb xview moveto 0
399    $sw.lb yview moveto 0
400    # leave room for a scrollbar
401    grid columnconfig $frame 0 -minsize [expr \
402            [winfo width [winfo parent $frame]] - 20]
403    if {$data == ""} {
404        return
405    }
406   
407    #
408    if {[llength $data] == 2} {
409        global [lindex $data 0]
410        if {[lindex $data 1] == "loop"} {
411            set looplist [set [lindex $data 0]($text)]
412            # get number of elements for first item
413            set items [llength [set [lindex $data 0]([lindex $looplist 0])]]
414            set sb $frame.spin
415            grid [SpinBox $sb -range "1 $items 1" \
416                    -label "Loop\nelement #" -labelwidth 10 -width 10 \
417                    -command    "ShowLoopVar [lindex $data 0] $text $frame $sb" \
418                    -modifycmd  "ShowLoopVar [lindex $data 0] $text $frame $sb"] \
419                    -column 0 -row 0 -sticky w
420            set i 0
421#           grid columnconfig $frame 0 -minsize 250
422            foreach var $looplist {
423                incr i
424                grid [TitleFrame $frame.$i -text $var -side left] \
425                        -column 0 -row $i -sticky ew
426                pack [label [$frame.$i getframe].l -anchor w -justify left] -side left
427            }
428            ShowLoopVar [lindex $data 0] $text $frame $sb
429        } else {
430            grid [TitleFrame $frame.0 -text $text -side left] \
431                    -column 0 -row 0 -sticky ew
432            set row 0
433            set frame0 [$frame.0 getframe]
434            grid columnconfig $frame0 2 -weight 1
435            foreach item [set [lindex $data 0]($text)] {
436                incr row
437                grid [label $frame0.a$row -justify left -text $row]\
438                        -sticky w -column 0 -row $row
439                grid [label $frame0.b$row -bd 2 -relief groove \
440                        -justify left -anchor w -text $item]\
441                        -sticky new -column 1 -row $row 
442            }
443        }
444    } else {
445        # unlooped data item
446        global [lindex $data 0]
447        grid [TitleFrame $frame.0 -text $text -side left] \
448                -column 0 -row 0 -sticky ew
449        pack [label [$frame.0 getframe].l -anchor w -justify left\
450                -text [set ${data}($text)]] -side left
451    }
452#    $lf configure -text $text
453}
454
455# Parse a number in CIF, that may include a SU (ESD) value
456# note that this routine will ignore spaces, quotes & semicolons
457proc ParseSU {value} {
458    # if there is no SU just return the value
459    if {[string first "(" $value] == -1} {
460        return $value
461    }
462    # is there a decimal point?
463    if [regexp {([-+]?[0-9]*\.)([0-9]*)\(([0-9]+)\)} $value junk a b err] {
464        set ex [string length $b]
465        return [list ${a}${b} [expr {pow(10.,-$ex)*$err}]]
466    }
467    if [regexp {([-+]?[0-9]*)\(([0-9]+)\)} $value junk a err] {
468        return [list ${a} $err]
469    }
470    tk_dialog .err {ParseSU Error} \
471            "ParseSU: Error processing value $value" \
472            warning 0 Continue
473}
Note: See TracBrowser for help on using the repository browser.