source: trunk/import_cif.tcl @ 538

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

# on 2002/01/22 22:28:53, toby did:
more complete space group checking

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