source: trunk/widplt

Last change on this file was 1251, checked in by toby, 9 years ago

use svn ps svn:eol-style "native" * to change line ends
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Revision Id
File size: 42.6 KB
Line 
1#!/bin/sh
2# the next line restarts this script using wish found in the path\
3exec wish "$0" "$@"
4# If this does not work, change the #!/usr/bin/wish line below
5# to reflect the actual wish location and delete all preceeding lines
6#
7# (delete here and above)
8#!/usr/bin/wish
9# $Id: widplt 1251 2014-03-10 22:17:29Z toby $
10set Revision {$Revision: 1251 $ $Date: 2014-03-10 22:17:29 +0000 (Mon, 10 Mar 2014) $}
11package require Tk
12bind all <Control-KeyPress-c> {destroy .}
13
14set expnam [lindex $argv 0]
15if {$expnam != ""} {
16    if {[string toupper [file extension $expnam]] != ".EXP"} {
17        append expnam ".EXP"
18    }
19}
20# get name of script
21set expgui(script) [info script]
22# what are we running here?
23set program [file tail $argv0]
24# fix up problem with starkit tcl
25if {$program != "absplt" && $program != "widplt"} {
26        set program [file tail $expgui(script)]
27}
28
29if [catch {package require BLT} errmsg] {
30    tk_dialog .err "BLT Error" "Error -- Unable to load the BLT package" \
31            error 0 Quit
32    destroy .
33}
34
35# handle Tcl/Tk v8+ where BLT is in a namespace
36#  use the command so that it is loaded
37catch {blt::graph}
38catch {
39    namespace import blt::graph
40    namespace import blt::vector
41}
42# old versions of blt don't report a version number
43if [catch {set blt_version}] {set blt_version 0}
44
45set expgui(debug) 0
46catch {if $env(DEBUG) {set expgui(debug) 1}}
47#set expgui(debug) 1
48
49proc waitmsg {message} {
50    set w .wait
51    # kill any window/frame with this name
52    catch {destroy $w}
53    pack [frame $w]
54    frame $w.bot -relief raised -bd 1
55    pack $w.bot -side bottom -fill both
56    frame $w.top -relief raised -bd 1
57    pack $w.top -side top -fill both -expand 1
58    label $w.msg -justify left -text $message -wrap 3i
59    catch {$w.msg configure -font \
60                -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-*
61    }
62    pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
63    label $w.bitmap -bitmap info
64    pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
65    update
66}
67
68proc donewaitmsg {} {
69    catch {destroy .wait}
70    update
71}
72
73if {$expnam != ""} {waitmsg "Loading $expnam, Please wait"}
74
75# get profile/absorption information out from an EXP file
76proc getprofiles {expnam} {
77    global WidSetList absSetList wave XY UVWP lblarr ttrange
78    global expmap
79
80    if {$expnam != ""} {
81        if {[expload $expnam] == -1} {
82            tk_dialog .err "EXP Error" "Warning -- Unable to read $expnam" \
83                error 0 OK
84            return
85        }
86        mapexp
87    } else {
88        set expmap(powderlist) {}
89    }
90    foreach hist $expmap(powderlist) {
91        # wavelength
92        set lambda1 [histinfo $hist lam1]
93        # data range
94        set drange [string trim [readexp "HST  $hist TRNGE"]]
95        global program
96        if {$program == "absplt"} {
97            global ABS
98            set ABS($hist) [list \
99                                [histinfo $hist abscor1] \
100                                [histinfo $hist abscor2] \
101                                [histinfo $hist abstype] \
102                                $drange \
103                                "Hist $hist" \
104                                $expmap(htype_$hist)]
105            lappend absSetList $hist
106        } else {
107            foreach phase $expmap(phaselist_$hist) {
108                set ptype [hapinfo $hist $phase proftype]
109                set pterms  [hapinfo $hist $phase profterms]
110                set key "H${hist}P${phase}"
111                # make sure the key is not present already
112                if {[lsearch $WidSetList $key] == -1} {
113                    lappend WidSetList $key
114                }
115                set lblarr($key) "Histogram $hist Phase $phase"
116                set wave($key) $lambda1
117                set ttrange($key) $drange
118                if {$ptype == 1} {
119                    set UVWP($key) [list [hapinfo $hist $phase pterm1] \
120                                        [hapinfo $hist $phase pterm2] \
121                                        [hapinfo $hist $phase pterm3] 0]
122                    set XY($key) {0 0}
123                } elseif {$ptype == 2} {
124                    set UVWP($key) [list [hapinfo $hist $phase pterm1] \
125                                        [hapinfo $hist $phase pterm2] \
126                                        [hapinfo $hist $phase pterm3] \
127                                        [hapinfo $hist $phase pterm9]]
128                    set XY($key) [list [hapinfo $hist $phase pterm4] \
129                                      [hapinfo $hist $phase pterm5]]
130                } elseif {$ptype == 3 || $ptype == 4 || $ptype == 5} {
131                    set UVWP($key) [list [hapinfo $hist $phase pterm1] \
132                                        [hapinfo $hist $phase pterm2] \
133                                        [hapinfo $hist $phase pterm3] \
134                                        [hapinfo $hist $phase pterm4]]
135                    if {$ptype == 3 || $ptype == 5} {
136                        set XY($key) [list [hapinfo $hist $phase pterm5] \
137                                          [hapinfo $hist $phase pterm6]]
138                    } else {
139                        set XY($key) [list [hapinfo $hist $phase pterm5] 0]
140                    }
141                }
142            }
143        }
144    }
145    MakeCascadeMenus
146}
147
148proc makepostscriptout {} {
149    global graph box
150    if !$graph(printout) {
151        set out [open "| $graph(outcmd) >& widplt.msg" w]
152        catch {
153            puts $out [$box postscript output -landscape 1 \
154                -decorations no -height 7.i -width 9.5i]
155            close $out
156        } msg
157        catch {
158            set out [open widplt.msg r]
159            if {$msg != ""} {append msg "\n"}
160            append msg [read $out]
161            close $out
162            file delete widplt.msg
163        }
164        if {$msg != ""} {
165            tk_dialog .msg "file created" \
166                    "Postscript file processed with command \
167                    $graph(outcmd). Result: $msg" "" 0 OK
168        } else {
169            tk_dialog .msg "file created" \
170                    "Postscript file processed with command \
171                    $graph(outcmd)" "" 0 OK
172        }
173    } else {
174        $box postscript output $graph(outname) -landscape 1 \
175                -decorations no -height 7.i -width 9.5i   
176        tk_dialog .msg "file created" \
177                "Postscript file $graph(outname) created" "" 0 OK
178    }
179}
180
181proc setprintopt {page} {
182    global graph
183    if $graph(printout) { 
184        $page.4.1 config -fg black
185        $page.4.2 config -fg black -state normal
186        $page.6.1 config -fg #888
187        $page.6.2 config -fg #888 -state disabled
188    } else {
189        $page.4.1 config -fg #888
190        $page.4.2 config -fg #888 -state disabled
191        $page.6.1 config -fg black
192        $page.6.2 config -fg black -state normal
193    }
194}
195
196proc seteqwave {top} {
197    global graph
198    set box .wave
199    catch {destroy $box}
200    toplevel $box
201    focus $box
202    grab $box
203    pack [frame $box.1] -side top
204    pack [label $box.1.a -text "Equivalent wavelength:"] -side top
205    pack [entry $box.1.b -textvariable graph(equivwave)] -side top
206    pack [frame $box.2] -side top
207    pack [button $box.2.c -text Clear -command "set graph(equivwave) {}; destroy $box"]
208    pack [button $box.2.u -text Use -command "destroy $box"]
209    tkwait window $box
210    plotdata $top
211}
212
213proc setpostscriptout {} {
214    global graph tcl_platform
215    set box .out
216    catch {destroy $box}
217    toplevel $box
218    focus $box
219    grab $box
220    pack [frame $box.4] -side top -anchor w -fill x
221    pack [checkbutton $box.4.a -text "Write PostScript files" \
222            -variable graph(printout) -offvalue 0 -onvalue 1 \
223            -command "setprintopt $box"] -side left -anchor w
224    pack [entry $box.4.2 -textvariable graph(outname)] -side right -anchor w
225    pack [label $box.4.1 -text "PostScript file name:"] -side right -anchor w
226    pack [frame $box.6] -side top -anchor w -fill x
227    pack [checkbutton $box.6.a -text "Print PostScript files" \
228            -variable graph(printout) -offvalue 1 -onvalue 0 \
229            -command "setprintopt $box" ] -side left -anchor w
230    pack [entry $box.6.2 -textvariable graph(outcmd)] -side right -anchor w
231    pack [label $box.6.1 -text "Command to print files:"] -side right -anchor w
232
233    pack [button $box.a -text "Close" -command "destroy $box"] -side top   
234    if {$tcl_platform(platform) == "windows"} {
235        set graph(printout) 1
236        $box.4.a config -state disabled
237        $box.6.a config -fg #888 -state disabled
238    }
239    setprintopt $box
240}
241
242proc aboutwidplot {} {
243    global Revision
244    tk_dialog .warn About "
245GSAS\n\
246R. B. Von Dreele, Argonne National Lab\n
247and A. C. Larson, Los Alamos (retired)\n\n\
248WIDPLT/ABSPLT\nB. H. Toby, Argonne National Lab\n\n\
249$Revision\n\
250" {} 0 OK
251}
252
253proc nextcolor {var} {
254    set num [uplevel "incr $var"]
255    return [lindex {red green blue cyan magenta yellow} [expr $num % 6]]
256}
257
258proc NewProfileValues {} {
259    global newmenu datanum
260    incr datanum
261    set base .edit
262    catch {destroy $base}
263    toplevel $base
264    focus $base
265    grab $base
266    wm title $base {Enter a new profile}
267    MakeEditProfileBox $base
268    grid [button $base.bttn1 -text Add \
269            -command "AddProfileValues; destroy $base"] -row 6 -column 6 
270    grid [button $base.bttn2 -text Quit \
271            -command "destroy $base"] -row 6 -column 7 
272    set newmenu(U) 0
273    set newmenu(V) 0
274    set newmenu(W) 0
275    set newmenu(P) 0
276    set newmenu(X) 0
277    set newmenu(Y) 0
278    set newmenu(min) 5
279    set newmenu(max) 100
280    set newmenu(label) "Curve #$datanum"
281    set newmenu(wave) 1.5418
282}
283
284proc AddProfileValues {} {
285    global newmenu datanum lblarr WidDisplay UVWP XY WidSetList ttrange wave
286    set key new$datanum
287    set UVWP($key) [list $newmenu(U) $newmenu(V) $newmenu(W) $newmenu(P)]
288    set XY($key) [list $newmenu(X) $newmenu(Y)]
289    set lblarr($key) $newmenu(label)
290    set ttrange($key) "$newmenu(min) $newmenu(max)"
291    set wave($key) $newmenu(wave)
292    lappend WidSetList $key
293    MakeCascadeMenus
294}
295
296proc editProfileValues {key} {
297    global newmenu WidSetList lblarr
298
299    set base .edit
300    catch {destroy $base}
301    toplevel $base
302    wm title $base {Edit a profile}
303    MakeEditProfileBox $base
304    grid [button $base.bttn1 -text Apply \
305            -command "SaveProfileEdits $key"] -row 6 -column 6 
306    grid [button $base.bttn2 -text Close \
307            -command "destroy $base"] -row 6 -column 7 
308
309    global UVWP XY ttrange wave lblarr
310    set newmenu(label) $lblarr($key)
311    set newmenu(U) [lindex $UVWP($key) 0]
312    set newmenu(V) [lindex $UVWP($key) 1]
313    set newmenu(W) [lindex $UVWP($key) 2]
314    set newmenu(P) [lindex $UVWP($key) 3]
315    set newmenu(X) [lindex $XY($key) 0]
316    set newmenu(Y) [lindex $XY($key) 1]
317    set newmenu(min) [lindex $ttrange($key) 0]
318    set newmenu(max) [lindex $ttrange($key) 1]
319    set newmenu(wave) $wave($key)
320}
321
322proc SaveProfileEdits {key} {
323    global newmenu datanum lblarr WidDisplay UVWP XY WidSetList ttrange wave box
324    set UVWP($key) [list $newmenu(U) $newmenu(V) $newmenu(W) $newmenu(P)]
325    set XY($key) [list $newmenu(X) $newmenu(Y)]
326    set ttrange($key) [list $newmenu(min) $newmenu(max)]
327    set wave($key) $newmenu(wave)
328    set lblarr($key) $newmenu(label)
329    MakeCascadeMenus
330    plotdata $box 
331}
332
333proc MakeEditProfileBox {base} {
334    grid [label $base.lb7 -text Gaussian] -row 2 -column 1  -columnspan 4
335    grid [label $base.lb8 -text Lorentz] -row 2 -column 6  -columnspan 2
336    grid [label $base.lb1 -text U] -row 3 -column 1
337    grid [label $base.lb2 -text V] -row 3 -column 2 
338    grid [label $base.lb3 -text W] -row 3 -column 3 
339    grid [label $base.lb4 -text P] -row 3 -column 4 
340    grid [label $base.lb5 -text X] -row 3 -column 6 
341    grid [label $base.lb6 -text Y] -row 3 -column 7
342    grid [entry $base.ent1 -textvariable newmenu(U) -width 12] \
343            -row 4 -column 1
344    grid [entry $base.ent2 -textvariable newmenu(V) -width 12] \
345            -row 4 -column 2 
346    grid [entry $base.ent3 -textvariable newmenu(W) -width 12] \
347            -row 4 -column 3 
348    grid [entry $base.ent4 -textvariable newmenu(P) -width 12] \
349            -row 4 -column 4 
350    grid [entry $base.ent5 -textvariable newmenu(X) -width 12] \
351            -row 4 -column 6 
352    grid [entry $base.ent6 -textvariable newmenu(Y) -width 12] \
353            -row 4 -column 7
354
355    grid [label $base.lb9 -text label] -row 5 -column 1  -sticky e
356    grid [entry $base.ent7 -textvariable newmenu(label)]\
357            -row 5 -column 2  -columnspan 3 -sticky ew
358
359    grid [label $base.lb13 -text Wavelength] -row 5 -column 5 -columnspan 2
360    grid [entry $base.ent11 -textvariable newmenu(wave) -width 8] \
361            -row 5 -column 7
362
363    grid [label $base.lb11 -text {2Theta Min}] -row 6 -column 1 
364    grid [entry $base.ent9 -textvariable newmenu(min) -width 9] \
365            -row 6 -column 2
366    grid [label $base.lb12 -text {2Theta Max}] -row 6 -column 3
367    grid [entry $base.ent10 -textvariable newmenu(max) -width 9] \
368            -row 6 -column 4
369    grid rowconfigure $base 5 -weight 0 -pad 40
370    grid columnconfigure $base 5 -weight 0 -minsize 25
371}
372
373proc editAbsValues {key} {
374    global newmenu absSetList lblarr
375
376    set base .edit
377    catch {destroy $base}
378    toplevel $base
379    wm title $base {Edit Absorption Values}
380    MakeEditAbsBox $base
381    grid [button $base.bttn1 -text Apply \
382            -command "SaveAbsorptionEdits $key"] -row 8 -column 6 
383    grid [button $base.bttn2 -text Close \
384            -command "destroy $base"] -row 8 -column 7 
385
386    global ABS
387    foreach v {1 2 opt range label htype} val $ABS($key) {
388        set newmenu($v) $val
389    }
390    foreach {newmenu(min) newmenu(max)} $newmenu(range) {}
391    if {[string range $newmenu(htype) 2 2] == "T"} {
392        set newmenu(units) "TOF (ms):"
393    } elseif {[string range $newmenu(htype) 2 2] == "C"} {
394        set newmenu(units) "2-Theta (deg):"
395    } elseif {[string range $newmenu(htype) 2 2] == "E"} {
396        set newmenu(units) "Energy (KeV):"
397    }
398}
399
400proc SaveAbsorptionEdits {key} {
401    global ABS newmenu box
402    set ABS($key) [list \
403            $newmenu(1) $newmenu(2) $newmenu(opt) \
404            [list $newmenu(min) $newmenu(max)] \
405            $newmenu(label) \
406            [lindex $ABS($key) 5]]
407    plotdata $box 
408}
409
410proc MakeEditAbsBox {base} {
411    grid [label $base.lb1 -text "Absorption Coefficients"] \
412            -row 2 -column 1  -columnspan 2
413    grid [label $base.lb1a -text "1"] -row 3 -column 1
414    grid [label $base.lb2a -text "2"] -row 3 -column 2
415    grid [label $base.lb3 -text Absorption\nFunction] \
416            -row 2 -column 6 -rowspan 2 -columnspan 2
417    grid [entry $base.ent1 -textvariable newmenu(1) -width 12] \
418            -row 4 -column 1
419    grid [entry $base.ent2 -textvariable newmenu(2) -width 12] \
420            -row 4 -column 2 
421    eval tk_optionMenu $base.m1 newmenu(opt) 0 1 2 3 4
422    grid $base.m1 -row 4 -column 6 -columnspan 2
423
424    grid [label $base.lb8 -textvariable newmenu(opttxt) \
425          -wrap 180 -justify left] -row 5 -column 1  -sticky e -columnspan 7
426    grid [label $base.lb9 -text label] -row 7 -column 1  -sticky e
427    grid [entry $base.ent7 -textvariable newmenu(label)]\
428            -row 7 -column 2  -columnspan 3 -sticky ew
429
430    grid [frame $base.f] -row 8 -column 1 -columnspan 4
431    grid [label $base.f.1 -textvariable newmenu(units)] -row 0 -column 1 
432    grid [label $base.f.2 -text {Min}] -row 0 -column 2
433    grid [entry $base.f.3 -textvariable newmenu(min) -width 9] \
434            -row 0 -column 3
435    grid [label $base.f.4 -text {Max}] -row 0 -column 4
436    grid [entry $base.f.5 -textvariable newmenu(max) -width 9] \
437            -row 0 -column 5
438    grid rowconfigure $base 6 -min 15
439}
440
441proc plotdata {top} {
442    global program graph
443    global UVWP XY wave lblarr WidSetList WidDisplay ttrange
444    global ABS absSetList AbsDisplay
445    if {$program == "absplt"} {
446        $top yaxis config -title {Abs. Corr.} 
447    } else {
448        $top yaxis config -title {FWHM} 
449    }
450    if {$graph(plotunits) == "d"} {
451        $top xaxis configure -title "d (A)"
452    } elseif {$graph(plotunits) == "deltad"} {
453        $top xaxis configure -title "d (A)"
454        $top yaxis configure -title "delta-d/d"
455    } elseif {$graph(plotunits) == "q"} {
456        $top xaxis configure -title "Q (A-1)"
457    } elseif {$graph(equivwave) == ""} {
458        $top xaxis configure -title "2Theta"
459    } else {
460        $top xaxis configure -title "2Theta @ $graph(equivwave)"
461    }
462    $top yaxis configure -min 0 
463    $top xaxis configure -min 0
464    # delete all graphs
465    eval $top element delete [$top element names]
466    set num -1
467    if {$program == "absplt"} {
468        foreach item $absSetList {
469            if {$AbsDisplay($item)} {
470                set ttlist {}
471                set abscor1 [lindex $ABS($item) 0]
472                set abscor2 [lindex $ABS($item) 1]
473                set abstype [lindex $ABS($item) 2]
474                set abslbl [lindex $ABS($item) 4]
475                set htype [lindex $ABS($item) 5]
476                set ttmin [lindex [lindex $ABS($item) 3] 0]
477                set ttmax [lindex [lindex $ABS($item) 3] 1]
478                set ttstep [expr {($ttmax - $ttmin)/50.}]
479                if {$graph(equivwave) == ""} {
480                    if {[string range $htype 2 2] == "T"} {
481                        $top xaxis configure -title "TOF (ms)"
482                    } elseif {[string range $htype 2 2] == "E"} {
483                        $top xaxis configure -title "Energy (KeV)"
484                    }
485                }
486                for     {set tt $ttmin} \
487                        {$tt <= $ttmax} \
488                        {set tt [expr {$tt + $ttstep}]} {
489                    catch {
490                        lappend abslist [AbsorbCalc \
491                                $item $tt $abscor1 $abscor2 $abstype]
492                        lappend ttlist $tt
493                    }
494                }
495                if {[llength $ttlist] == 0} continue
496                if {$graph(plotunits) == "d"} {
497                    set ttlist [tod $ttlist $item]
498                } elseif {$graph(plotunits) == "deltad"} {
499                    set ttlist [tod $ttlist $item]
500                } elseif {$graph(plotunits) == "q"} {
501                    set ttlist [toQ $ttlist $item]
502                }
503                catch {
504                    $top element create $item
505                }
506                $top element config $item -label $abslbl \
507                        -xdata $ttlist -ydata $abslist -linewidth 3 \
508                        -color [nextcolor num]
509            }
510        }
511    } else {
512        foreach item $WidSetList {
513            if {$WidDisplay($item)} {
514                if {[expr [lindex $XY($item) 0] + [lindex $XY($item) 1]] != 0} {
515                    set lflag 1
516                } else {
517                    set lflag 0
518                }
519                set ttlist {}
520                set fwhmlist {}
521                set lfwhmlist {}
522                set tfwhmlist {}
523                # loop over two-theta
524                for     {set tt [lindex $ttrange($item) 0]} \
525                        {$tt <= [lindex $ttrange($item) 1]} \
526                        {set tt [expr $tt + 4]} {
527                    set lfwhm 0
528                    catch {
529                        if {$graph(plotunits) == "d"} {
530                            lappend ttlist [tt2d $wave($item) $tt ]
531                            set gfwhm [deltad $wave($item) $tt \
532                                    [eval FWHM $tt $UVWP($item)]]
533                            lappend fwhmlist $gfwhm
534                            if $lflag {
535                                set lfwhm [deltad $wave($item) $tt \
536                                        [eval LFWHM $tt $XY($item)]]
537                                lappend lfwhmlist $lfwhm
538                            }
539                        } elseif {$graph(plotunits) == "deltad"} {
540                            set d [tt2d $wave($item) $tt ]
541                            lappend ttlist $d
542                            set gfwhm [deltad $wave($item) $tt \
543                                    [eval FWHM $tt $UVWP($item)]]
544                            lappend fwhmlist [expr {$gfwhm/$d}]
545                            if $lflag {
546                                set lfwhm [deltad $wave($item) $tt \
547                                        [eval LFWHM $tt $XY($item)]]
548                                lappend lfwhmlist [expr {$lfwhm/$d}]
549                            }
550                        } elseif {$graph(plotunits) == "q"} {
551                            lappend ttlist [tt2Q $wave($item) $tt ]
552                            set gfwhm [deltaQ $wave($item) $tt \
553                                    [eval FWHM $tt $UVWP($item)]]
554                            lappend fwhmlist $gfwhm
555                            if $lflag {
556                                set lfwhm [deltaQ $wave($item) $tt \
557                                        [eval LFWHM $tt $XY($item)]]
558                                lappend lfwhmlist $lfwhm
559                            }
560                        } elseif {$graph(equivwave) == ""} {
561                            lappend ttlist $tt
562                            set gfwhm [eval FWHM $tt $UVWP($item)]
563                            lappend fwhmlist $gfwhm
564                            if $lflag {
565                                set lfwhm [eval LFWHM $tt $XY($item)]
566                                lappend lfwhmlist $lfwhm
567                            }
568                        } else {
569                            set tteq [ttequiv $wave($item) $tt $graph(equivwave)]
570                            if {$tteq != ""} {
571                                lappend ttlist $tteq
572                                set gfwhm [delta2teq $wave($item) $tt \
573                                        [eval FWHM $tt $UVWP($item)] $graph(equivwave)]
574                                lappend fwhmlist $gfwhm
575                                if $lflag {
576                                    set lfwhm [delta2teq $wave($item) $tt \
577                                            [eval LFWHM $tt $XY($item)] $graph(equivwave)]
578                                    lappend lfwhmlist $lfwhm
579                                }
580                            }
581                        }
582                        # Use polynomial of P. Thompson, D.E. Cox & J.B. Hastings, 
583                        # J. Appl. Cryst.,20,79-83, 1987 (GSAS manual 9/26/04 p157)
584                        # to compute composite FWHM
585                        lappend tfwhmlist \
586                            [expr {
587                                   pow(
588                                       pow($gfwhm,5) +
589                                       2.69269*pow($gfwhm,4)*$lfwhm +
590                                       2.42843*pow($gfwhm,3)*pow($lfwhm,2) +
591                                       4.47163*pow($gfwhm,2)*pow($lfwhm,3) +
592                                       0.07842*$gfwhm*pow($lfwhm,4) +
593                                       pow($lfwhm,5)
594                                       , 0.2)
595                               }]
596                    }
597                        }
598                if $lflag {
599                    catch {
600                        $top element create ${item}G -label "$lblarr($item) G" 
601                    }
602                    $top element config ${item}G \
603                            -xdata $ttlist -ydata $fwhmlist -linewidth 3 \
604                            -color [nextcolor num]
605                    catch {
606                        $top element create ${item}L -label "$lblarr($item) L"
607                    }
608                    $top element config ${item}L \
609                            -xdata $ttlist -ydata $lfwhmlist -linewidth 3 \
610                            -color [nextcolor num]
611                }
612                catch {
613                    $top element create $item -label $lblarr($item) 
614                }
615                $top element config $item \
616                        -xdata $ttlist -ydata $tfwhmlist -linewidth 3 \
617                        -color [nextcolor num]
618            }
619        }
620    }
621}
622proc AbsorbCalc {hst ttof abscor1 abscor2 mode} {
623    global expmap
624    set htype $expmap(htype_$hst)
625    set pi [expr {2.*acos(0.)}]
626    # determine sin(theta) & lambda
627    if {[string range $htype 2 2] == "T"} {
628        set sth [expr {sin($pi * abs([histinfo $hst tofangle])/360.)}]
629        set lamb [expr {2 * [toftod $ttof $hst] * $sth}]
630    } elseif {[string range $htype 2 2] == "C"} {
631        set lamb [histinfo $hst lam1]
632        set sth [expr {sin($pi * ($ttof - [histinfo $hst zero]/100.)/360.)}]
633    } elseif {[string range $htype 2 2] == "E"} {
634        set lamb [expr { 12.398 / $ttof}]
635        set sth [expr {sin($pi * [histinfo $hst lam1] / 360.)}]
636    }
637    set sth2 [expr $sth*$sth]
638    set cth2 [expr {1 - $sth2}]
639    set cth  [expr {sqrt($cth2)}]
640
641    if {$mode == 0} { 
642        set murl [expr {$abscor1 * $lamb}]; # Lobanov & Alte da Veiga
643        if {$murl <= 3} {
644            set TERM0 [expr { 16.0/(3*$pi) }]
645            set TERM1 [expr { (25.99978-0.01911*pow($sth2,0.25)) * \
646                    exp(-0.024551*$sth2) + 0.109561*sqrt($sth2)-26.04556 }]
647            set TERM2 [expr {-0.02489 - 0.39499*$sth2 + \
648                    1.219077*pow($sth2,1.5) - 1.31268*pow($sth2,2) + \
649                    0.871081*pow($sth2,2.5) - 0.2327*pow($sth2,3) }]
650            set TERM3 [expr { 0.003045+0.018167*$sth2 - 0.03305*pow($sth2,2) }]
651            set TRANS [expr { -$TERM0*$murl - $TERM1*pow($murl,2) - \
652                    $TERM2*pow($murl,3) - $TERM3*pow($murl,4) }]
653            if {$TRANS <= -20.0} {
654                set TRANS 2.06E-9
655            } elseif {$TRANS >= 20.0} {
656                set TRANS 4.85E8
657            } else {
658                set TRANS [expr {exp($TRANS)}]
659            }
660        } else {
661            set TERM1 [expr { 1.433902 + 11.07504*$sth2 - \
662                    8.77629*pow($sth2,2) + 10.02088*pow($sth2,3) - \
663                    3.36778*pow($sth2,4) }]
664            set TERM2 [expr { (0.013869 - 0.01249*$sth2) * \
665                    exp(3.27094*$sth2) + \
666                    (0.337894 + 13.77317*$sth2) / \
667                    pow((1.0+11.53544*$sth2),1.555039) }]
668            set TERM3 [expr { 1.933433 / pow((1.0+23.12967*$sth2),1.686715) - \
669                    0.13576*sqrt($sth2) + 1.163198}]
670            set TERM4 [expr { 0.044365 - 0.4259 / \
671                    pow((1.0+0.41051*$sth2),148.4202) }]
672            set TRANS [expr { ($TERM1-$TERM4) / \
673                    pow((1.0+$TERM2*($murl-3.0)),$TERM3) + $TERM4 }]
674            set TRANS [expr { $TRANS/100.0}]
675        }
676    } elseif {$mode == 1} { 
677        #!Simple linear absorption
678        set TRANS [expr { -$abscor1*$lamb }]
679        set TRANS [expr { exp($TRANS) }]
680    } elseif {$mode == 2} { 
681        #!Pitschke, Hermann & Muttern - surface roughness
682        set TERM1 [expr { 1.0/$sth-$abscor2/$sth2 }]
683        set TERM2 [expr { 1.0-$abscor1*(1.0+$abscor2) }]
684        set TRANS [expr { (1.0-$abscor1*$TERM1)/$TERM2 }]
685    } elseif {$mode == 3} { 
686        #!Suortti - surface roughness
687        set TERM1 [expr { exp(-$abscor2/$sth) }]
688        set TERM2 [expr { $abscor1 + (1.0-$abscor1) * exp(-$abscor2) }]
689        set TRANS [expr { ($abscor1 +(1.0-$abscor1) * $TERM1)/$TERM2 }]
690    } elseif {$mode == 4} { 
691        #!Plate transmission absorption
692        if {abs($abscor2) < 1} {
693            #!Use symmetric fxn. if phi 1 deg or less
694            set TRANS [expr { -$abscor1*$lamb/$cth }]
695            set TRANS [expr { exp($TRANS) }]
696        } else {
697            #!Bigger tilts
698            set SPH [expr { sin($pi/180. * $abscor2) }]
699            set CPH [expr { cos($pi/180. * $abscor2) }]
700            set CTPP [expr { $CPH*$cth - $SPH*$sth }]
701            set CTMP [expr { $CPH*$cth + $SPH*$sth }]
702            set T [expr { -$abscor1*$lamb }]
703            set T1 [expr { $T / $CTPP }]
704            set TRANS1 [expr { exp($T1) }]
705            set T2 [expr { $T/$CTMP }]
706            set TRANS2 [expr { exp($T2) }]
707            set TB [expr { $T * (1.0 - $CTMP / $CTPP) }]
708            set TRANS [expr { ($TRANS1 - $TRANS2) / $TB }]
709        }
710    }
711    return $TRANS
712}
713
714# save some of the global options in ~/.gsas_config
715proc SaveOptions {} {
716    global graph  tcl_platform
717    if {$tcl_platform(platform) == "windows"} {
718        set fp [open c:/gsas.config a]
719    } else {
720        set fp [open [file join ~ .gsas_config] a]
721    }
722    puts $fp "# WIDPLT saved options from [clock format [clock ticks]]"
723    puts $fp "set graph(legend) [list $graph(legend)]"
724    puts $fp "set graph(printout) [list $graph(printout)]"
725    puts $fp "set graph(outname) [list $graph(outname)]"
726    puts $fp "set graph(outcmd) [list $graph(outcmd)]"
727    puts $fp "set graph(plotunits) [list $graph(plotunits)]"
728    puts $fp "set graph(equivwave) [list $graph(equivwave)]"
729    close $fp
730}
731
732proc MakeCascadeMenus {} {
733    global WidSetList lblarr box absSetList ABS
734    .a.plot.menu delete 0 end
735    .a.file.menu.edit delete 0 end
736    global program
737    if {$program != "absplt"} {
738        foreach item $WidSetList {
739            .a.plot.menu add checkbutton -label $lblarr($item) \
740                    -command "plotdata $box" -variable WidDisplay($item)
741            .a.file.menu.edit add command -label $lblarr($item) \
742                    -command "editProfileValues $item"
743        }
744    } else {
745        foreach item $absSetList {
746            .a.plot.menu add checkbutton -label [lindex $ABS($item) 4] \
747                    -command "plotdata $box" -variable AbsDisplay($item)
748            .a.file.menu.edit add command -label [lindex $ABS($item) 4] \
749                    -command "editAbsValues $item"
750        }
751    }
752}
753#-------------------------------------------------------------------------
754# converts 2theta(deg) to Q (A-1)
755proc tt2Q {lambda twotheta} {
756    set pi 3.14159
757    set torad [expr $pi / 360.]
758    return [expr 4 * $pi / ($lambda) * sin (($twotheta) * $torad)]
759}
760
761# converts Q (A-1) to 2theta(deg)
762proc Q2tt {lambda Q} {
763    set pi 3.14159
764    set todeg [expr 360. / $pi]
765    set asinarg [expr ($lambda) * $Q * 0.25 / $pi]
766    if {$asinarg <= 1} {
767        return [expr $todeg * asin ($asinarg)]
768    }
769    return {}
770}
771
772# converts a FWHM in 2theta(deg) to a FWHM in Q (A-1)
773proc deltaQ {lambda twotheta FWHM} {
774    return [expr [tt2Q $lambda $twotheta+($FWHM/2.)] - \
775                 [tt2Q $lambda $twotheta-($FWHM/2.)] ]
776}
777
778# converts 2theta(deg) to d (A)
779proc tt2d {lambda twotheta} {
780    set pi 3.14159
781    set torad [expr $pi / 360.]
782    return [expr 0.5 * ($lambda) / sin (($twotheta) * $torad)]
783}
784
785# converts d (A) to 2theta(deg)
786proc d2tt {lambda d} {
787    set pi 3.14159
788    set todeg [expr 360. / $pi]
789    set asinarg [expr ($lambda) * 0.5 / $d]
790    if {$asinarg <= 1} {
791        return [expr $todeg * asin ($asinarg)]
792    }
793    return {}
794}
795
796# converts a FWHM in 2theta(deg) to a FWHM in Q (A-1)
797proc deltad {lambda twotheta FWHM} {
798    return [expr [tt2d $lambda $twotheta-($FWHM/2.)] - \
799                 [tt2d $lambda $twotheta+($FWHM/2.)] ]
800}
801
802# computes an equivalent 2theta at a different wavelength
803proc ttequiv {lambda twotheta lambda_eq} {
804    return [Q2tt $lambda_eq [tt2Q $lambda $twotheta]]
805}
806
807# converts a FWHM in 2theta(deg) to a FWHM at in 2theta
808# at a different wavelength
809proc delta2teq {lambda twotheta FWHM lambda_eq} {
810    return [expr [Q2tt $lambda_eq [tt2Q $lambda $twotheta+($FWHM/2.)]] - \
811                 [Q2tt $lambda_eq [tt2Q $lambda $twotheta-($FWHM/2.)]] ]
812}
813
814# convert x values to d-space
815proc tod {xlist hst} {
816    global expmap
817    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
818        return [toftod $xlist $hst]
819    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
820        return [tttod $xlist $hst]
821    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
822        return [engtod $xlist $hst]
823    } else {
824        return {}
825    }
826}
827
828# convert tof to d-space
829proc toftod {toflist hst} {
830    set difc [expr {[histinfo $hst difc]/1000.}]
831    set difc2 [expr {$difc*$difc}]
832    set difa [expr {[histinfo $hst difa]/1000.}]
833    set zero [expr {[histinfo $hst zero]/1000.}]
834    set ans {}
835    foreach tof $toflist {
836        if {$tof == 0.} {
837            lappend ans 0.
838        } elseif {$tof == 1000.} {
839            lappend ans 1000.
840        } else {
841            set td [expr {$tof-$zero}]
842            lappend ans [expr {$td*($difc2+$difa*$td)/ \
843                    ($difc2*$difc+2.0*$difa*$td)}]
844        }
845    }
846    return $ans
847}
848
849# convert two-theta to d-space
850proc tttod {twotheta hst} {
851    set lamo2 [expr {0.5 * [histinfo $hst lam1]}]
852    set zero [expr [histinfo $hst zero]/100.]
853    set ans {}
854    set cnv [expr {acos(0.)/180.}]
855    foreach tt $twotheta {
856        if {$tt == 0.} {
857            lappend ans 99999.
858        } elseif {$tt == 1000.} {
859            lappend ans 0.
860        } else {
861            lappend ans [expr {$lamo2 / sin($cnv*($tt-$zero))}]
862        }
863    }
864    return $ans
865}
866
867# convert energy (edx-ray) to d-space
868# (note that this ignores the zero correction)
869proc engtod {eng hst} {
870    set lam [histinfo $hst lam1]
871    set zero [histinfo $hst zero]
872    set ans {}
873    set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
874    foreach e $eng {
875        if {$e == 0.} {
876            lappend ans 1000.
877        } elseif {$e == 1000.} {
878            lappend ans 0.
879        } else {
880            lappend ans [expr {$v/$e}]
881        }
882    }
883    return $ans
884}
885
886# convert x values to Q
887proc toQ {xlist hst} {
888    global expmap
889    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
890        return [toftoQ $xlist $hst]
891    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
892        return [tttoQ $xlist $hst]
893    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
894        return [engtoQ $xlist $hst]
895    } else {
896        return {}
897    }
898}
899# convert tof to Q
900proc toftoQ {toflist hst} {
901    set difc [expr {[histinfo $hst difc]/1000.}]
902    set difc2 [expr {$difc*$difc}]
903    set difa [expr {[histinfo $hst difa]/1000.}]
904    set zero [expr {[histinfo $hst zero]/1000.}]
905    set 2pi [expr {4.*acos(0.)}]
906    set ans {}
907    foreach tof $toflist {
908        if {$tof == 0.} {
909            lappend ans 99999.
910        } elseif {$tof == 1000.} {
911            lappend ans 0.
912        } else {
913            set td [expr {$tof-$zero}]
914            lappend ans [expr {$2pi * \
915                    ($difc2*$difc+2.0*$difa*$td)/($td*($difc2+$difa*$td))}]
916        }
917    }
918    return $ans
919}
920
921# convert two-theta to Q
922proc tttoQ {twotheta hst} {
923    set lamo2 [expr {0.5 * [histinfo $hst lam1]}]
924    set zero [expr [histinfo $hst zero]/100.]
925    set ans {}
926    set cnv [expr {acos(0.)/180.}]
927    set 2pi [expr {4.*acos(0.)}]
928    foreach tt $twotheta {
929        if {$tt == 0.} {
930            lappend ans 0.
931        } elseif {$tt == 1000.} {
932            lappend ans 1000.
933        } else {
934            lappend ans [expr {$2pi * sin($cnv*($tt-$zero)) / $lamo2}]
935        }
936    }
937    return $ans
938}
939# convert energy (edx-ray) to Q
940# (note that this ignores the zero correction)
941proc engtoQ {eng hst} {
942    set lam [histinfo $hst lam1]
943    set zero [histinfo $hst zero]
944    set ans {}
945    set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
946    set 2pi [expr {4.*acos(0.)}]
947    foreach e $eng {
948        if {$e == 0.} {
949            lappend ans 0.
950        } elseif {$e == 1000.} {
951            lappend ans 1000.
952        } else {
953            lappend ans [expr {$2pi * $e / $v}]
954        }
955    }
956    return $ans
957}
958proc sind {angle} {
959    return [expr {sin($angle*acos(0.)/90.)}]
960}
961
962proc FWHM {tt U V W P} {
963    set pi 3.14159
964    set torad [expr $pi / 360.]
965    # tan theta
966    set tantt [expr tan($tt * $torad ) ]
967    set costt [expr cos($tt * $torad ) ]
968    return [expr {
969                  sqrt (8.* log(2) *
970                        ($U * $tantt * $tantt + $V * $tantt + $W +
971                         $P / ($costt * $costt))
972                        ) / 100.}]
973}
974
975proc LFWHM {tt X Y} {
976    set pi 3.14159
977    set torad [expr $pi / 360.]
978    # tan theta
979    set tantt [expr tan($tt * $torad ) ]
980    set costt [expr cos($tt * $torad ) ]
981    return [expr ($X / $costt + $Y * $tantt) / 100.]
982}
983
984proc setlegend {box legend} {
985    global blt_version
986    if {$blt_version >= 2.3 && $blt_version < 8.0} {
987        if $legend {
988            $box legend config -hide no
989        } else {
990            $box legend config -hide yes
991        }
992    } else {
993        if $legend {
994            $box legend config -mapped yes
995        } else {
996            $box legend config -mapped no
997        }
998    }
999}
1000
1001proc BLTmanualZoom {} {
1002    global graph box
1003    catch {toplevel .zoom}
1004    eval destroy [grid slaves .zoom]
1005    raise .zoom
1006    wm title .zoom {Manual Scaling}
1007    grid [label .zoom.l1 -text minimum] -row 1 -column 2 
1008    grid [label .zoom.l2 -text maximum] -row 1 -column 3 
1009    grid [label .zoom.l3 -text x] -row 2 -column 1 
1010    grid [label .zoom.l4 -text y] -row 3 -column 1 
1011    grid [entry .zoom.xmin -textvariable graph(xmin) -width 10] -row 2 -column 2 
1012    grid [entry .zoom.xmax -textvariable graph(xmax) -width 10] -row 2 -column 3 
1013    grid [entry .zoom.ymin -textvariable graph(ymin) -width 10] -row 3 -column 2 
1014    grid [entry .zoom.ymax -textvariable graph(ymax) -width 10] -row 3 -column 3 
1015    grid [frame .zoom.b] -row 4 -column 1 -columnspan 3
1016    grid [button .zoom.b.1 -text "Set Scaling" \
1017             -command "SetManualZoom set"]  -row 4 -column 1 -columnspan 2
1018    grid [button .zoom.b.2 -text Reset \
1019            -command "SetManualZoom clear"] -row 4 -column 3
1020    grid [button .zoom.b.3 -text Close -command "destroy .zoom"] -row 4 -column 4 
1021    grid rowconfigure .zoom 1 -weight 1 -pad 5
1022    grid rowconfigure .zoom 2 -weight 1 -pad 5
1023    grid rowconfigure .zoom 3 -weight 1 -pad 5
1024    grid rowconfigure .zoom 4 -weight 0 -pad 5
1025    grid columnconfigure .zoom 1 -weight 1 -pad 20
1026    grid columnconfigure .zoom 1 -weight 1 
1027    grid columnconfigure .zoom 3 -weight 1 -pad 10
1028    foreach item {min min max max} \
1029            format {3   2   3   2} \
1030            axis   {x   y   x   y} {
1031        set val [$box ${axis}axis cget -${item}]
1032        set graph(${axis}${item}) {(auto)}
1033        catch {set graph(${axis}${item}) [format %.${format}f $val]}
1034    }
1035    bind .zoom <Return> "SetManualZoom set"
1036}
1037
1038proc SetManualZoom {mode} {
1039    global graph box
1040    if {$mode == "clear"} {
1041        foreach item {xmin ymin xmax ymax} {
1042            set graph($item) {(auto)}
1043        }
1044    }
1045    foreach item {xmin ymin xmax ymax} {
1046        if {[catch {expr $graph($item)}]} {
1047            set $item ""
1048        } else {
1049            set $item $graph($item)
1050        }
1051    }
1052    # reset the zoomstack
1053    catch {Blt_ZoomStack $box}
1054    catch {$box xaxis config -min $xmin -max $xmax}
1055    catch {$box yaxis config -min $ymin -max $ymax}
1056    #global program
1057    #if {$program == "bkgedit"} {bkgEditMode ""}
1058}
1059
1060#-------------------------------------------------------------------------
1061# export current plot to Grace
1062#-------------------------------------------------------------------------
1063if {$tcl_platform(platform) == "unix"} {
1064    set graph(GraceFile) /tmp/grace_out.agr
1065} else {
1066    set graph(GraceFile) C:/graceout.agr
1067}
1068proc exportgrace {} {
1069    global graph box
1070    global tcl_platform graph
1071    catch {toplevel .export}
1072    raise .export
1073    eval destroy [grid slaves .export]
1074    set col 5
1075    grid [label .export.1a -text Title:] -column 1 -row 1
1076    set graph(title) [$box cget -title]
1077    grid [entry .export.1b -width 60 -textvariable graph(title)] \
1078            -column 2 -row 1 -columnspan 4
1079    grid [label .export.2a -text Subtitle:] -column 1 -row 2
1080    grid [entry .export.2b -width 60 -textvariable graph(subtitle)] \
1081            -column 2 -row 2 -columnspan 4
1082    grid [label .export.3a -text "File name:"] -column 1 -row 3
1083    grid [entry .export.3b -width 60 -textvariable graph(GraceFile)] \
1084            -column 2 -row 3 -columnspan 4
1085    grid [button .export.help -text Help -bg yellow \
1086            -command "MakeWWWHelp liveplot.html grace"] \
1087            -column [incr col -1] -row 4
1088    grid [button .export.c -text "Close" \
1089            -command "set graph(export) 0; destroy .export"] \
1090            -column [incr col -1] -row 4
1091    if {$tcl_platform(platform) == "unix" && [auto_execok xmgrace] != ""} {
1092        grid [button .export.d -text "Export & \nstart grace" \
1093            -command "set graph(export) 1; destroy .export"] \
1094                -column [incr col -1] -row 4
1095    }
1096    grid [button .export.e -text "Export" \
1097            -command "set graph(export) 2; destroy .export"] \
1098            -column [incr col -1] -row 4
1099    tkwait window .export
1100    if {$graph(export) == 0} return
1101    if {[catch {
1102        set fp [open $graph(GraceFile) w]
1103        puts $fp [output_grace $box $graph(title) $graph(subtitle)]
1104        close $fp
1105    } errmsg]} {
1106        MyMessageBox -parent . -title "Export Error" \
1107                -message "An error occured during the export: $errmsg" \
1108                -icon error -type Ignore -default ignore
1109        return
1110    }
1111
1112    if {$graph(export) == 1} {
1113        set err [catch {exec xmgrace $graph(GraceFile) &} errmsg]
1114        if $err {
1115        MyMessageBox -parent . -title "Grace Error" \
1116                -message "An error occured launching grace (xmgrace): $errmsg" \
1117                -icon error -type Ignore -default ignore
1118        }
1119    } else {
1120        MyMessageBox -parent . -title "OK" \
1121                -message "File $graph(GraceFile) created" \
1122                -type OK -default ok
1123    }
1124}
1125#-------------------------------------------------------------------------
1126# export current plot as .csv file
1127#-------------------------------------------------------------------------
1128proc makecsvfile {} {
1129    global graph box expnam program
1130    global tcl_platform graph
1131    set typelist {
1132        {{Comma separated} {.csv}        }
1133        {{Text File}       {.txt}        }
1134    }
1135    set file [tk_getSaveFile -filetypes $typelist \
1136            -initialfile ${expnam}_$program.csv]
1137    if {$file == ""} return
1138    set varlist {}
1139    set line {}
1140    foreach element_name [$box element names] {
1141        lappend varlist ${element_name}_x
1142        set ${element_name}_x [$box element cget $element_name -xdata]
1143        lappend varlist ${element_name}_y
1144        set ${element_name}_y [$box element cget $element_name -ydata]
1145        append line [$box element cget $element_name -label] "-X, "
1146        append line [$box element cget $element_name -label] "-Y, "
1147    }
1148    set fp [open $file w]
1149    # get x and y axis limits
1150    foreach v {x y} {
1151        foreach "${v}min ${v}max" [$box ${v}axis limits] {}
1152        puts $fp "\"$v axis range [set ${v}min] to [set ${v}max]\""
1153        puts $fp "\"$v axis label [$box ${v}axis cget -title]\""
1154    }
1155    puts $fp $line
1156    set i 0
1157    set done 1
1158    while {$done} {
1159        set line {}
1160        set done 0
1161        foreach var $varlist {
1162            set val [lindex [set $var] $i]
1163            if {$val != ""} {set done 1}
1164            append line "$val, "
1165        }
1166        if {$done} {puts $fp $line}
1167        incr i
1168    }
1169    close $fp
1170}
1171
1172
1173set graph(legend) 0
1174set graph(equivwave) {}
1175set graph(plotunits) tt
1176if {$tcl_platform(platform) == "windows"} {
1177    set graph(printout) 1
1178} else {
1179    set graph(printout) 0
1180}
1181set graph(outname) out.ps
1182set graph(outcmd) lpr
1183set WidSetList {}
1184set absSetList {}
1185
1186#----------------------------------------------------------------
1187# find location of other files relative to the current script
1188# 1st, translate links -- go six levels deep
1189foreach i {1 2 3 4 5 6} {
1190    if {[file type $expgui(script)] == "link"} {
1191        set link [file readlink $expgui(script)]
1192        if { [file  pathtype  $link] == "absolute" } {
1193h           set expgui(script) $link
1194        } {
1195            set expgui(script) [file dirname $expgui(script)]/$link
1196        }
1197    } else {
1198        break
1199    }
1200}
1201# fixup relative paths
1202if {[file pathtype $expgui(script)] == "relative"} {
1203    set expgui(script) [file join [pwd] $expgui(script)]
1204}
1205set expgui(scriptdir) [file dirname $expgui(script) ]
1206set expgui(docdir) [file join $expgui(scriptdir) doc]
1207# location for web pages, if not found locally
1208set expgui(website) 11bm.xor.aps.anl.gov/expguidoc/
1209
1210# fetch EXP file processing routines
1211source [file join $expgui(scriptdir) readexp.tcl]
1212source [file join $expgui(scriptdir) gsascmds.tcl]
1213
1214# override options with locally defined values
1215set filelist [file join $expgui(scriptdir) localconfig]
1216if {$tcl_platform(platform) == "windows"} {
1217    lappend filelist "c:/gsas.config"
1218} else {
1219    lappend filelist [file join ~ .gsas_config]
1220}
1221if {[catch {
1222    foreach file $filelist {
1223        if [file exists $file] {source $file}
1224    }
1225} errmsg]} {
1226    set msg "Error reading file $file (aka [file nativename $file]): $errmsg"
1227    MyMessageBox -parent . -title "Customize warning" \
1228        -message $msg -icon warning -type Ignore -default ignore \
1229        -helplink "expguierr.html Customizewarning"
1230}
1231#----------------------------------------------------------------
1232
1233set datalist {}
1234if {$program != "absplt"} {
1235    foreach file [glob -nocomplain [file join [pwd] widplt_*]] {
1236        source $file
1237    }
1238    foreach file [glob -nocomplain [file join $expgui(scriptdir) widplt_*]] {
1239        source $file
1240    }
1241    set WidSetList $datalist
1242}
1243
1244# create the graph
1245if [catch {
1246    set box [graph .g]
1247} errmsg] {
1248    tk_dialog .err "BLT Error" \
1249"BLT Setup Error: could not create a graph (msg: $errmsg). \
1250There is a problem with the setup of BLT on your system.
1251See the expgui.html file for more info." \
1252            error 0 "Quit"
1253exit
1254}
1255if [catch {
1256    Blt_ZoomStack $box
1257    Blt_ActiveLegend $box
1258    Blt_ClosestPoint $box
1259} errmsg] {
1260    tk_dialog .err "BLT Error" \
1261"BLT Setup Error: could not access a Blt_ routine (msg: $errmsg). \
1262The pkgIndex.tcl is probably not loading bltGraph.tcl.
1263See the expgui.html file for more info." \
1264            error 0 "Limp ahead"
1265}
1266$box config -title {}
1267setlegend $box $graph(legend)
1268
1269#frame .a -bd 8 -relief groove
1270frame .a -bd 2 -relief groove
1271
1272pack [menubutton .a.file -text File -underline 0 -menu .a.file.menu] -side left
1273menu .a.file.menu
1274pack [menubutton .a.plot -text "Plot Contents" -underline 0 -menu .a.plot.menu] -side left
1275menu .a.plot.menu
1276#.a.file.menu add cascade -label Tickmarks -menu .a.file.menu.tick
1277if {$expnam != ""} {
1278    .a.file.menu add command -label "Reload from EXP" \
1279            -command "getprofiles $expnam; plotdata $box"
1280}
1281if {$program == "absplt"} {
1282    .a.file.menu add cascade -label "Edit Abs Params" -menu .a.file.menu.edit
1283} else {
1284    .a.file.menu add command -label "Add New Curve" -command NewProfileValues
1285    .a.file.menu add cascade -label "Edit Curve" -menu .a.file.menu.edit
1286}
1287#.a.file.menu add command -label "Make PostScript" -command makepostscriptout
1288menu .a.file.menu.edit
1289.a.file.menu add cascade -label "Export plot" -menu .a.file.menu.export
1290menu .a.file.menu.export
1291.a.file.menu.export add command -label "Make PostScript" \
1292    -command makepostscriptout
1293if {$blt_version > 2.3 && $blt_version != 8.0} {
1294    source [file join $expgui(scriptdir) graceexport.tcl]
1295    .a.file.menu.export add command -label "to Grace" -command exportgrace
1296}
1297.a.file.menu.export add command -label "as .csv file" \
1298        -command makecsvfile
1299.a.file.menu add command -label Quit -command "destroy ."
1300pack [menubutton .a.options -text Options -underline 0 -menu .a.options.menu] \
1301        -side left   
1302menu .a.options.menu
1303if {$program == "absplt"} {
1304    .a.options.menu add radiobutton -label "2Theta/Tof/Eng" -value tt \
1305            -variable graph(plotunits) \
1306            -command "plotdata $box"
1307} else {
1308    .a.options.menu add radiobutton -label "2Theta" -value tt \
1309            -variable graph(plotunits) \
1310            -command "plotdata $box"
1311    .a.options.menu add command -label "Set Equiv. Wavelength" \
1312            -command "seteqwave $box"
1313}
1314.a.options.menu add radiobutton -label "d-space" -value d \
1315        -variable graph(plotunits) \
1316        -command "plotdata $box"
1317.a.options.menu add radiobutton -label "Q" -value q \
1318        -variable graph(plotunits) \
1319        -command "plotdata $box"
1320.a.options.menu add radiobutton -label "delta-d/d" -value deltad \
1321        -variable graph(plotunits) \
1322        -command "plotdata $box"
1323.a.options.menu add checkbutton -label "Include legend" \
1324        -variable graph(legend) \
1325        -command {setlegend $box $graph(legend)}
1326.a.options.menu add command -label "Set PS output" \
1327        -command setpostscriptout
1328.a.options.menu add command -label "Save Options" -underline 1 \
1329        -command "SaveOptions"
1330
1331pack [menubutton .a.help -text Help -underline 0 -menu .a.help.menu] -side right
1332menu .a.help.menu -tearoff 0
1333if {$program == "absplt"}  {
1334    .a.help.menu add command -command "MakeWWWHelp expgui.html ABSPLT" \
1335            -label "Web page"
1336} else {
1337    .a.help.menu add command -command "MakeWWWHelp expgui.html WIDPLT" \
1338            -label "Web page"
1339}
1340if {![catch {package require tkcon} errmsg]} {
1341    .a.help.menu add command -label "Open console" -command {tkcon show}
1342} elseif {$tcl_platform(platform) == "windows"} {
1343    .a.help.menu add command -label "Open console" -command {console show}
1344}
1345.a.help.menu add command -command aboutwidplot -label About
1346
1347pack .a -side top -fill both
1348pack $box -fill both -expand yes
1349
1350#----------------------------------------------------------------
1351# OK now go get the profile info
1352getprofiles $expnam
1353#----------------------------------------------------------------
1354
1355trace variable newmenu(opt) w setoptmsg
1356
1357bind . <Key-z> {BLTmanualZoom}
1358bind . <Key-Z> {BLTmanualZoom}
1359
1360proc setoptmsg {args} {
1361    global newmenu
1362    array set opttxt {
1363        0 "Cylindrical samples, Lobanov & Alte da Veiga (TOF, CW, synch.)"
1364        1 "Simple linear (TOF)"
1365        2 "Surface Roughness, Pitschke, Hermann & Muttern (Bragg-Brentano)"
1366        3 "Surface Roughness, Suortti (Bragg-Brentano)"
1367        4 "Flat plate, transmission mode"
1368    }
1369    set newmenu(opttxt) ""
1370    catch {set newmenu(opttxt) [set opttxt($newmenu(opt))]}
1371}
1372set datanum 0
1373# seems to be needed in OSX
1374update
1375wm geom . [winfo reqwidth .]x[winfo reqheight .]
1376#
1377donewaitmsg
Note: See TracBrowser for help on using the repository browser.