source: trunk/export_drawxtl.tcl @ 919

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

# on 2005/09/07 21:26:38, toby did:
fix use of delete window decoration (== quit)
fix display arrows options; warn on old GEOMETRY program
use .drawxtlrc to find DRAWXTL5.x program
  • Property rcs:author set to toby
  • Property rcs:date set to 2005/09/07 21:26:38
  • Property rcs:lines set to +32 -21
  • Property rcs:rev set to 1.3
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 14.7 KB
Line 
1# export a phase to DRAWXTL
2#
3# $Id: export_drawxtl.tcl 846 2009-12-04 23:13:03Z toby $
4# set local variables that define the proc to execute and the menu label
5set label "export to DRAWXTL (.str) file"
6set action export_drawxtl
7proc export_drawxtl {} {
8    global expmap expgui
9    # don't bother if there are no phases to write
10    if {[llength $expmap(phaselist)] == 0} {
11        MyMessageBox -parent . -title "No phases" \
12                -message "Sorry, no phases are present to write" \
13                -icon warning
14        return
15    }
16    foreach t [trace vinfo expgui(export_phase)] {
17        eval trace vdelete expgui(export_phase) $t
18    }
19     MakeExportBox .export "Export coordinates to program DRAWXTL" ""
20#           "MakeWWWHelp expgui.html export"
21
22    # force the window to stay on top
23    putontop .export
24    # trigger a quit on window delete
25    wm protocol .export WM_DELETE_WINDOW {set expgui(export_phase) 0; destroy .export }
26    set bx .export.special
27    global DXTL
28    if {[info global DXTL] == ""} {
29        set DXTL(bonds) 0
30        set DXTL(coords) 1
31        set DXTL(blackarrow) Green
32        set DXTL(redarrow) Red
33    }
34    set row 1
35    grid [label $bx.1 -text "Title:"] -column 1 -row $row -sticky e
36    grid [entry $bx.2 -textvariable DXTL(title) -width 40] \
37        -row $row -column 2 -columnspan 5 -sticky w
38    set DXTL(title) [expinfo title]
39    incr row
40    grid [checkbutton $bx.3 -text "Include coordinates in .str file" \
41              -variable DXTL(coords)] \
42        -row $row -column 1 -columnspan 5 -sticky w
43    incr row
44    set DXTL(arrowbox) $bx.4
45    grid [checkbutton $bx.4 -text "Display arrows for magnetic atoms" \
46              -variable DXTL(genarrows) -state disabled] \
47        -row $row -column 1 -columnspan 5 -sticky w
48    incr row
49    set colorlist "White Red Green Blue Yellow Cyan Magenta Black Orange Brown Grey Silver White"
50    set DXTL(arrowcolorbox) $bx.4a
51    set DXTL(arrowcolorbox_row) $row
52    grid [frame $bx.4a] -sticky ew -row $DXTL(arrowcolorbox_row) \
53        -column 1 -columnspan 5 
54    grid [label $bx.4a.h -text "Arrow colors: "] -column 0 -row 1 -sticky w
55    grid [label $bx.4a.bll -text "   generated by Black operator "] -column 0 -row 2
56    eval tk_optionMenu $bx.4a.bl DXTL(blackarrow) $colorlist
57    grid $bx.4a.bl -column 2 -row 2
58    grid [label $bx.4a.redl -text "  generated by Red operator "] -column 0 -row 3
59    eval tk_optionMenu $bx.4a.red DXTL(redarrow) $colorlist
60    grid $bx.4a.red -column 2 -row 3
61    incr row
62    # is DRAWxtl installed?
63    set app {}
64    if {![catch {set fp [open [file join $::env(HOME) .drawxtlrc] r]}]} {
65        # line 12 is name of executable
66        set i 0
67        while {$i < 12} {
68            incr i
69            gets $fp appname
70        }
71        close $fp
72        set app [auto_execok $appname]
73    }
74    if {$app != ""} {
75        set show normal
76        set DXTL(app) $appname
77        set DXTL(launch) 1
78    } else {
79        set show disabled
80        set DXTL(launch) 0
81    }
82    grid [checkbutton $bx.l -text "Launch DRAWxtl" \
83              -variable DXTL(launch) -state $show] \
84        -row $row -column 1 -columnspan 5 -sticky w
85    incr row
86    grid [frame $bx.c -relief groove -bd 4] -row $row -column 0 -columnspan 5
87    grid [label $bx.c.0 -text "Range of fractional coordinates to include" \
88              -anchor center] -row 0 -column 0 -columnspan 8
89    foreach v {x y z} V {X Y Z} {
90        incr row
91        grid [label $bx.c.${v}1 -text "${V} min:"] -column 1 -row $row
92        grid [entry $bx.c.${v}2 -textvariable DXTL(${v}min) -width 4] -column 2 -row $row
93        grid [scale $bx.c.${v}3 -resolution 0.1 -variable DXTL(${v}min) \
94                  -showvalue 0 -orient h -from -2 -to 1] -column 3 -row $row
95        set DXTL(${v}min) -0.1
96        grid [label $bx.c.${v}4 -text " max:"] -column 4 -row $row
97        grid [entry $bx.c.${v}5 -textvariable DXTL(${v}max) -width 4] -column 5 -row $row
98        grid [scale $bx.c.${v}6 -resolution 0.1 -variable DXTL(${v}max) \
99                  -showvalue 0 -orient h -from 0 -to 3] -column 6 -row $row
100        set DXTL(${v}max) 1.1
101    }
102    # atom type box
103    grid [frame $bx.s -relief groove -bd 4] -row $row -column 0 -columnspan 5 -sticky nsew
104    grid [label $bx.s.0 -text "Atom representation" \
105              -anchor w] -row 0 -column 0 -sticky w
106    grid [canvas $bx.s.canvas -relief sunk -bd 2 \
107              -scrollregion {0 0 5000 500} -width 250 -height 70 \
108              -yscrollcommand "$bx.s.scroll set" ] \
109        -column 0 -row [incr row] -sticky nsew
110    grid columnconfig $bx.s 0 -weight 1
111    frame [set DXTL(lb) $bx.s.canvas.fr]
112    $bx.s.canvas create window 0 0 -anchor nw -window $DXTL(lb)
113    grid [scrollbar $bx.s.scroll \
114              -command "$bx.s.canvas yview"] -sticky ns -row $row -column 1
115    # bond box
116    incr row
117    grid [frame $bx.b -relief groove -bd 4] -row $row -column 0 -columnspan 5 -sticky ew
118    grid [frame $bx.b.0] -row 0 -column 0 -columnspan 7 -sticky ew
119    grid [label $bx.b.0.1 -text "Bond List" \
120              -anchor w] -row 0 -column 0 -sticky w
121    grid columnconfig $bx.b.0 0 -weight 1
122    grid [button $bx.b.0.b -text "Add Bond" -command DXTLaddBond \
123             ] -row 0 -column 1 -sticky e
124    grid [canvas $bx.b.canvas -relief sunk -bd 2 \
125              -scrollregion {0 0 5000 500} -width 250 -height 70 \
126              -yscrollcommand "$bx.b.scroll set" ] \
127        -column 0 -row [incr row] -sticky nsew
128    grid columnconfig $bx.b 0 -weight 1
129    frame [set DXTL(Blst) $bx.b.canvas.fr]
130    $bx.b.canvas create window 0 0 -anchor nw -window $DXTL(Blst)
131    grid [scrollbar $bx.b.scroll \
132              -command "$bx.b.canvas yview"] -sticky ns -row $row -column 1
133
134    trace variable expgui(export_phase) w SetDXTLatoms
135    SetDXTLatoms
136    # this appears to be needed by OSX
137    ResizeWin .export
138
139    # Wait for the Write or Quit button to be pressed
140    tkwait window .export
141    afterputontop
142    # test for Quit
143    if {$expgui(export_phase) == 0} {return}
144
145    # now open the file and write it
146    set phase $expgui(export_phase)
147    if [catch {
148        set filnam [file rootname $expgui(expfile)]_${phase}.str
149        set fp [open $filnam w]
150        # deal with macromolecular phases
151        if {[lindex $expmap(phasetype) [expr {$phase - 1}]] == 4} {
152            MyMessageBox -parent . -title "MM phase" \
153                -message "Sorry, macromolecular phases cannot be processed" \
154                -icon warning
155            return
156        }
157        catch {unset typelist}
158        foreach atom $expmap(atomlist_$phase) {
159            set typelist([atominfo $phase $atom type]) 1
160        }
161        # title info from GSAS title & phase title
162        puts $fp "REM  created by EXPGUI from $expgui(expfile) on [clock format [clock seconds]]"
163        puts $fp "title \"$DXTL(title)\""
164        puts $fp "pack $DXTL(xmin) $DXTL(xmax) $DXTL(ymin) $DXTL(ymax) $DXTL(zmin) $DXTL(zmax)"
165        puts $fp "edges 0.02 Black"
166        puts $fp "phong 1.0 30."
167        foreach type [array names typelist] {
168            if {$DXTL(display_$type) == "sphere"} {
169                puts $fp "sphere $type $DXTL(radius_$type) $DXTL(color_$type)"
170            } elseif {$DXTL(display_$type) == "polyhedron"} {
171                puts $fp "polysz $type $DXTL(radius_$type) $DXTL(color_$type)"
172            } elseif {$DXTL(display_$type) == "ellipsoid"} {
173                puts $fp "ellipcolor $type * $DXTL(color_$type)"
174            }
175        }
176        if {$DXTL(coords)} {
177            # write out cell parameters
178            puts -nonewline $fp "cell"
179            foreach p {a b c alpha beta gamma} {
180                puts -nonewline $fp " [phaseinfo $phase $p]"
181            }
182            puts $fp ""
183            # write out GSAS spacegroup
184            puts $fp "spgp [phaseinfo $phase spacegroup]"
185            # now loop over atoms
186            foreach atom $expmap(atomlist_$phase) {
187                puts -nonewline $fp "atom [atominfo $phase $atom type] $atom "
188                foreach v {x y z} {
189                    puts -nonewline $fp "[atominfo $phase $atom $v] "
190                }
191                puts $fp ""
192               
193                set uiso [atominfo $phase $atom Uiso]
194                # are there anisotropic atoms? If so convert them to Uequiv
195                if {[atominfo $phase $atom temptype] == "A"} {
196                    puts -nonewline $fp "Uij [atominfo $phase $atom type] $atom "
197                    foreach v {U11 U22 U33 U12 U13 U23} {
198                        puts -nonewline $fp "[atominfo $phase $atom $v] "
199                    }
200                    puts $fp ""
201                }
202            }
203        } else {
204            puts $fp "import gsas [file tail $expgui(expfile)] $phase"
205        }
206        for {set i 1} {$i <= $DXTL(bonds)} {incr i} {
207            puts $fp "bond $DXTL(ba_$i) $DXTL(bb_$i) $DXTL(bw_$i) $DXTL(bmin_$i) $DXTL(bmax_$i) $DXTL(bc_$i)"
208        }
209        # list arrows, when requested
210        if {[lindex $expmap(phasetype) [expr {$phase - 1}]] != 1 && \
211                $DXTL(genarrows)} {
212            DXTLwriteArrows $fp $phase
213        }
214        puts $fp "END"
215        close $fp
216        if {$DXTL(launch)} {
217            exec $DXTL(app) $filnam &
218        }
219    } errmsg] {
220        MyMessageBox -parent . -title "Export error" \
221                -message "Export error: $errmsg" -icon warning
222    } else {
223        MyMessageBox -parent . -title "Done" \
224                -message "File [file tail $filnam] was written"
225    }
226    catch {unset DXTL}
227    foreach t [trace vinfo expgui(export_phase)] {
228        eval trace vdelete expgui(export_phase) $t
229    }
230 }
231
232# resize windows -- this appears to be needed by OSX 10.2
233proc ResizeWin {win} {
234    update
235    wm geom $win [winfo reqwidth $win]x[winfo reqheight $win]
236    # center the EXPGUI window
237    wm withdraw $win
238    set x [expr [winfo screenwidth $win]/2 - [winfo reqwidth $win]/2 ]
239    set y [expr [winfo screenheight $win]/2 - [winfo reqheight $win]/2]
240    wm geom $win +$x+$y
241    wm deiconify $win
242}
243
244
245# add atoms to atom representation list
246proc SetDXTLatoms {args} {
247    global DXTL expgui expmap
248    set colorlist "White Red Green Blue Yellow Cyan Magenta Black Orange Brown Grey Silver White"
249    eval destroy [winfo children $DXTL(lb)]
250    eval destroy [winfo children $DXTL(Blst)]
251    set DXTL(bonds) 0
252    if {$expgui(export_phase) == 0} {return}
253    set phase $expgui(export_phase)
254    if {[lindex $expmap(phasetype) [expr {$phase - 1}]] == 4} {
255        MyMessageBox -parent . -title "MM phase" \
256            -message "Sorry, macromolecular phases cannot be processed" \
257            -icon warning
258        return
259    }
260    if {[lindex $expmap(phasetype) [expr {$phase - 1}]] == 1} {
261        set DXTL(genarrows) 0
262        $DXTL(arrowbox) configure -state disabled
263        grid forget $DXTL(arrowcolorbox) 
264    } else {
265        set DXTL(genarrows) 1
266        $DXTL(arrowbox) configure -state normal
267        grid $DXTL(arrowcolorbox) -sticky ew -row $DXTL(arrowcolorbox_row) \
268            -column 1 -columnspan 5
269    }
270    catch {unset typelist}
271    set DXTL(title)  [phaseinfo $phase name]
272    foreach atom $expmap(atomlist_$phase) {
273        set typelist([atominfo $phase $atom type]) 1
274    }
275    set DXTL(typelist) [array names typelist]
276    set row 0
277    grid [label $DXTL(lb).l$row -text "type " -bg yellow\
278             ] -column 0 -row $row  -sticky ew
279    grid [label $DXTL(lb).d$row -text " representation " -bg yellow
280         ] -column 1 -row $row -sticky ew
281    grid [label $DXTL(lb).e$row -text " radius " -bg yellow\
282             ] -column 2 -row $row -sticky ew
283    grid [label $DXTL(lb).c$row -text " color " -bg yellow\
284             ] -column 3 -row $row -sticky ew
285    foreach type [array names typelist] {
286        incr row
287        grid [label $DXTL(lb).l$row -text $type] -column 0 -row $row
288        tk_optionMenu $DXTL(lb).d$row DXTL(display_$type) sphere polyhedron ellipsoid none
289        grid $DXTL(lb).d$row -column 1 -row $row
290        grid [entry $DXTL(lb).e$row -textvariable DXTL(radius_$type) \
291                -width 5] -column 2 -row $row
292        eval tk_optionMenu $DXTL(lb).c$row DXTL(color_$type) $colorlist
293        grid $DXTL(lb).c$row -column 3 -row $row
294        set DXTL(display_$type) sphere
295        set DXTL(radius_$type) 0.2
296        set DXTL(color_$type) [lindex $colorlist $row]
297    }
298    # Resize the list
299    update
300    set sizes [grid bbox $DXTL(lb)]
301    [winfo parent $DXTL(lb)] config -scrollregion $sizes \
302        -width [lindex $sizes 2]
303    set sizes [grid bbox $DXTL(Blst)]
304    [winfo parent $DXTL(Blst)] config -scrollregion $sizes \
305        -width [lindex $sizes 2]
306    wm geom [winfo toplevel $DXTL(Blst)] {}
307}
308
309# add bonds to bond list
310proc DXTLaddBond {} {
311    global DXTL
312    set colorlist "White Red Green Blue Yellow Cyan Magenta Black Orange Brown Grey Silver White"
313
314    if {$DXTL(bonds) == 0} {
315        # insert header
316        set row 0
317        grid [label $DXTL(Blst).a$row -text "from " -bg yellow\
318                 ] -column 1 -row $row  -sticky ew
319        grid [label $DXTL(Blst).b$row -text " to " -bg yellow\
320                 ] -column 2 -row $row  -sticky ew
321        grid [label $DXTL(Blst).c$row -text " width " -bg yellow\
322                 ] -column 3 -row $row  -sticky ew
323        grid [label $DXTL(Blst).d$row -text " min " -bg yellow\
324             ] -column 4 -row $row  -sticky ew
325        grid [label $DXTL(Blst).e$row -text " max " -bg yellow\
326                 ] -column 5 -row $row  -sticky ew
327        grid [label $DXTL(Blst).f$row -text " color " -bg yellow\
328                 ] -column 6 -row $row  -sticky ew
329    }
330    set row [incr DXTL(bonds)]
331    eval tk_optionMenu $DXTL(Blst).ta$row DXTL(ba_$row) $DXTL(typelist)
332    grid $DXTL(Blst).ta$row -column 1 -row $row
333    eval tk_optionMenu $DXTL(Blst).tb$row DXTL(bb_$row) $DXTL(typelist)
334    grid $DXTL(Blst).tb$row -column 2 -row $row
335    grid [entry $DXTL(Blst).w$row -textvariable DXTL(bw_$row) \
336              -width 5] -column 3 -row $row
337    grid [entry $DXTL(Blst).mi$row -textvariable DXTL(bmin_$row) \
338              -width 5] -column 4 -row $row
339    grid [entry $DXTL(Blst).mx$row -textvariable DXTL(bmax_$row) \
340              -width 5] -column 5 -row $row
341    eval tk_optionMenu $DXTL(Blst).c$row DXTL(bc_$row) $colorlist
342    grid $DXTL(Blst).c$row -column 6 -row $row
343    set DXTL(bw_$row) 0.02
344    set DXTL(bmin_$row) 1.0
345    set DXTL(bmax_$row) 2.0
346    set DXTL(bc_$row) [lindex $colorlist $row]
347    # Resize the list
348    update
349    set sizes [grid bbox $DXTL(Blst)]
350    [winfo parent $DXTL(Blst)] config -scrollregion $sizes \
351        -width [lindex $sizes 2]
352}
353
354proc DXTLwriteArrows {out phase} {
355    global expgui expmap DXTL
356    set fp [open geom.in w]
357    puts $fp "N"
358    puts $fp "M"
359    if {[llength $expmap(phaselist)] > 1} {
360        puts $fp "$phase"
361    }
362    puts $fp "N"
363    puts $fp "X"
364    close $fp
365    catch {
366        if {$::tcl_platform(platform) == "windows"} {
367            exec [file join $expgui(gsasexe) geometry.exe] \
368                [file root $expgui(expfile)] < geom.in >& geom.out
369        } else {
370            exec [file join $expgui(gsasexe) geometry] \
371                [file root $expgui(expfile)] < geom.in >& geom.out
372        }
373        set fp [open geom.out r]
374        while {[gets $fp line] >= 0} {
375            if {[string match "*Geometry*,L,N,*" $line]} {
376                MyMessageBox -parent . -title "Old GSAS" \
377                    -message "Old GEOMETRY program: You are using an old version of GSAS that cannot export magnetic vectors. Upgrade GSAS to generate arrows." -icon warning
378                break
379            }
380            if {[string match "*name*elem*x *y *z*x *y *z*" $line]} {break}
381        }
382        set i 0
383        while {[gets $fp line] >= 0} {
384            if {[string match "*Enter Geometry option*" $line]} {break}
385            incr i
386            if {$i == 2} {
387                set name [string trim [string range $line 5 12]]
388                set tail [string trim [string range $line 22 end]]
389                set pos [lrange $tail 0 2]
390                set spin [lindex $tail end]
391            } elseif {$i == 5} {
392                set vec [string trim [string range $line 22 end]]
393                if {[catch {set count($name)}]} {set count($name) 0}
394                catch {
395                    set k ?
396                    incr count($name)
397                    set k $count($name)
398                }
399                puts $out "rem spin for atom $name # $k ($spin)"
400                if {$spin == "Red"} {
401                    puts $out "arrow $pos     $vec    1. 0.15 $DXTL(redarrow)"
402                } else {
403                    puts $out "arrow $pos     $vec    1. 0.15 $DXTL(blackarrow)"
404                }
405            } elseif {$i == 6} {
406                set i 1
407            }
408        }
409    }
410    catch {close $fp}
411    catch {file delete -force geom.in geom.out}
412    puts $out "mag_trans 1. 0 0  0 1. 0  0 0 1."
413}
Note: See TracBrowser for help on using the repository browser.