source: trunk/import_cif.tcl @ 935

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

EXPGUI:

  • Implement routine to locate window where user wants (see LocateWindow?)
  • allow pgplot in gsas/pgl or gsas/pgplot

Import_cif: make sure that missing or defaulted values for Uiso & occ are set to valid values.

gsascmds:

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