1 | # export a phase to DRAWXTL |
---|
2 | # |
---|
3 | # $Id: export_drawxtl.tcl 1250 2014-03-10 21:23:13Z toby $ |
---|
4 | # set local variables that define the proc to execute and the menu label |
---|
5 | set label "export to DRAWXTL (.str) file" |
---|
6 | set action export_drawxtl |
---|
7 | set ::DXTLcolorlist "White Red Green Blue Yellow Cyan Magenta Black Orange Brown Grey Silver White" |
---|
8 | set ::DXTL(bonds) 0 |
---|
9 | set ::DXTL(coords) 1 |
---|
10 | set ::DXTL(blackarrow) Green |
---|
11 | set ::DXTL(redarrow) Red |
---|
12 | foreach a {X Y Z} { |
---|
13 | set ::DXTL(${a}dispMin) 0.0 |
---|
14 | set ::DXTL(${a}dispMax) 1.0 |
---|
15 | } |
---|
16 | set ::DXTL(mtype) "" |
---|
17 | set ::DXTL(mfil) "" |
---|
18 | set ::DXTL(FourierRange) "" |
---|
19 | |
---|
20 | proc export_drawxtl {} { |
---|
21 | global expmap expgui |
---|
22 | # don't bother if there are no phases to write |
---|
23 | if {[llength $expmap(phaselist)] == 0} { |
---|
24 | MyMessageBox -parent . -title "No phases" \ |
---|
25 | -message "Sorry, no phases are present to write" \ |
---|
26 | -icon warning |
---|
27 | return |
---|
28 | } |
---|
29 | foreach t [trace vinfo ::expgui(export_phase)] { |
---|
30 | eval trace vdelete ::expgui(export_phase) $t |
---|
31 | } |
---|
32 | MakeExportBox .export "Export coordinates to program DRAWXTL" "" |
---|
33 | # "MakeWWWHelp expgui.html export" |
---|
34 | |
---|
35 | # trigger a quit on window delete |
---|
36 | wm protocol .export WM_DELETE_WINDOW {set expgui(export_phase) 0; destroy .export } |
---|
37 | set bx .export.special |
---|
38 | set row 1 |
---|
39 | grid [label $bx.1 -text "Title:"] -column 1 -row $row -sticky e |
---|
40 | grid [entry $bx.2 -textvariable ::DXTL(title) -width 40] \ |
---|
41 | -row $row -column 2 -columnspan 5 -sticky w |
---|
42 | set ::DXTL(title) [expinfo title] |
---|
43 | incr row |
---|
44 | grid [checkbutton $bx.3 -text "Include coordinates in .str file" \ |
---|
45 | -variable ::DXTL(coords)] \ |
---|
46 | -row $row -column 1 -columnspan 5 -sticky w |
---|
47 | incr row |
---|
48 | set ::DXTL(arrowbox) $bx.4 |
---|
49 | grid [checkbutton $bx.4 -text "Display arrows for magnetic atoms" \ |
---|
50 | -variable ::DXTL(genarrows) -state disabled] \ |
---|
51 | -row $row -column 1 -columnspan 5 -sticky w |
---|
52 | incr row |
---|
53 | set ::DXTL(arrowcolorbox) $bx.4a |
---|
54 | set ::DXTL(arrowcolorbox_row) $row |
---|
55 | grid [frame $bx.4a] -sticky ew -row $::DXTL(arrowcolorbox_row) \ |
---|
56 | -column 1 -columnspan 5 |
---|
57 | grid [label $bx.4a.h -text "Arrow colors: "] -column 0 -row 1 -sticky w |
---|
58 | grid [label $bx.4a.bll -text " generated by Black operator "] -column 0 -row 2 |
---|
59 | eval tk_optionMenu $bx.4a.bl ::DXTL(blackarrow) $::DXTLcolorlist |
---|
60 | grid $bx.4a.bl -column 2 -row 2 |
---|
61 | grid [label $bx.4a.redl -text " generated by Red operator "] -column 0 -row 3 |
---|
62 | eval tk_optionMenu $bx.4a.red ::DXTL(redarrow) $::DXTLcolorlist |
---|
63 | grid $bx.4a.red -column 2 -row 3 |
---|
64 | incr row |
---|
65 | # is DRAWxtl installed? |
---|
66 | set app {} |
---|
67 | if {![catch {set fp [open [file join $::env(HOME) .drawxtlrc] r]}]} { |
---|
68 | # line 12 is name of executable |
---|
69 | set i 0 |
---|
70 | while {$i < 12} { |
---|
71 | incr i |
---|
72 | gets $fp appname |
---|
73 | } |
---|
74 | close $fp |
---|
75 | set app [auto_execok $appname] |
---|
76 | } |
---|
77 | if {$app != ""} { |
---|
78 | set show normal |
---|
79 | set ::DXTL(app) $appname |
---|
80 | set ::DXTL(launch) 1 |
---|
81 | } else { |
---|
82 | set show disabled |
---|
83 | set ::DXTL(launch) 0 |
---|
84 | } |
---|
85 | grid [checkbutton $bx.l -text "Launch DRAWxtl" \ |
---|
86 | -variable ::DXTL(launch) -state $show] \ |
---|
87 | -row $row -column 1 -columnspan 5 -sticky w |
---|
88 | incr row |
---|
89 | grid [frame $bx.c -relief groove -bd 4] -row $row -column 0 -columnspan 5 |
---|
90 | grid [label $bx.c.0 -text "Range of fractional coordinates to include" \ |
---|
91 | -anchor center] -row 0 -column 0 -columnspan 8 |
---|
92 | foreach v {x y z} V {X Y Z} { |
---|
93 | incr row |
---|
94 | grid [label $bx.c.${v}1 -text "${V} min:"] -column 1 -row $row |
---|
95 | grid [entry $bx.c.${v}2 -textvariable ::DXTL(${v}min) -width 4] -column 2 -row $row |
---|
96 | grid [scale $bx.c.${v}3 -resolution 0.1 -variable ::DXTL(${v}min) \ |
---|
97 | -showvalue 0 -orient h -from -2 -to 1] -column 3 -row $row |
---|
98 | set ::DXTL(${v}min) -0.1 |
---|
99 | grid [label $bx.c.${v}4 -text " max:"] -column 4 -row $row |
---|
100 | grid [entry $bx.c.${v}5 -textvariable ::DXTL(${v}max) -width 4] -column 5 -row $row |
---|
101 | grid [scale $bx.c.${v}6 -resolution 0.1 -variable ::DXTL(${v}max) \ |
---|
102 | -showvalue 0 -orient h -from 0 -to 3] -column 6 -row $row |
---|
103 | set ::DXTL(${v}max) 1.1 |
---|
104 | } |
---|
105 | # atom type box |
---|
106 | grid [frame $bx.s -relief groove -bd 4] -row $row -column 0 -columnspan 5 -sticky nsew |
---|
107 | grid rowconfigure $bx $row -weight 1 |
---|
108 | grid [label $bx.s.0 -text "Atom representation" \ |
---|
109 | -anchor w] -row 0 -column 0 -sticky w |
---|
110 | grid [canvas $bx.s.canvas -relief sunk -bd 2 \ |
---|
111 | -scrollregion {0 0 5000 500} -width 250 -height 70 \ |
---|
112 | -yscrollcommand "$bx.s.scroll set" ] \ |
---|
113 | -column 0 -row [incr row] -sticky nsew |
---|
114 | grid rowconfigure $bx.s $row -weight 1 |
---|
115 | grid columnconfig $bx.s 0 -weight 1 |
---|
116 | frame [set ::DXTL(lb) $bx.s.canvas.fr] |
---|
117 | $bx.s.canvas create window 0 0 -anchor nw -window $::DXTL(lb) |
---|
118 | grid [scrollbar $bx.s.scroll \ |
---|
119 | -command "$bx.s.canvas yview"] -sticky ns -row $row -column 1 |
---|
120 | # bond box |
---|
121 | incr row |
---|
122 | grid [frame $bx.b -relief groove -bd 4] -row $row -column 0 -columnspan 5 -sticky ew |
---|
123 | grid rowconfigure $bx $row -weight 1 |
---|
124 | grid [frame $bx.b.0] -row 0 -column 0 -columnspan 7 -sticky ew |
---|
125 | grid [label $bx.b.0.1 -text "Bond List" \ |
---|
126 | -anchor w] -row 0 -column 0 -sticky w |
---|
127 | grid columnconfig $bx.b.0 0 -weight 1 |
---|
128 | grid [button $bx.b.0.b -text "Add Bond" -command DXTLaddBond \ |
---|
129 | ] -row 0 -column 1 -sticky e |
---|
130 | grid [canvas $bx.b.canvas -relief sunk -bd 2 \ |
---|
131 | -scrollregion {0 0 5000 500} -width 250 -height 70 \ |
---|
132 | -yscrollcommand "$bx.b.scroll set" ] \ |
---|
133 | -column 0 -row [incr row] -sticky nsew |
---|
134 | grid rowconfigure $bx.b $row -weight 1 |
---|
135 | grid columnconfig $bx.b 0 -weight 1 |
---|
136 | frame [set ::DXTL(Blst) $bx.b.canvas.fr] |
---|
137 | $bx.b.canvas create window 0 0 -anchor nw -window $::DXTL(Blst) |
---|
138 | grid [scrollbar $bx.b.scroll \ |
---|
139 | -command "$bx.b.canvas yview"] -sticky ns -row $row -column 1 |
---|
140 | # Fourier Box |
---|
141 | incr row |
---|
142 | grid [frame $bx.f -relief groove -bd 4] -row $row -column 0 -columnspan 5 -sticky nsew |
---|
143 | grid [frame $bx.f.0] -column 0 -columnspan 3 -row 0 -sticky news |
---|
144 | grid columnconfig $bx.f.0 0 -weight 1 |
---|
145 | grid [label $bx.f.0.l1 -text "Fourier display" \ |
---|
146 | -anchor w] -row 0 -column 0 -sticky w |
---|
147 | set ::DXTL(FourierRange) "Range: unknown" |
---|
148 | grid [label $bx.f.0.l2 -textvariable ::DXTL(FourierRange) \ |
---|
149 | -anchor w] -row 0 -column 1 -sticky e |
---|
150 | grid [frame $bx.f.1] -column 0 -columnspan 3 -row 1 -sticky news |
---|
151 | grid [frame $bx.f.2] -column 0 -columnspan 3 -row 2 -sticky news |
---|
152 | grid [canvas $bx.f.canvas -relief sunk -bd 2 \ |
---|
153 | -scrollregion {0 0 5000 500} -width 250 -height 70 \ |
---|
154 | -yscrollcommand "$bx.f.scroll set" ] \ |
---|
155 | -column 0 -row 3 -sticky nsew |
---|
156 | grid rowconfigure $bx $row -weight 1 |
---|
157 | grid rowconfigure $bx.f 3 -weight 1 |
---|
158 | grid columnconfig $bx.f 0 -weight 1 |
---|
159 | frame [set ::DXTL(fb) $bx.f.canvas.fr] |
---|
160 | $bx.f.canvas create window 0 0 -anchor nw -window $::DXTL(fb) |
---|
161 | grid [scrollbar $bx.f.scroll \ |
---|
162 | -command "$bx.f.canvas yview"] -sticky ns -row 3 -column 2 |
---|
163 | grid [button $bx.f.1.1 -text "Setup\nFourier" \ |
---|
164 | -command {EditFourier $::expgui(export_phase); SetupFourierButtons} \ |
---|
165 | ] -column 0 -row 0 |
---|
166 | grid [button [set ::DXTL(FourCompute) $bx.f.1.2] -text "Compute\nFourier" \ |
---|
167 | -command {DXTLwritegrd $expgui(export_phase)}] -column 1 -row 0 |
---|
168 | grid [label $bx.f.1.3 -text "Select\nMap"] -column 3 -row 0 |
---|
169 | set ::DXTL(fmenu) [tk_optionMenu $bx.f.1.4 ::DXTL(mtype) test] |
---|
170 | grid $bx.f.1.4 -column 4 -row 0 |
---|
171 | grid [button [set ::DXTL(AddContour) $bx.f.1.5] -text "Add\nContour" \ |
---|
172 | -command AddContour] -column 5 -row 0 |
---|
173 | grid [frame $bx.f.1.f] -column 0 -columnspan 9 -row 1 |
---|
174 | grid [label $bx.f.1.f.0 -text "display\nlimits"] -column 0 -row 0 |
---|
175 | set col 0 |
---|
176 | foreach a {X Y Z} { |
---|
177 | incr col |
---|
178 | grid [label $bx.f.1.f.$col -text $a] -column $col -row 0 |
---|
179 | incr col |
---|
180 | grid [entry $bx.f.1.f.$col -textvariable ::DXTL(${a}dispMin) \ |
---|
181 | -width 6] -column $col -row 0 |
---|
182 | incr col |
---|
183 | grid [entry $bx.f.1.f.$col -textvariable ::DXTL(${a}dispMax) \ |
---|
184 | -width 6] -column $col -row 0 |
---|
185 | } |
---|
186 | set ::DXTL(contours) 0 |
---|
187 | trace variable ::expgui(export_phase) w OnNewFourierPhase |
---|
188 | OnNewFourierPhase |
---|
189 | # this appears to be needed by OSX |
---|
190 | ResizeWin .export |
---|
191 | # force the window to stay on top |
---|
192 | putontop .export |
---|
193 | SetDXTLatoms |
---|
194 | |
---|
195 | # Wait for the Write or Quit button to be pressed |
---|
196 | tkwait window .export |
---|
197 | afterputontop |
---|
198 | # test for Quit |
---|
199 | if {$expgui(export_phase) == 0} {return} |
---|
200 | |
---|
201 | # now open the file and write it |
---|
202 | set phase $expgui(export_phase) |
---|
203 | if [catch { |
---|
204 | set filnam [file rootname $expgui(expfile)]_${phase}.str |
---|
205 | set fp [open $filnam w] |
---|
206 | # deal with macromolecular phases |
---|
207 | if {[lindex $expmap(phasetype) [expr {$phase - 1}]] == 4} { |
---|
208 | MyMessageBox -parent . -title "MM phase" \ |
---|
209 | -message "Sorry, macromolecular phases cannot be processed" \ |
---|
210 | -icon warning |
---|
211 | return |
---|
212 | } |
---|
213 | catch {unset typelist} |
---|
214 | foreach atom $expmap(atomlist_$phase) { |
---|
215 | set typelist([atominfo $phase $atom type]) 1 |
---|
216 | } |
---|
217 | # title info from GSAS title & phase title |
---|
218 | puts $fp "REM created by EXPGUI from $expgui(expfile) on [clock format [clock seconds]]" |
---|
219 | puts $fp "title \"$::DXTL(title)\"" |
---|
220 | puts $fp "pack $::DXTL(xmin) $::DXTL(xmax) $::DXTL(ymin) $::DXTL(ymax) $::DXTL(zmin) $::DXTL(zmax)" |
---|
221 | puts $fp "edges 0.02 Black" |
---|
222 | puts $fp "phong 1.0 30." |
---|
223 | foreach type [array names typelist] { |
---|
224 | if {$::DXTL(display_$type) == "sphere"} { |
---|
225 | puts $fp "sphere $type $::DXTL(radius_$type) $::DXTL(color_$type)" |
---|
226 | } elseif {$::DXTL(display_$type) == "polyhedron"} { |
---|
227 | puts $fp "polysz $type $::DXTL(radius_$type) $::DXTL(color_$type)" |
---|
228 | } elseif {$::DXTL(display_$type) == "ellipsoid"} { |
---|
229 | puts $fp "ellipcolor $type * $::DXTL(color_$type)" |
---|
230 | } |
---|
231 | } |
---|
232 | if {$::DXTL(coords)} { |
---|
233 | # write out cell parameters |
---|
234 | puts -nonewline $fp "cell" |
---|
235 | foreach p {a b c alpha beta gamma} { |
---|
236 | puts -nonewline $fp " [phaseinfo $phase $p]" |
---|
237 | } |
---|
238 | puts $fp "" |
---|
239 | # write out GSAS spacegroup |
---|
240 | puts $fp "spgp [phaseinfo $phase spacegroup]" |
---|
241 | # now loop over atoms |
---|
242 | foreach atom $expmap(atomlist_$phase) { |
---|
243 | puts -nonewline $fp "atom [atominfo $phase $atom type] $atom " |
---|
244 | foreach v {x y z} { |
---|
245 | puts -nonewline $fp "[atominfo $phase $atom $v] " |
---|
246 | } |
---|
247 | puts $fp "" |
---|
248 | |
---|
249 | set uiso [atominfo $phase $atom Uiso] |
---|
250 | # are there anisotropic atoms? If so convert them to Uequiv |
---|
251 | if {[atominfo $phase $atom temptype] == "A"} { |
---|
252 | puts -nonewline $fp "Uij [atominfo $phase $atom type] $atom " |
---|
253 | foreach v {U11 U22 U33 U12 U13 U23} { |
---|
254 | puts -nonewline $fp "[atominfo $phase $atom $v] " |
---|
255 | } |
---|
256 | puts $fp "" |
---|
257 | } |
---|
258 | } |
---|
259 | } else { |
---|
260 | puts $fp "import gsas [file tail $expgui(expfile)] $phase" |
---|
261 | } |
---|
262 | for {set i 1} {$i <= $::DXTL(bonds)} {incr i} { |
---|
263 | puts $fp "bond $::DXTL(ba_$i) $::DXTL(bb_$i) $::DXTL(bw_$i) $::DXTL(bmin_$i) $::DXTL(bmax_$i) $::DXTL(bc_$i)" |
---|
264 | } |
---|
265 | # list arrows, when requested |
---|
266 | if {[lindex $expmap(phasetype) [expr {$phase - 1}]] != 1 && \ |
---|
267 | $::DXTL(genarrows)} { |
---|
268 | DXTLwriteArrows $fp $phase |
---|
269 | } |
---|
270 | DXTLwriteFourierCommands $fp |
---|
271 | puts $fp "END" |
---|
272 | close $fp |
---|
273 | if {$::DXTL(launch)} { |
---|
274 | exec $::DXTL(app) $filnam & |
---|
275 | } |
---|
276 | } errmsg] { |
---|
277 | MyMessageBox -parent . -title "Export error" \ |
---|
278 | -message "Export error: $errmsg" -icon warning |
---|
279 | } else { |
---|
280 | MyMessageBox -parent . -title "Done" \ |
---|
281 | -message "File [file tail $filnam] was written" |
---|
282 | } |
---|
283 | #catch {unset DXTL} |
---|
284 | foreach t [trace vinfo expgui(export_phase)] { |
---|
285 | eval trace vdelete expgui(export_phase) $t |
---|
286 | } |
---|
287 | } |
---|
288 | |
---|
289 | # resize windows -- this appears to be needed by OSX 10.2 |
---|
290 | proc ResizeWin {win} { |
---|
291 | update |
---|
292 | wm geom $win [winfo reqwidth $win]x[winfo reqheight $win] |
---|
293 | # center the EXPGUI window |
---|
294 | wm withdraw $win |
---|
295 | set x [expr [winfo screenwidth $win]/2 - [winfo reqwidth $win]/2 ] |
---|
296 | set y [expr [winfo screenheight $win]/2 - [winfo reqheight $win]/2] |
---|
297 | wm geom $win +$x+$y |
---|
298 | wm deiconify $win |
---|
299 | } |
---|
300 | |
---|
301 | |
---|
302 | # add atoms to atom representation list |
---|
303 | proc SetDXTLatoms {args} { |
---|
304 | global expgui expmap |
---|
305 | eval destroy [winfo children $::DXTL(lb)] |
---|
306 | eval destroy [winfo children $::DXTL(Blst)] |
---|
307 | set ::DXTL(bonds) 0 |
---|
308 | if {$expgui(export_phase) == 0} {return} |
---|
309 | set phase $expgui(export_phase) |
---|
310 | if {[lindex $expmap(phasetype) [expr {$phase - 1}]] == 4} { |
---|
311 | MyMessageBox -parent . -title "MM phase" \ |
---|
312 | -message "Sorry, macromolecular phases cannot be processed" \ |
---|
313 | -icon warning |
---|
314 | return |
---|
315 | } |
---|
316 | if {[lindex $expmap(phasetype) [expr {$phase - 1}]] == 1} { |
---|
317 | set ::DXTL(genarrows) 0 |
---|
318 | $::DXTL(arrowbox) configure -state disabled |
---|
319 | grid forget $::DXTL(arrowcolorbox) |
---|
320 | } else { |
---|
321 | set ::DXTL(genarrows) 1 |
---|
322 | $::DXTL(arrowbox) configure -state normal |
---|
323 | grid $::DXTL(arrowcolorbox) -sticky ew -row $::DXTL(arrowcolorbox_row) \ |
---|
324 | -column 1 -columnspan 5 |
---|
325 | } |
---|
326 | catch {unset typelist} |
---|
327 | set ::DXTL(title) [phaseinfo $phase name] |
---|
328 | foreach atom $expmap(atomlist_$phase) { |
---|
329 | set typelist([atominfo $phase $atom type]) 1 |
---|
330 | } |
---|
331 | set ::DXTL(typelist) [array names typelist] |
---|
332 | set row 0 |
---|
333 | grid [label $::DXTL(lb).l$row -text "type " -bg yellow\ |
---|
334 | ] -column 0 -row $row -sticky ew |
---|
335 | grid [label $::DXTL(lb).d$row -text " representation " -bg yellow |
---|
336 | ] -column 1 -row $row -sticky ew |
---|
337 | grid [label $::DXTL(lb).e$row -text " radius " -bg yellow\ |
---|
338 | ] -column 2 -row $row -sticky ew |
---|
339 | grid [label $::DXTL(lb).c$row -text " color " -bg yellow\ |
---|
340 | ] -column 3 -row $row -sticky ew |
---|
341 | foreach type [array names typelist] { |
---|
342 | incr row |
---|
343 | grid [label $::DXTL(lb).l$row -text $type] -column 0 -row $row |
---|
344 | tk_optionMenu $::DXTL(lb).d$row ::DXTL(display_$type) sphere polyhedron ellipsoid none |
---|
345 | grid $::DXTL(lb).d$row -column 1 -row $row |
---|
346 | grid [entry $::DXTL(lb).e$row -textvariable ::DXTL(radius_$type) \ |
---|
347 | -width 5] -column 2 -row $row |
---|
348 | eval tk_optionMenu $::DXTL(lb).c$row ::DXTL(color_$type) $::DXTLcolorlist |
---|
349 | grid $::DXTL(lb).c$row -column 3 -row $row |
---|
350 | set ::DXTL(display_$type) sphere |
---|
351 | set ::DXTL(radius_$type) 0.2 |
---|
352 | set ::DXTL(color_$type) [lindex $::DXTLcolorlist $row] |
---|
353 | } |
---|
354 | # Resize the list |
---|
355 | update idletasks |
---|
356 | foreach i {lb Blst fb} { |
---|
357 | set sizes [grid bbox $::DXTL($i)] |
---|
358 | [winfo parent $::DXTL($i)] config -scrollregion $sizes \ |
---|
359 | -width [lindex $sizes 2] |
---|
360 | } |
---|
361 | wm geom [winfo toplevel $::DXTL(Blst)] {} |
---|
362 | } |
---|
363 | |
---|
364 | # add bonds to bond list |
---|
365 | proc DXTLaddBond {} { |
---|
366 | if {$::DXTL(bonds) == 0} { |
---|
367 | # insert header |
---|
368 | set row 0 |
---|
369 | grid [label $::DXTL(Blst).a$row -text "from " -bg yellow\ |
---|
370 | ] -column 1 -row $row -sticky ew |
---|
371 | grid [label $::DXTL(Blst).b$row -text " to " -bg yellow\ |
---|
372 | ] -column 2 -row $row -sticky ew |
---|
373 | grid [label $::DXTL(Blst).c$row -text " width " -bg yellow\ |
---|
374 | ] -column 3 -row $row -sticky ew |
---|
375 | grid [label $::DXTL(Blst).d$row -text " min " -bg yellow\ |
---|
376 | ] -column 4 -row $row -sticky ew |
---|
377 | grid [label $::DXTL(Blst).e$row -text " max " -bg yellow\ |
---|
378 | ] -column 5 -row $row -sticky ew |
---|
379 | grid [label $::DXTL(Blst).f$row -text " color " -bg yellow\ |
---|
380 | ] -column 6 -row $row -sticky ew |
---|
381 | } |
---|
382 | set row [incr ::DXTL(bonds)] |
---|
383 | eval tk_optionMenu $::DXTL(Blst).ta$row ::DXTL(ba_$row) $::DXTL(typelist) |
---|
384 | grid $::DXTL(Blst).ta$row -column 1 -row $row |
---|
385 | eval tk_optionMenu $::DXTL(Blst).tb$row ::DXTL(bb_$row) $::DXTL(typelist) |
---|
386 | grid $::DXTL(Blst).tb$row -column 2 -row $row |
---|
387 | grid [entry $::DXTL(Blst).w$row -textvariable ::DXTL(bw_$row) \ |
---|
388 | -width 5] -column 3 -row $row |
---|
389 | grid [entry $::DXTL(Blst).mi$row -textvariable ::DXTL(bmin_$row) \ |
---|
390 | -width 5] -column 4 -row $row |
---|
391 | grid [entry $::DXTL(Blst).mx$row -textvariable ::DXTL(bmax_$row) \ |
---|
392 | -width 5] -column 5 -row $row |
---|
393 | eval tk_optionMenu $::DXTL(Blst).c$row ::DXTL(bc_$row) $::DXTLcolorlist |
---|
394 | grid $::DXTL(Blst).c$row -column 6 -row $row |
---|
395 | set ::DXTL(bw_$row) 0.02 |
---|
396 | set ::DXTL(bmin_$row) 1.0 |
---|
397 | set ::DXTL(bmax_$row) 2.0 |
---|
398 | set ::DXTL(bc_$row) [lindex $::DXTLcolorlist $row] |
---|
399 | # Resize the list |
---|
400 | update |
---|
401 | set sizes [grid bbox $::DXTL(Blst)] |
---|
402 | [winfo parent $::DXTL(Blst)] config -scrollregion $sizes \ |
---|
403 | -width [lindex $sizes 2] |
---|
404 | #set can [winfo parent $::DXTL($i)] |
---|
405 | #set scroll [winfo parent $can].scroll |
---|
406 | #[winfo parent $::DXTL($i)] config -scrollregion $sizes |
---|
407 | } |
---|
408 | |
---|
409 | proc DXTLwriteArrows {out phase} { |
---|
410 | global expgui expmap |
---|
411 | set fp [open geom.in w] |
---|
412 | puts $fp "N" |
---|
413 | puts $fp "M" |
---|
414 | if {[llength $expmap(phaselist)] > 1} { |
---|
415 | puts $fp "$phase" |
---|
416 | } |
---|
417 | puts $fp "N" |
---|
418 | puts $fp "X" |
---|
419 | close $fp |
---|
420 | catch { |
---|
421 | if {$::tcl_platform(platform) == "windows"} { |
---|
422 | exec [file join $expgui(gsasexe) geometry.exe] \ |
---|
423 | [file root $expgui(expfile)] < geom.in >& geom.out |
---|
424 | } else { |
---|
425 | exec [file join $expgui(gsasexe) geometry] \ |
---|
426 | [file root $expgui(expfile)] < geom.in >& geom.out |
---|
427 | } |
---|
428 | set fp [open geom.out r] |
---|
429 | while {[gets $fp line] >= 0} { |
---|
430 | if {[string match "*Geometry*,L,N,*" $line]} { |
---|
431 | MyMessageBox -parent . -title "Old GSAS" \ |
---|
432 | -message "Old GEOMETRY program: You are using an old version of GSAS that cannot export magnetic vectors. Upgrade GSAS to generate arrows." -icon warning |
---|
433 | break |
---|
434 | } |
---|
435 | if {[string match "*name*elem*x *y *z*x *y *z*" $line]} {break} |
---|
436 | } |
---|
437 | set i 0 |
---|
438 | while {[gets $fp line] >= 0} { |
---|
439 | if {[string match "*Enter Geometry option*" $line]} {break} |
---|
440 | incr i |
---|
441 | if {$i == 2} { |
---|
442 | set name [string trim [string range $line 5 12]] |
---|
443 | set tail [string trim [string range $line 22 end]] |
---|
444 | set pos [lrange $tail 0 2] |
---|
445 | set spin [lindex $tail end] |
---|
446 | } elseif {$i == 5} { |
---|
447 | set vec [string trim [string range $line 22 end]] |
---|
448 | if {[catch {set count($name)}]} {set count($name) 0} |
---|
449 | catch { |
---|
450 | set k ? |
---|
451 | incr count($name) |
---|
452 | set k $count($name) |
---|
453 | } |
---|
454 | puts $out "rem spin for atom $name # $k ($spin)" |
---|
455 | if {$spin == "Red"} { |
---|
456 | puts $out "arrow $pos $vec 1. 0.15 $::DXTL(redarrow)" |
---|
457 | } else { |
---|
458 | puts $out "arrow $pos $vec 1. 0.15 $::DXTL(blackarrow)" |
---|
459 | } |
---|
460 | } elseif {$i == 6} { |
---|
461 | set i 1 |
---|
462 | } |
---|
463 | } |
---|
464 | } |
---|
465 | catch {close $fp} |
---|
466 | catch {file delete -force geom.in geom.out} |
---|
467 | puts $out "mag_trans 1. 0 0 0 1. 0 0 0 1." |
---|
468 | } |
---|
469 | |
---|
470 | # Computes a Fourier map(s) and converts the maps from binary to ascii |
---|
471 | # returns a list of Fourier map types |
---|
472 | proc DXTLwritegrd {phase} { |
---|
473 | global expgui expmap |
---|
474 | set lst [listFourier] |
---|
475 | if {[llength $lst] < 1} { |
---|
476 | MyMessageBox -parent . -title "No Fourier" \ |
---|
477 | -message "You have not set up to compute a Fourier map." \ |
---|
478 | -icon warning |
---|
479 | return |
---|
480 | } |
---|
481 | set typelist {} |
---|
482 | foreach l $lst { |
---|
483 | lappend typelist [Fourierinfo $l type] |
---|
484 | } |
---|
485 | set hists [FourierHists $phase] |
---|
486 | # make sure we have default limits |
---|
487 | getFourierLimits $phase |
---|
488 | if {[llength $hists] < 1} { |
---|
489 | MyMessageBox -parent . -title "No Fourier" \ |
---|
490 | -message "You have not set up to compute a Fourier map for phase $phase." \ |
---|
491 | -icon warning |
---|
492 | return |
---|
493 | } |
---|
494 | if {$::tcl_platform(platform) == "windows"} { |
---|
495 | set map [file join $expgui(gsasexe) gsas2map.exe] |
---|
496 | set fourier [file join $expgui(gsasexe) fourier.exe] |
---|
497 | } else { |
---|
498 | set map [file join $expgui(gsasexe) gsas2map] |
---|
499 | set fourier [file join $expgui(gsasexe) fourier] |
---|
500 | } |
---|
501 | if {![file exists $map]} { |
---|
502 | MyMessageBox -parent . -title "No Map Converter prog" \ |
---|
503 | -message "Error Fourier map converter program ($map) not found." \ |
---|
504 | -icon warning |
---|
505 | return |
---|
506 | } |
---|
507 | if {![file exists $fourier]} { |
---|
508 | MyMessageBox -parent . -title "No Fourier prog" \ |
---|
509 | -message "Error Fourier program ($fourier) not found." \ |
---|
510 | -icon warning |
---|
511 | return |
---|
512 | } |
---|
513 | set fp [open f.in w] |
---|
514 | if {[OutputFourierType]} { |
---|
515 | puts $fp [lindex $typelist 0] |
---|
516 | } |
---|
517 | puts $fp "E" |
---|
518 | foreach t [lrange $typelist 1 end] { |
---|
519 | puts $fp "F $t" |
---|
520 | puts $fp "E" |
---|
521 | } |
---|
522 | puts $fp "q" |
---|
523 | close $fp |
---|
524 | # delete any old grd files |
---|
525 | foreach f [glob -nocomplain "[file root $expgui(expfile)]*.grd"] { |
---|
526 | catch {file delete -force $f} |
---|
527 | } |
---|
528 | set deleteerror 0 |
---|
529 | if {[llength [glob -nocomplain "[file root $expgui(expfile)]*.grd"]] >0} { |
---|
530 | MyMessageBox -parent . -title "Old grd files?" \ |
---|
531 | -message "Warning: Could not delete old .grd files; it will probably not be possible to overwrite them either. Be aware that map results may be out of date." \ |
---|
532 | -icon warning |
---|
533 | set deleteerror 1 |
---|
534 | } |
---|
535 | # Save the current exp file |
---|
536 | savearchiveexp |
---|
537 | # disable the file changed monitor |
---|
538 | set expgui(expModifiedLast) 0 |
---|
539 | catch { |
---|
540 | exec $fourier [file root $expgui(expfile)] >& f.out |
---|
541 | exec $map [file root $expgui(expfile)] < f.in >>& f.out |
---|
542 | } |
---|
543 | # reset the file changed monitor |
---|
544 | #loadexp $expgui(expfile) |
---|
545 | set expgui(expModifiedLast) [file mtime $expgui(expfile)] |
---|
546 | |
---|
547 | if {[llength [glob -nocomplain "[file root $expgui(expfile)]*.grd"]] == 0} { |
---|
548 | set fp [open f.out r] |
---|
549 | set lines {} |
---|
550 | while {[gets $fp line] >= 0} { |
---|
551 | append lines $line "\n" |
---|
552 | } |
---|
553 | close $fp |
---|
554 | MyMessageBox -parent . -title "No grd files" \ |
---|
555 | -message "Error: no .grd files were created. See log file below\n\n$lines" \ |
---|
556 | -icon error |
---|
557 | return {} |
---|
558 | } else { |
---|
559 | catch {close $fp} |
---|
560 | catch {file delete -force f.in f.out} |
---|
561 | SetupFourierButtons |
---|
562 | return $typelist |
---|
563 | } |
---|
564 | } |
---|
565 | |
---|
566 | # called when the phase # is set or changed |
---|
567 | # clean up old Fourier maps |
---|
568 | proc OnNewFourierPhase {args} { |
---|
569 | SetDXTLatoms |
---|
570 | if {[llength $::expmap(phaselist)] > 1} { |
---|
571 | # there is more than one phase; delete any .grd files to make sure |
---|
572 | # generate ones for the current phase |
---|
573 | foreach f [glob -nocomplain "[file root $::expgui(expfile)]*.grd"] { |
---|
574 | catch {file delete -force $f} |
---|
575 | } |
---|
576 | } |
---|
577 | SetupFourierButtons |
---|
578 | eval destroy [winfo children $::DXTL(fb)] |
---|
579 | set ::DXTL(contours) 0 |
---|
580 | } |
---|
581 | |
---|
582 | # this enables/disables Fourier buttons based on the Fourier setup |
---|
583 | # and the files that are present |
---|
584 | proc SetupFourierButtons {} { |
---|
585 | if {[catch { |
---|
586 | set phase $::expgui(export_phase) |
---|
587 | $::DXTL(FourCompute) config -state disabled |
---|
588 | $::DXTL(AddContour) config -state disabled |
---|
589 | $::DXTL(fmenu) delete 0 end |
---|
590 | }]} return |
---|
591 | set ::DXTL(mtype) "" |
---|
592 | set ::DXTL(mfil) "" |
---|
593 | set ::DXTL(FourierRange) "" |
---|
594 | # if the Fourier is not set up; return here |
---|
595 | if {[llength [set nF [listFourier]]] < 1} return |
---|
596 | # check that all phases are set to current phase |
---|
597 | foreach i $nF { |
---|
598 | set ph [Fourierinfo $i phase] |
---|
599 | if {$ph != $phase} return |
---|
600 | } |
---|
601 | if {[llength [FourierHists $phase]] < 1} return |
---|
602 | # make sure we have default limits |
---|
603 | getFourierLimits $phase |
---|
604 | $::DXTL(FourCompute) config -state normal |
---|
605 | # if there are no maps, return now |
---|
606 | set maps [glob -nocomplain "[file root $::expgui(expfile)]*.grd"] |
---|
607 | if {[llength $maps] < 1} return |
---|
608 | set types {} |
---|
609 | foreach fil $maps { |
---|
610 | lappend types [lindex [split [file root [file tail $fil]] "_"] end] |
---|
611 | } |
---|
612 | set i 0 |
---|
613 | foreach fil $maps lbl $types { |
---|
614 | $::DXTL(fmenu) add command -label $lbl \ |
---|
615 | -command "set DXTL(mtype) $lbl; set DXTL(mfil) $fil; GetFourierRange" |
---|
616 | if {$i == 0} { |
---|
617 | $::DXTL(fmenu) invoke 0 |
---|
618 | $::DXTL(AddContour) config -state normal |
---|
619 | } |
---|
620 | incr i |
---|
621 | } |
---|
622 | } |
---|
623 | |
---|
624 | proc AddContour {} { |
---|
625 | # set a header |
---|
626 | if {$::DXTL(contours) == 0} { |
---|
627 | set row 0 |
---|
628 | grid [label $::DXTL(fb).a$row -text "Type" -bg yellow \ |
---|
629 | ] -column 1 -row $row -sticky ew |
---|
630 | grid [label $::DXTL(fb).b$row -text "Contour Level" -bg yellow \ |
---|
631 | ] -column 2 -row $row -sticky ew |
---|
632 | grid [label $::DXTL(fb).c$row -text "Color" -bg yellow \ |
---|
633 | -anchor center] -column 3 -row $row -sticky ew |
---|
634 | } |
---|
635 | set row [incr ::DXTL(contours)] |
---|
636 | eval tk_optionMenu $::DXTL(fb).ta$row ::DXTL(fb_type_$row) {mesh solid} |
---|
637 | grid $::DXTL(fb).ta$row -column 1 -row $row |
---|
638 | grid [entry $::DXTL(fb).w$row -width 10 -textvariable ::DXTL(fb_val_$row) \ |
---|
639 | ] -column 2 -row $row |
---|
640 | set menu [eval tk_optionMenu $::DXTL(fb).tb$row \ |
---|
641 | ::DXTL(fb_color_$row) $::DXTLcolorlist] |
---|
642 | $menu invoke $row |
---|
643 | grid $::DXTL(fb).tb$row -column 3 -row $row |
---|
644 | grid [button $::DXTL(fb).del$row -text "Delete"\ |
---|
645 | -command "DeleteFourierContour $row"] -column 4 -row $row |
---|
646 | update idletasks |
---|
647 | set sizes [grid bbox $::DXTL(fb)] |
---|
648 | [winfo parent $::DXTL(fb)] config -scrollregion $sizes \ |
---|
649 | -width [lindex $sizes 2] |
---|
650 | } |
---|
651 | |
---|
652 | proc DeleteFourierContour {row} { |
---|
653 | foreach i "$::DXTL(fb).ta$row $::DXTL(fb).w$row $::DXTL(fb).tb$row \ |
---|
654 | $::DXTL(fb).tb$row $::DXTL(fb).del$row" { |
---|
655 | catch {destroy $i} |
---|
656 | } |
---|
657 | set ::DXTL(fb_val_$i) "" |
---|
658 | if {$::DXTL(contours) == $row} {incr ::DXTL(contours) -1} |
---|
659 | } |
---|
660 | |
---|
661 | proc GetFourierRange {} { |
---|
662 | set fp [open f.in w] |
---|
663 | set lst [listFourier] |
---|
664 | if {[llength $lst] < 1} { |
---|
665 | MyMessageBox -parent . -title "No Fourier" \ |
---|
666 | -message "You have not set up to compute a Fourier map." \ |
---|
667 | -icon warning |
---|
668 | return |
---|
669 | } |
---|
670 | set typelist {} |
---|
671 | foreach l $lst { |
---|
672 | lappend typelist [Fourierinfo $l type] |
---|
673 | } |
---|
674 | if {[OutputFourierType]} { |
---|
675 | puts $fp $::DXTL(mtype) |
---|
676 | } |
---|
677 | close $fp |
---|
678 | if {$::tcl_platform(platform) == "windows"} { |
---|
679 | set map [file join $::expgui(gsasexe) forsrh.exe] |
---|
680 | } else { |
---|
681 | set map [file join $::expgui(gsasexe) forsrh] |
---|
682 | } |
---|
683 | catch { |
---|
684 | exec $map [file root $::expgui(expfile)] < f.in >& f.out |
---|
685 | } |
---|
686 | foreach {min max} {{} {}} {} |
---|
687 | catch { |
---|
688 | set fp [open "f.out" r] |
---|
689 | while {[gets $fp line] >= 0} { |
---|
690 | if {[string first "range of map values" $line] != -1} { |
---|
691 | set off [expr 4 + [string first " is " $line]] |
---|
692 | foreach {min to max} [string trim [string range $line $off end]] {} |
---|
693 | break |
---|
694 | } |
---|
695 | } |
---|
696 | } |
---|
697 | catch { |
---|
698 | close $fp |
---|
699 | } |
---|
700 | if {$min != ""} {set ::DXTL(FourierRange) "Range: $min to $max"} |
---|
701 | } |
---|
702 | |
---|
703 | # is output of the current Fourier map type required as input to a program? |
---|
704 | # answer is yes when more than one map file is present |
---|
705 | proc OutputFourierType {} { |
---|
706 | set i 0 |
---|
707 | foreach ext {DEL FCL FOB PTS DPT} { |
---|
708 | if {[file exists [file root $::expgui(expfile)].$ext]} { |
---|
709 | incr i |
---|
710 | } |
---|
711 | for {set i 2} {$i <= 9} {incr i} { |
---|
712 | if {[file exists [file root $::expgui(expfile)].${i}FD]} { |
---|
713 | incr i |
---|
714 | } |
---|
715 | } |
---|
716 | } |
---|
717 | if {$i > 1} { |
---|
718 | return 1 |
---|
719 | } |
---|
720 | return 0 |
---|
721 | } |
---|
722 | |
---|
723 | proc DXTLwriteFourierCommands {fp} { |
---|
724 | if {$::DXTL(mfil) == ""} return |
---|
725 | if {![file exists $::DXTL(mfil)]} { |
---|
726 | puts "file not found $::DXTL(mfil)" |
---|
727 | return |
---|
728 | } |
---|
729 | set cntlist {} |
---|
730 | for {set i 1} {$i <= $::DXTL(contours)} {incr i} { |
---|
731 | set val "" |
---|
732 | catch {set val $::DXTL(fb_val_$i)} |
---|
733 | if {[catch {set val [expr 1.*$val]}]} continue |
---|
734 | lappend cntlist [list $val $::DXTL(fb_type_$i) $::DXTL(fb_color_$i)] } |
---|
735 | if {[llength $cntlist] <= 0} return |
---|
736 | puts $fp "mapread grd [file tail $::DXTL(mfil)] 4" |
---|
737 | foreach item $cntlist { |
---|
738 | puts $fp "mapcontour $item" |
---|
739 | } |
---|
740 | set s {} |
---|
741 | foreach a {X Y Z} { |
---|
742 | lappend s $::DXTL(${a}dispMin) |
---|
743 | lappend s $::DXTL(${a}dispMax) |
---|
744 | } |
---|
745 | puts $fp "mapregion $s" |
---|
746 | } |
---|