source: trunk/import_cif.tcl @ 643

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

# on 2002/09/05 18:17:58, toby did:
Major rework to use text-based browsecif.tcl

  • Property rcs:author set to toby
  • Property rcs:date set to 2002/09/05 18:17:58
  • Property rcs:lines set to +44 -458
  • Property rcs:rev set to 1.10
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 6.8 KB
Line 
1# $Id: import_cif.tcl 643 2009-12-04 23:09:36Z toby $
2
3#-------------------------------------------------
4# define info used in addcmds.tcl
5catch {
6    source [file join $expgui(scriptdir) browsecif.tcl]
7    set description "Crystallographic Information File (CIF)"
8    set extensions .cif
9    set procname ReadCIFFile
10}
11#-------------------------------------------------
12
13proc ReadCIFFile {filename} {
14    global expgui CIF
15    set fp [open $filename r]
16    pleasewait "Reading CIF file"         
17
18    catch {destroy [set file .file]}
19    toplevel $file
20    #bind $file <Key-F1> "MakeWWWHelp gsas2cif.html filltemplate"
21    set CIF(txt) $file.t
22    grid [text $CIF(txt) -height 10 -width 80 -yscrollcommand "$file.s set"] \
23            -col 0 -row 0 -sticky news
24    grid [scrollbar $file.s -command "$CIF(txt) yview"] \
25            -col 1 -row 0 -sticky ns
26    grid columnconfig $file 0 -weight 1
27    grid rowconfig $file 0 -weight 1
28    # hide it
29    wm withdraw $file
30    set blocks [ParseCIF $CIF(txt) $filename]
31    if {$blocks == ""} {
32        donewait
33        MyMessageBox -parent . -type ok -icon warning \
34                -message "Note: no valid CIF blocks were read from file $filename"
35        return 
36    }
37    set allblocks {}
38    set coordblocks {}
39    # search each block for coordinate
40    for {set i 1} {$i <= $blocks} {incr i} {
41        lappend allblocks $i
42        global block$i
43        set flag 1
44        foreach id {_atom_site_fract_x _atom_site_fract_y _atom_site_fract_z} {
45            if {[array name block$i $id] == ""} {set flag 0}
46        }
47        if $flag {lappend coordblocks $i}
48    }
49    donewait
50    if {$coordblocks == ""} {
51        MyMessageBox -parent . -type ok -icon warning \
52                -message "Note: CIF $filename contains no coordinates"
53        return
54    }
55    set expgui(choose) [lindex $coordblocks 0]
56    # there is more than one appropriate block
57    if {[llength $coordblocks] > 1} {
58        catch {destroy .choose}
59        toplevel .choose
60        wm title .choose "Choose CIF Block"
61        bind .choose <Key-F1> "MakeWWWHelp expguierr.html ChooseCIF"
62        grid [label .choose.0 -text \
63                "More than one block in CIF $filename\ncontains coordinates.\n\nSelect the block to use" \
64                ] -row 0 -column 0 -columnspan 2
65        set row 0
66        foreach i $coordblocks {
67            incr row
68            set name ""
69            catch {set name [set block${i}(data_)]}
70            grid [radiobutton .choose.$row -value $i \
71                    -text "block $i ($name)" -variable expgui(choose)] \
72                    -row $row -column 0 -sticky w
73        }
74        grid [button .choose.browse -text CIF\nBrowser -command \
75                "CallBrowseCIF $CIF(txt) [list $allblocks] [list $coordblocks] .choose.cif" \
76                ] -row 1 -rowspan $row -column 1 
77        grid [button .choose.ok -text OK -command "destroy .choose"] \
78                -row [incr row] -column 0 -sticky w
79        grid [button .choose.help -text Help -bg yellow \
80            -command "MakeWWWHelp expguierr.html ChooseCIF"] \
81            -column 1 -row $row -sticky e
82        putontop .choose
83        tkwait window .choose
84        # fix grab...
85        afterputontop
86    }
87
88    set i $expgui(choose)
89    # get the space group
90    set spg {}
91    set sgnum {}
92    set msg {}
93    catch {
94        set spg [ValueFromCIF block${i} _symmetry_space_group_name_h-m]
95        set sgtmp [string toupper $spg]
96        # remove spaces from space group
97        regsub -all " " $sgtmp "" sgtmp
98        # make a copy where we treat bar 3 as the same as 3
99        regsub -- "-3" $sgtmp "3" sgtmp3
100        # see if this space group exists in the table
101        set fp1 [open [file join \
102                $expgui(scriptdir) spacegrp.ref] r]
103        while {[gets $fp1 line] >= 0} {
104            set testsg [string toupper [lindex $line 8]]
105            regsub -all " " $testsg "" testsg
106            if {$testsg == $sgtmp} {
107                set spg [lindex $line 8]
108                set sgnum [lindex $line 1]
109                break
110            } elseif {[lindex $line 1] >= 200} {
111                regsub -- "-3" $testsg "3" testsg3
112                if {$testsg3 == $sgtmp3} {
113                    set spg [lindex $line 8]
114                    set sgnum [lindex $line 1]
115                    break
116                }
117            } elseif {[lindex $line 1] <= 18} {
118                # monoclinic: change operators of form "1 xxx 1" to "xxx"
119                regsub -- " 1 (.*) 1" [string toupper [lindex $line 8]] "\\1" testsg
120                # remove spaces from space group
121                regsub -all " " $testsg "" testsg
122                if {$testsg == $sgtmp} {
123                    set spg [lindex $line 8]
124                    set sgnum [lindex $line 1]
125                    break
126                }
127            }
128        }
129        close $fp1
130        if {$spg == ""} {
131            set msg "Warning: a Space Group must be specified"
132        } elseif {$sgnum == ""} {
133            set msg "Warning: the Space Group ($spg) is likely incorrect for GSAS"
134        }
135    }
136    set cell {}
137    foreach var {_cell_length_a _cell_length_b _cell_length_c \
138            _cell_angle_alpha _cell_angle_beta _cell_angle_gamma} {
139        # leave blank any unspecified data items
140        set val {}
141        catch {set val [ValueFromCIF block${i} $var]}
142        lappend cell [lindex [ParseSU $val] 0]
143    }
144   
145    set atomlist {}
146    set lbllist {}
147    catch {
148        set lbllist [ValueFromCIF block${i} _atom_site_label]
149    }
150    set uisolist {}
151    set Uconv 1
152    catch {
153        set uisolist [ValueFromCIF block${i} _atom_site_u_iso_or_equiv]
154    }
155    if {$uisolist == ""} {
156        catch {
157            set uisolist [ValueFromCIF block${i} _atom_site_b_iso_or_equiv]
158            set Uconv [expr 1/(8*3.14159*3.14159)]
159        }
160    }
161    set occlist {}
162    catch {
163        set occlist [ValueFromCIF block${i} _atom_site_occupancy]
164    }
165    set typelist {}
166    catch {
167        set typelist [ValueFromCIF block${i} _atom_site_type_symbol]
168    }
169    foreach x [ValueFromCIF block${i} _atom_site_fract_x] \
170            y [ValueFromCIF block${i} _atom_site_fract_y] \
171            z [ValueFromCIF block${i} _atom_site_fract_z] \
172            lbl $lbllist uiso $uisolist occ $occlist type $typelist {
173        if {$uiso == ""} {set uiso 0.025}
174        # should not be any quotes, but remove them, if there are
175        foreach var {lbl type} {
176            foreach char {' \"} {
177                set q {\\}
178                append q $char
179                set hidden [regsub -all $q [set $var] \200 $var]
180                if {[string index [set $var] 0] == $char} {
181                    regsub -all $char [set $var] {} $var
182                }
183                if {$hidden} {regsub -all \200 [set $var] $char $var}
184            }
185        }
186        # CIF specifies types as Cu2+; GSAS uses Cu+2
187        if {[regexp {([A-Za-z]+)([1-9])([+-])} $type junk elem sign val]} {
188            set type ${elem}${val}$sign
189        }
190        # if type is missing, attempt to parse an element in the label
191        if {$type == "" && $lbl != ""} {
192            regexp {[A-Za-z][A-Za-z]?} $lbl type
193        }
194        # get rid of standard uncertainies
195        foreach var {x y z occ uiso} {
196            catch {
197                set $var [lindex [ParseSU [set $var]] 0]
198            }
199        }
200        # convert Biso to Uiso (if needed)
201        if {$Uconv != 1} {
202            catch {set $uiso [expr $Uconv*$uiso]}
203        }
204        lappend atomlist [list $lbl $x $y $z $type $occ $uiso]
205    }
206
207    # clean up -- get rid of the CIF arrays & window
208    for {set i 1} {$i <= $blocks} {incr i} {
209        unset block$i
210    }
211    destroy $file
212    return "[list $spg] [list $cell] [list $atomlist] [list $msg]"
213}
214
215
216proc CallBrowseCIF {txt blocklist selected frame} {
217    global CIF CIF_index CIF_dataname_index expgui
218
219    catch {
220        source  [file join $expgui(scriptdir) CIF_index]
221    }
222
223    # add location of these files & the typical GSAS data directory
224    # to the dictionary search path
225    lappend CIF(cif_path) $expgui(scriptdir) [file join [file dirname $expgui(scriptdir)] data]
226   
227    BrowseCIF $txt $blocklist $selected $frame
228}
Note: See TracBrowser for help on using the repository browser.