source: branches/sandbox/export_drawxtl.tcl @ 1220

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

fix chem constrain add row bug; Add Fourier to export_drawxtl; new param on MakeExportBox? -- not used?
  • Property svn:keywords set to Author Date Revision Id
File size: 29.7 KB
Line 
1# export a phase to DRAWXTL
2#
3# $Id: export_drawxtl.tcl 1220 2012-08-26 23:51:47Z 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
7set ::DXTLcolorlist "White Red Green Blue Yellow Cyan Magenta Black Orange Brown Grey Silver White"
8set ::DXTL(bonds) 0
9set ::DXTL(coords) 1
10set ::DXTL(blackarrow) Green
11set ::DXTL(redarrow) Red
12foreach a {X Y Z} {
13    set ::DXTL(${a}dispMin) 0.0
14    set ::DXTL(${a}dispMax) 1.0
15}
16set ::DXTL(mtype) ""
17set ::DXTL(mfil) ""
18set ::DXTL(FourierRange) ""
19
20proc 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] -column 0 -row 0
165    grid [button [set ::DXTL(FourCompute) $bx.f.1.2] -text "Compute\nFourier" \
166              -command {DXTLwritegrd $expgui(export_phase)}] -column 1 -row 0
167    grid [label $bx.f.1.3 -text "Select\nMap"] -column 3 -row 0
168    set ::DXTL(fmenu) [tk_optionMenu $bx.f.1.4 ::DXTL(mtype) test]
169    grid $bx.f.1.4 -column 4 -row 0
170    grid [button [set ::DXTL(AddContour) $bx.f.1.5] -text "Add\nContour" \
171              -command AddContour] -column 5 -row 0
172    grid [frame $bx.f.1.f] -column 0 -columnspan 9 -row 1
173    grid [label $bx.f.1.f.0 -text "display\nlimits"] -column 0 -row 0
174    set col 0
175    foreach a {X Y Z} {
176        incr col
177        grid [label $bx.f.1.f.$col -text $a] -column $col -row 0
178        incr col
179        grid [entry $bx.f.1.f.$col -textvariable ::DXTL(${a}dispMin) \
180                  -width 6] -column $col -row 0
181        incr col
182        grid [entry $bx.f.1.f.$col -textvariable ::DXTL(${a}dispMax) \
183                  -width 6] -column $col -row 0
184    }
185    set ::DXTL(contours) 0
186    trace variable ::expgui(export_phase) w OnNewFourierPhase
187    OnNewFourierPhase
188#SetupFourierButtons
189#return
190    # this appears to be needed by OSX
191    ResizeWin .export
192    # force the window to stay on top
193    putontop .export
194    SetDXTLatoms
195
196    # Wait for the Write or Quit button to be pressed
197    tkwait window .export
198    afterputontop
199    # test for Quit
200    if {$expgui(export_phase) == 0} {return}
201
202    # now open the file and write it
203    set phase $expgui(export_phase)
204    if [catch {
205        set filnam [file rootname $expgui(expfile)]_${phase}.str
206        set fp [open $filnam w]
207        # deal with macromolecular phases
208        if {[lindex $expmap(phasetype) [expr {$phase - 1}]] == 4} {
209            MyMessageBox -parent . -title "MM phase" \
210                -message "Sorry, macromolecular phases cannot be processed" \
211                -icon warning
212            return
213        }
214        catch {unset typelist}
215        foreach atom $expmap(atomlist_$phase) {
216            set typelist([atominfo $phase $atom type]) 1
217        }
218        # title info from GSAS title & phase title
219        puts $fp "REM  created by EXPGUI from $expgui(expfile) on [clock format [clock seconds]]"
220        puts $fp "title \"$::DXTL(title)\""
221        puts $fp "pack $::DXTL(xmin) $::DXTL(xmax) $::DXTL(ymin) $::DXTL(ymax) $::DXTL(zmin) $::DXTL(zmax)"
222        puts $fp "edges 0.02 Black"
223        puts $fp "phong 1.0 30."
224        foreach type [array names typelist] {
225            if {$::DXTL(display_$type) == "sphere"} {
226                puts $fp "sphere $type $::DXTL(radius_$type) $::DXTL(color_$type)"
227            } elseif {$::DXTL(display_$type) == "polyhedron"} {
228                puts $fp "polysz $type $::DXTL(radius_$type) $::DXTL(color_$type)"
229            } elseif {$::DXTL(display_$type) == "ellipsoid"} {
230                puts $fp "ellipcolor $type * $::DXTL(color_$type)"
231            }
232        }
233        if {$::DXTL(coords)} {
234            # write out cell parameters
235            puts -nonewline $fp "cell"
236            foreach p {a b c alpha beta gamma} {
237                puts -nonewline $fp " [phaseinfo $phase $p]"
238            }
239            puts $fp ""
240            # write out GSAS spacegroup
241            puts $fp "spgp [phaseinfo $phase spacegroup]"
242            # now loop over atoms
243            foreach atom $expmap(atomlist_$phase) {
244                puts -nonewline $fp "atom [atominfo $phase $atom type] $atom "
245                foreach v {x y z} {
246                    puts -nonewline $fp "[atominfo $phase $atom $v] "
247                }
248                puts $fp ""
249               
250                set uiso [atominfo $phase $atom Uiso]
251                # are there anisotropic atoms? If so convert them to Uequiv
252                if {[atominfo $phase $atom temptype] == "A"} {
253                    puts -nonewline $fp "Uij [atominfo $phase $atom type] $atom "
254                    foreach v {U11 U22 U33 U12 U13 U23} {
255                        puts -nonewline $fp "[atominfo $phase $atom $v] "
256                    }
257                    puts $fp ""
258                }
259            }
260        } else {
261            puts $fp "import gsas [file tail $expgui(expfile)] $phase"
262        }
263        for {set i 1} {$i <= $::DXTL(bonds)} {incr i} {
264            puts $fp "bond $::DXTL(ba_$i) $::DXTL(bb_$i) $::DXTL(bw_$i) $::DXTL(bmin_$i) $::DXTL(bmax_$i) $::DXTL(bc_$i)"
265        }
266        # list arrows, when requested
267        if {[lindex $expmap(phasetype) [expr {$phase - 1}]] != 1 && \
268                $::DXTL(genarrows)} {
269            DXTLwriteArrows $fp $phase
270        }
271        DXTLwriteFourierCommands $fp
272        puts $fp "END"
273        close $fp
274        if {$::DXTL(launch)} {
275            exec $::DXTL(app) $filnam &
276        }
277    } errmsg] {
278        MyMessageBox -parent . -title "Export error" \
279                -message "Export error: $errmsg" -icon warning
280    } else {
281        MyMessageBox -parent . -title "Done" \
282                -message "File [file tail $filnam] was written"
283    }
284    #catch {unset DXTL}
285    foreach t [trace vinfo expgui(export_phase)] {
286        eval trace vdelete expgui(export_phase) $t
287    }
288 }
289
290# resize windows -- this appears to be needed by OSX 10.2
291proc ResizeWin {win} {
292    update
293    wm geom $win [winfo reqwidth $win]x[winfo reqheight $win]
294    # center the EXPGUI window
295    wm withdraw $win
296    set x [expr [winfo screenwidth $win]/2 - [winfo reqwidth $win]/2 ]
297    set y [expr [winfo screenheight $win]/2 - [winfo reqheight $win]/2]
298    wm geom $win +$x+$y
299    wm deiconify $win
300}
301
302
303# add atoms to atom representation list
304proc SetDXTLatoms {args} {
305    global expgui expmap
306    eval destroy [winfo children $::DXTL(lb)]
307    eval destroy [winfo children $::DXTL(Blst)]
308    set ::DXTL(bonds) 0
309    if {$expgui(export_phase) == 0} {return}
310    set phase $expgui(export_phase)
311    if {[lindex $expmap(phasetype) [expr {$phase - 1}]] == 4} {
312        MyMessageBox -parent . -title "MM phase" \
313            -message "Sorry, macromolecular phases cannot be processed" \
314            -icon warning
315        return
316    }
317    if {[lindex $expmap(phasetype) [expr {$phase - 1}]] == 1} {
318        set ::DXTL(genarrows) 0
319        $::DXTL(arrowbox) configure -state disabled
320        grid forget $::DXTL(arrowcolorbox) 
321    } else {
322        set ::DXTL(genarrows) 1
323        $::DXTL(arrowbox) configure -state normal
324        grid $::DXTL(arrowcolorbox) -sticky ew -row $::DXTL(arrowcolorbox_row) \
325            -column 1 -columnspan 5
326    }
327    catch {unset typelist}
328    set ::DXTL(title)  [phaseinfo $phase name]
329    foreach atom $expmap(atomlist_$phase) {
330        set typelist([atominfo $phase $atom type]) 1
331    }
332    set ::DXTL(typelist) [array names typelist]
333    set row 0
334    grid [label $::DXTL(lb).l$row -text "type " -bg yellow\
335             ] -column 0 -row $row  -sticky ew
336    grid [label $::DXTL(lb).d$row -text " representation " -bg yellow
337         ] -column 1 -row $row -sticky ew
338    grid [label $::DXTL(lb).e$row -text " radius " -bg yellow\
339             ] -column 2 -row $row -sticky ew
340    grid [label $::DXTL(lb).c$row -text " color " -bg yellow\
341             ] -column 3 -row $row -sticky ew
342    foreach type [array names typelist] {
343        incr row
344        grid [label $::DXTL(lb).l$row -text $type] -column 0 -row $row
345        tk_optionMenu $::DXTL(lb).d$row ::DXTL(display_$type) sphere polyhedron ellipsoid none
346        grid $::DXTL(lb).d$row -column 1 -row $row
347        grid [entry $::DXTL(lb).e$row -textvariable ::DXTL(radius_$type) \
348                -width 5] -column 2 -row $row
349        eval tk_optionMenu $::DXTL(lb).c$row ::DXTL(color_$type) $::DXTLcolorlist
350        grid $::DXTL(lb).c$row -column 3 -row $row
351        set ::DXTL(display_$type) sphere
352        set ::DXTL(radius_$type) 0.2
353        set ::DXTL(color_$type) [lindex $::DXTLcolorlist $row]
354    }
355    # Resize the list
356    update idletasks
357    foreach i {lb Blst fb} {
358        set sizes [grid bbox $::DXTL($i)]
359        [winfo parent $::DXTL($i)] config -scrollregion $sizes  \
360            -width [lindex $sizes 2]
361    }
362    wm geom [winfo toplevel $::DXTL(Blst)] {}
363}
364
365# add bonds to bond list
366proc DXTLaddBond {} {
367    if {$::DXTL(bonds) == 0} {
368        # insert header
369        set row 0
370        grid [label $::DXTL(Blst).a$row -text "from " -bg yellow\
371                 ] -column 1 -row $row  -sticky ew
372        grid [label $::DXTL(Blst).b$row -text " to " -bg yellow\
373                 ] -column 2 -row $row  -sticky ew
374        grid [label $::DXTL(Blst).c$row -text " width " -bg yellow\
375                 ] -column 3 -row $row  -sticky ew
376        grid [label $::DXTL(Blst).d$row -text " min " -bg yellow\
377             ] -column 4 -row $row  -sticky ew
378        grid [label $::DXTL(Blst).e$row -text " max " -bg yellow\
379                 ] -column 5 -row $row  -sticky ew
380        grid [label $::DXTL(Blst).f$row -text " color " -bg yellow\
381                 ] -column 6 -row $row  -sticky ew
382    }
383    set row [incr ::DXTL(bonds)]
384    eval tk_optionMenu $::DXTL(Blst).ta$row ::DXTL(ba_$row) $::DXTL(typelist)
385    grid $::DXTL(Blst).ta$row -column 1 -row $row
386    eval tk_optionMenu $::DXTL(Blst).tb$row ::DXTL(bb_$row) $::DXTL(typelist)
387    grid $::DXTL(Blst).tb$row -column 2 -row $row
388    grid [entry $::DXTL(Blst).w$row -textvariable ::DXTL(bw_$row) \
389              -width 5] -column 3 -row $row
390    grid [entry $::DXTL(Blst).mi$row -textvariable ::DXTL(bmin_$row) \
391              -width 5] -column 4 -row $row
392    grid [entry $::DXTL(Blst).mx$row -textvariable ::DXTL(bmax_$row) \
393              -width 5] -column 5 -row $row
394    eval tk_optionMenu $::DXTL(Blst).c$row ::DXTL(bc_$row) $::DXTLcolorlist
395    grid $::DXTL(Blst).c$row -column 6 -row $row
396    set ::DXTL(bw_$row) 0.02
397    set ::DXTL(bmin_$row) 1.0
398    set ::DXTL(bmax_$row) 2.0
399    set ::DXTL(bc_$row) [lindex $::DXTLcolorlist $row]
400    # Resize the list
401    update
402    set sizes [grid bbox $::DXTL(Blst)]
403    [winfo parent $::DXTL(Blst)] config -scrollregion $sizes \
404        -width [lindex $sizes 2]
405    #set can [winfo parent $::DXTL($i)]
406    #set scroll [winfo parent $can].scroll
407    #[winfo parent $::DXTL($i)] config -scrollregion $sizes
408}
409
410proc DXTLwriteArrows {out phase} {
411    global expgui expmap
412    set fp [open geom.in w]
413    puts $fp "N"
414    puts $fp "M"
415    if {[llength $expmap(phaselist)] > 1} {
416        puts $fp "$phase"
417    }
418    puts $fp "N"
419    puts $fp "X"
420    close $fp
421    catch {
422        if {$::tcl_platform(platform) == "windows"} {
423            exec [file join $expgui(gsasexe) geometry.exe] \
424                [file root $expgui(expfile)] < geom.in >& geom.out
425        } else {
426            exec [file join $expgui(gsasexe) geometry] \
427                [file root $expgui(expfile)] < geom.in >& geom.out
428        }
429        set fp [open geom.out r]
430        while {[gets $fp line] >= 0} {
431            if {[string match "*Geometry*,L,N,*" $line]} {
432                MyMessageBox -parent . -title "Old GSAS" \
433                    -message "Old GEOMETRY program: You are using an old version of GSAS that cannot export magnetic vectors. Upgrade GSAS to generate arrows." -icon warning
434                break
435            }
436            if {[string match "*name*elem*x *y *z*x *y *z*" $line]} {break}
437        }
438        set i 0
439        while {[gets $fp line] >= 0} {
440            if {[string match "*Enter Geometry option*" $line]} {break}
441            incr i
442            if {$i == 2} {
443                set name [string trim [string range $line 5 12]]
444                set tail [string trim [string range $line 22 end]]
445                set pos [lrange $tail 0 2]
446                set spin [lindex $tail end]
447            } elseif {$i == 5} {
448                set vec [string trim [string range $line 22 end]]
449                if {[catch {set count($name)}]} {set count($name) 0}
450                catch {
451                    set k ?
452                    incr count($name)
453                    set k $count($name)
454                }
455                puts $out "rem spin for atom $name # $k ($spin)"
456                if {$spin == "Red"} {
457                    puts $out "arrow $pos     $vec    1. 0.15 $::DXTL(redarrow)"
458                } else {
459                    puts $out "arrow $pos     $vec    1. 0.15 $::DXTL(blackarrow)"
460                }
461            } elseif {$i == 6} {
462                set i 1
463            }
464        }
465    }
466    catch {close $fp}
467    catch {file delete -force geom.in geom.out}
468    puts $out "mag_trans 1. 0 0  0 1. 0  0 0 1."
469}
470
471# Computes a Fourier map(s) and converts the maps from binary to ascii
472#   returns a list of Fourier map types
473proc DXTLwritegrd {phase} {
474    global expgui expmap
475    set lst [listFourier]
476    if {[llength $lst] < 1} {
477        MyMessageBox -parent . -title "No Fourier" \
478            -message "You have not set up to compute a Fourier map." \
479            -icon warning
480        return
481    }
482    set typelist {}
483    foreach l $lst {
484        lappend typelist [Fourierinfo $l type]
485    }
486    set hists [FourierHists $phase]
487    # make sure we have default limits
488    getFourierLimits $phase
489    if {[llength $hists] < 1} {
490        MyMessageBox -parent . -title "No Fourier" \
491            -message "You have not set up to compute a Fourier map for phase $phase." \
492            -icon warning
493        return
494    }
495    if {$::tcl_platform(platform) == "windows"} {
496        set map [file join $expgui(gsasexe) gsas2map.exe]
497        set fourier [file join $expgui(gsasexe) fourier.exe]
498    } else {
499        set map [file join $expgui(gsasexe) gsas2map]
500        set fourier [file join $expgui(gsasexe) fourier]
501    }
502    if {![file exists $map]} {
503        MyMessageBox -parent . -title "No Map Converter prog" \
504            -message "Error Fourier map converter program ($map) not found." \
505            -icon warning
506        return
507    }
508    if {![file exists $fourier]} {
509        MyMessageBox -parent . -title "No Fourier prog" \
510            -message "Error Fourier program ($fourier) not found." \
511            -icon warning
512        return
513    }
514    set fp [open f.in w]
515    if {[OutputFourierType]} {
516        puts $fp [lindex $typelist 0]
517    }
518    puts $fp "E"
519    foreach t [lrange $typelist 1 end] {
520        puts $fp "F $t"
521        puts $fp "E"
522    }
523    puts $fp "q"
524    close $fp
525    # delete any old grd files
526    foreach f [glob -nocomplain "[file root $expgui(expfile)]*.grd"] {
527        catch {file delete -force $f}
528    }
529    set deleteerror 0
530    if {[llength [glob -nocomplain "[file root $expgui(expfile)]*.grd"]] >0} {
531        MyMessageBox -parent . -title "Old grd files?" \
532            -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." \
533            -icon warning
534        set deleteerror 1
535    }
536    # Save the current exp file
537    savearchiveexp
538    # disable the file changed monitor
539    set expgui(expModifiedLast) 0
540    catch {
541        exec $fourier [file root $expgui(expfile)] >& f.out
542        exec $map [file root $expgui(expfile)] < f.in >>& f.out
543    }
544    # reset the file changed monitor
545    #loadexp $expgui(expfile)
546    set expgui(expModifiedLast) [file mtime $expgui(expfile)]
547
548    if {[llength [glob -nocomplain "[file root $expgui(expfile)]*.grd"]] == 0} {
549        set fp [open f.out r]
550        set lines {}
551        while {[gets $fp line] >= 0} {
552            append lines $line "\n"
553        }
554        close $fp
555        MyMessageBox -parent . -title "No grd files" \
556            -message "Error: no .grd files were created. See log file below\n\n$lines" \
557            -icon error
558        return {}
559    } else {
560        catch {close $fp}
561        catch {file delete -force f.in f.out}
562        SetupFourierButtons
563        return $typelist
564    }
565}
566
567# called when the phase # is set or changed
568# clean up old Fourier maps
569proc OnNewFourierPhase {args} {
570    SetDXTLatoms
571    if {[llength $::expmap(phaselist)] > 1} {
572        # there is more than one phase; delete any .grd files to make sure
573        # generate ones for the current phase
574        foreach f [glob -nocomplain "[file root $::expgui(expfile)]*.grd"] {
575            catch {file delete -force $f}
576        }
577    }
578    SetupFourierButtons
579    eval destroy [winfo children $::DXTL(fb)]
580    set ::DXTL(contours) 0
581}
582
583# this enables/disables Fourier buttons based on the Fourier setup
584# and the files that are present
585proc SetupFourierButtons {} {
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    set ::DXTL(mtype) ""
591    set ::DXTL(mfil) ""
592    set ::DXTL(FourierRange) ""
593    # if the Fourier is not set up; return here
594    if {[llength [set nF [listFourier]]] < 1} return
595    # check that all phases are set to current phase
596    foreach i $nF {
597        set ph [Fourierinfo $i phase]
598        if {$ph != $phase} return
599    }
600    if {[llength [FourierHists $phase]] < 1} return
601    # make sure we have default limits
602    getFourierLimits $phase
603    $::DXTL(FourCompute) config -state normal
604    # if there are no maps, return now
605    set maps [glob -nocomplain "[file root $::expgui(expfile)]*.grd"]
606    if {[llength $maps] < 1} return
607    set types {}
608    foreach fil $maps {
609        lappend types [lindex [split [file root [file tail $fil]] "_"] end]
610    }
611    set i 0
612    foreach fil $maps lbl $types {
613        $::DXTL(fmenu) add command -label $lbl \
614            -command "set DXTL(mtype) $lbl; set DXTL(mfil) $fil; GetFourierRange"
615        if {$i == 0} {
616            $::DXTL(fmenu) invoke 0
617            $::DXTL(AddContour) config -state normal
618        }
619        incr i
620    }
621}
622
623proc EditFourier {} {
624    set phase $::expgui(export_phase)
625    # check that all Fourier records are set to the current phase
626    foreach i [listFourier] {
627        set ph [Fourierinfo $i phase]
628        if {$ph != $phase} {Fourierinfo $i phase set $phase}
629    }
630    # for now we will not offer access to section, (dmin, dmax not supported)
631    set typelist {}
632    foreach i [listFourier] {
633        lappend typelist [Fourierinfo $i type]
634    }
635    set histlist [FourierHists $phase]
636    set limits  [getFourierLimits $phase]
637    set box .export.fourier
638    catch {destroy $box}
639    toplevel $box
640    grid [frame $box.1] -row 1 -column 1 -rowspan 10
641    grid [frame $box.2] -row 1 -column 2 -rowspan 10
642    grid [frame $box.b] -sticky news -row 11 -column 1 -columnspan 2
643    grid columnconfigure $box.b 0 -weight 1
644    grid columnconfigure $box.b 3 -weight 1
645    grid [button $box.b.1 -text Continue \
646              -command "set ::DXTL(quit) 0; destroy $box" \
647             ] -row 1 -column 1
648    grid [button $box.b.2 -text Quit \
649              -command "set ::DXTL(quit) 1; destroy $box" \
650             ] -row 1 -column 2
651   
652    # map type selection
653    set row 0
654    grid [label $box.1.$row -text "Select map type(s)"] -column 1 -row $row
655    foreach typ {DELF FCLC FOBS 2FDF 3FDF 4FDF PTSN DPTS} lbl {
656        "Difference Fourier" "Fcalc Fourier" "Fobs Fourier" 
657        "2*Fo-Fc Fourier" "3*Fo-2*Fc Fourier" "4*Fo-3*Fc Fourier" "Patterson map" "Delta-F Patterson"\
658        } {
659            incr row
660            grid [ \
661                       checkbutton $box.1.$row -variable ::DXTL($typ) \
662                       -text "$lbl ($typ)" \
663                      ] -column 1 -row $row -sticky w
664            if {[lsearch $typelist $typ] == -1} {
665                set ::DXTL($typ) 0
666            } else {
667                set ::DXTL($typ) 1
668            }
669        }
670    grid [label $box.2.a1 -text "Histogram(s) to be used\n(last superceeds)"] -column 1 -row 1
671    grid [entry $box.2.a2 -textvariable ::DXTL(histlist) -width 20] -column 2 -row 1 -columnspan 3
672    set ::DXTL(histlist) $histlist
673    grid [label $box.2.m1 -text min] -column 2 -row 2
674    grid [label $box.2.m2 -text max] -column 3 -row 2
675    grid [label $box.2.m3 -text "map step\n(A)"] -column 4 -row 2
676    set row 3
677    foreach axis {X Y Z} lim [lrange $limits 1 end] step [lindex $limits 0] {
678        incr row
679        grid [label $box.2.0$axis -text "$axis limits"] -column 1 -row $row -sticky e
680        grid [entry $box.2.min$axis -width 10 -textvariable ::DXTL(min$axis)] -column 2 -row $row
681        grid [entry $box.2.max$axis -width 10 -textvariable ::DXTL(max$axis)] -column 3 -row $row
682        grid [entry $box.2.step$axis -width 10 -textvariable ::DXTL(step$axis)] -column 4 -row $row
683        set ::DXTL(min$axis) [lindex $lim 0]
684        set ::DXTL(max$axis) [lindex $lim 1]
685        set ::DXTL(step$axis) [format "%.4f" [expr {$step + 0.0001}]]
686    }
687    putontop $box
688    tkwait window $box
689    afterputontop
690    if $::DXTL(quit) return
691    delFourier
692    foreach typ {DELF FCLC FOBS 2FDF 3FDF 4FDF PTSN DPTS} {
693        if {$::DXTL($typ)} {
694            addFourier $phase $typ
695        }
696    }
697    FourierHists $phase set $::DXTL(histlist)
698    setFourierLimits $phase \
699        [list $::DXTL(stepX) $::DXTL(stepY) $::DXTL(stepZ)] \
700        [list $::DXTL(minX) $::DXTL(maxX)] \
701        [list $::DXTL(minY) $::DXTL(maxY)] \
702        [list $::DXTL(minZ) $::DXTL(maxZ)]
703    SetupFourierButtons
704    incr ::expgui(changed)
705}
706
707proc AddContour {} {
708    # set a header
709    if {$::DXTL(contours) == 0} {
710        set row 0
711        grid [label $::DXTL(fb).a$row -text "Type" -bg yellow \
712                 ] -column 1 -row $row  -sticky ew
713        grid [label $::DXTL(fb).b$row -text "Contour Level" -bg yellow \
714                 ] -column 2 -row $row  -sticky ew
715        grid [label $::DXTL(fb).c$row -text "Color" -bg yellow \
716                 -anchor center] -column 3 -row $row  -sticky ew
717    }
718    set row [incr ::DXTL(contours)]
719    eval tk_optionMenu $::DXTL(fb).ta$row ::DXTL(fb_type_$row) {mesh solid}
720    grid $::DXTL(fb).ta$row -column 1 -row $row
721    grid [entry $::DXTL(fb).w$row -width 10 -textvariable ::DXTL(fb_val_$row) \
722         ] -column 2 -row $row
723    set menu [eval tk_optionMenu $::DXTL(fb).tb$row \
724                  ::DXTL(fb_color_$row) $::DXTLcolorlist]
725    $menu invoke $row
726    grid $::DXTL(fb).tb$row -column 3 -row $row
727    grid [button $::DXTL(fb).del$row -text "Delete"\
728             -command "DeleteFourierContour $row"] -column 4 -row $row
729    update idletasks
730    set sizes [grid bbox $::DXTL(fb)]
731    [winfo parent $::DXTL(fb)] config -scrollregion $sizes \
732        -width [lindex $sizes 2]
733}
734
735proc DeleteFourierContour {row} {
736    foreach i "$::DXTL(fb).ta$row $::DXTL(fb).w$row $::DXTL(fb).tb$row \
737$::DXTL(fb).tb$row $::DXTL(fb).del$row" {
738        catch {destroy $i}
739    }
740    set ::DXTL(fb_val_$i) ""
741    if {$::DXTL(contours) == $row} {incr ::DXTL(contours) -1}
742}
743
744proc GetFourierRange {} {
745    set fp [open f.in w]
746    set lst [listFourier]
747    if {[llength $lst] < 1} {
748        MyMessageBox -parent . -title "No Fourier" \
749            -message "You have not set up to compute a Fourier map." \
750            -icon warning
751        return
752    }
753    set typelist {}
754    foreach l $lst {
755        lappend typelist [Fourierinfo $l type]
756    }
757    if {[OutputFourierType]} {
758        puts $fp $::DXTL(mtype)
759    }
760    close $fp
761    if {$::tcl_platform(platform) == "windows"} {
762        set map [file join $::expgui(gsasexe) forsrh.exe]
763    } else {
764        set map [file join $::expgui(gsasexe) forsrh]
765    }
766    catch {
767        exec $map [file root $::expgui(expfile)] < f.in >& f.out
768    }
769    foreach {min max} {{} {}} {}
770    catch {
771        set fp [open "f.out" r]       
772        while {[gets $fp line] >= 0} {
773            if {[string first "range of map values" $line] != -1} {
774                set off [expr 4 + [string first " is " $line]]
775                foreach {min to max} [string trim [string range $line $off end]] {}
776                break
777            }
778        }
779    }
780    catch {
781        close $fp
782    }
783    if {$min != ""} {set ::DXTL(FourierRange) "Range: $min to $max"}
784}
785
786# is output of the current Fourier map type required as input to a program?
787# answer is yes when more than one map file is present
788proc OutputFourierType {} {
789    set i 0
790    foreach ext {DEL FCL FOB PTS DPT} {
791        if {[file exists [file root $::expgui(expfile)].$ext]} {
792            incr i
793        }
794        for {set i 2} {$i <= 9} {incr i} {
795            if {[file exists [file root $::expgui(expfile)].${i}FD]} {
796                incr i
797            }
798        }
799    }
800    if {$i > 1} {
801        return 1
802    }
803    return 0
804}
805
806proc DXTLwriteFourierCommands {fp} {
807    if {$::DXTL(mfil) == ""} return
808    if {![file exists $::DXTL(mfil)]} {
809        puts "file not found $::DXTL(mfil)"
810        return
811    }
812    set cntlist {}
813    for {set i 1} {$i <= $::DXTL(contours)} {incr i} {
814        set val ""
815        catch {set val $::DXTL(fb_val_$i)}
816        if {[catch {set val [expr 1.*$val]}]} continue
817        lappend cntlist [list $val $::DXTL(fb_type_$i) $::DXTL(fb_color_$i)]       }
818    if {[llength $cntlist] <= 0} return
819    puts $fp "mapread grd [file tail $::DXTL(mfil)] 4"
820    foreach item $cntlist {
821        puts $fp "mapcontour $item"
822    }
823    set s {}
824    foreach a {X Y Z} {
825        lappend s $::DXTL(${a}dispMin)
826        lappend s $::DXTL(${a}dispMax)
827    }
828    puts $fp "mapregion $s"
829}
Note: See TracBrowser for help on using the repository browser.