source: trunk/widplt @ 554

Last change on this file since 554 was 554, checked in by toby, 13 years ago

# on 2002/01/24 15:34:43, toby did:
bug fix: update plot after "Apply" with change in absorption coeff.
  • Property rcs:author set to toby
  • Property rcs:date set to 2002/01/24 15:34:43
  • Property rcs:lines set to +2 -1
  • Property rcs:rev set to 1.10
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 33.2 KB
Line 
1#!/usr/local/bin/wish
2# $Id: widplt 554 2009-12-04 23:08:07Z toby $
3set Revision {$Revision: 554 $ $Date: 2009-12-04 23:08:07 +0000 (Fri, 04 Dec 2009) $}
4bind all <Control-KeyPress-c> {destroy .}
5set expnam [lindex $argv 0]
6if {$expnam != ""} {
7    if {[string toupper [file extension $expnam]] != ".EXP"} {
8        append expnam ".EXP"
9    }
10}
11set program [file tail $argv0]
12
13if [catch {package require BLT} errmsg] {
14    tk_dialog .err "BLT Error" "Error -- Unable to load the BLT package" \
15            error 0 Quit
16    destroy .
17}
18
19# handle Tcl/Tk v8+ where BLT is in a namespace
20#  use the command so that it is loaded
21catch {blt::graph}
22catch {
23    namespace import blt::graph
24    namespace import blt::vector
25}
26# old versions of blt don't report a version number
27if [catch {set blt_version}] {set blt_version 0}
28
29set expgui(debug) 0
30catch {if $env(DEBUG) {set expgui(debug) 1}}
31#set expgui(debug) 1
32
33proc waitmsg {message} {
34    set w .wait
35    # kill any window/frame with this name
36    catch {destroy $w}
37    pack [frame $w]
38    frame $w.bot -relief raised -bd 1
39    pack $w.bot -side bottom -fill both
40    frame $w.top -relief raised -bd 1
41    pack $w.top -side top -fill both -expand 1
42    label $w.msg -justify left -text $message -wrap 3i
43    catch {$w.msg configure -font \
44                -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-*
45    }
46    pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
47    label $w.bitmap -bitmap info
48    pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
49    update
50}
51
52proc donewaitmsg {} {
53    catch {destroy .wait}
54    update
55}
56
57if {$expnam != ""} {waitmsg "Loading $expnam, Please wait"}
58
59# get profile/absorption information out from an EXP file
60proc getprofiles {expnam} {
61    global WidSetList absSetList wave XY UVWP lblarr ttrange
62
63    if {[expload $expnam] == -1} {
64        tk_dialog .err "EXP Error" "Warning -- Unable to read $expnam" \
65                error 0 OK
66        return
67    }
68    mapexp
69
70    global expmap
71    foreach hist $expmap(powderlist) {
72        # wavelength
73        set lambda1 [histinfo $hist lam1]
74        # data range
75        set drange [string trim [readexp "HST  $hist TRNGE"]]
76        global program
77        if {$program == "absplt"} {
78            global ABS
79            set ABS($hist) [list \
80                    [histinfo $hist abscor1] \
81                    [histinfo $hist abscor2] \
82                    [histinfo $hist abstype] \
83                    $drange \
84                    "Hist $hist" \
85                    $expmap(htype_$hist)]
86            lappend absSetList $hist
87        } else {
88            foreach phase $expmap(phaselist_$hist) {
89                set ptype [hapinfo $hist $phase proftype]
90                set pterms  [hapinfo $hist $phase profterms]
91                set key "H${hist}P${phase}"
92                # make sure the key is not present already
93                if {[lsearch $WidSetList $key] == -1} {
94                    lappend WidSetList $key
95                }
96                set lblarr($key) "Histogram $hist Phase $phase"
97                set wave($key) $lambda1
98                set ttrange($key) $drange
99                if {$ptype == 1} {
100                    set UVWP($key) [list [hapinfo $hist $phase pterm1] \
101                            [hapinfo $hist $phase pterm2] \
102                            [hapinfo $hist $phase pterm3] 0]
103                    set XY($key) {0 0}
104                } elseif {$ptype == 2} {
105                    set UVWP($key) [list [hapinfo $hist $phase pterm1] \
106                            [hapinfo $hist $phase pterm2] \
107                            [hapinfo $hist $phase pterm3] \
108                            [hapinfo $hist $phase pterm9]]
109                    set XY($key) [list [hapinfo $hist $phase pterm4] \
110                            [hapinfo $hist $phase pterm5]]
111                } elseif {$ptype == 3 || $ptype == 4} {
112                    set UVWP($key) [list [hapinfo $hist $phase pterm1] \
113                            [hapinfo $hist $phase pterm2] \
114                            [hapinfo $hist $phase pterm3] \
115                            [hapinfo $hist $phase pterm4]]
116                    if {$ptype == 3} {
117                        set XY($key) [list [hapinfo $hist $phase pterm5] \
118                                [hapinfo $hist $phase pterm6]]
119                    } else {
120                        set XY($key) [list [hapinfo $hist $phase pterm5] 0]
121                    }
122                }
123            }
124        }
125    }
126    MakeCascadeMenus
127}
128
129proc makepostscriptout {} {
130    global graph box
131    if !$graph(printout) {
132        set out [open "| $graph(outcmd) >& widplt.msg" w]
133        catch {
134            puts $out [$box postscript output -landscape 1 \
135                -decorations no -height 7.i -width 9.5i]
136            close $out
137        } msg
138        catch {
139            set out [open widplt.msg r]
140            if {$msg != ""} {append msg "\n"}
141            append msg [read $out]
142            close $out
143            file delete widplt.msg
144        }
145        if {$msg != ""} {
146            tk_dialog .msg "file created" \
147                    "Postscript file processed with command \
148                    $graph(outcmd). Result: $msg" "" 0 OK
149        } else {
150            tk_dialog .msg "file created" \
151                    "Postscript file processed with command \
152                    $graph(outcmd)" "" 0 OK
153        }
154    } else {
155        $box postscript output $graph(outname) -landscape 1 \
156                -decorations no -height 7.i -width 9.5i   
157        tk_dialog .msg "file created" \
158                "Postscript file $graph(outname) created" "" 0 OK
159    }
160}
161
162proc setprintopt {page} {
163    global graph
164    if $graph(printout) {
165        $page.4.1 config -fg black
166        $page.4.2 config -fg black -state normal
167        $page.6.1 config -fg #888
168        $page.6.2 config -fg #888 -state disabled
169    } else {
170        $page.4.1 config -fg #888
171        $page.4.2 config -fg #888 -state disabled
172        $page.6.1 config -fg black
173        $page.6.2 config -fg black -state normal
174    }
175}
176
177proc seteqwave {top} {
178    global graph
179    set box .wave
180    catch {destroy $box}
181    toplevel $box
182    focus $box
183    grab $box
184    pack [frame $box.1] -side top
185    pack [label $box.1.a -text "Equivalent wavelength:"] -side top
186    pack [entry $box.1.b -textvariable graph(equivwave)] -side top
187    pack [frame $box.2] -side top
188    pack [button $box.2.c -text Clear -command "set graph(equivwave) {}; destroy $box"]
189    pack [button $box.2.u -text Use -command "destroy $box"]
190    tkwait window $box
191    plotdata $top
192}
193
194proc setpostscriptout {} {
195    global graph tcl_platform
196    set box .out
197    catch {destroy $box}
198    toplevel $box
199    focus $box
200    grab $box
201    pack [frame $box.4] -side top -anchor w -fill x
202    pack [checkbutton $box.4.a -text "Write PostScript files" \
203            -variable graph(printout) -offvalue 0 -onvalue 1 \
204            -command "setprintopt $box"] -side left -anchor w
205    pack [entry $box.4.2 -textvariable graph(outname)] -side right -anchor w
206    pack [label $box.4.1 -text "PostScript file name:"] -side right -anchor w
207    pack [frame $box.6] -side top -anchor w -fill x
208    pack [checkbutton $box.6.a -text "Print PostScript files" \
209            -variable graph(printout) -offvalue 1 -onvalue 0 \
210            -command "setprintopt $box" ] -side left -anchor w
211    pack [entry $box.6.2 -textvariable graph(outcmd)] -side right -anchor w
212    pack [label $box.6.1 -text "Command to print files:"] -side right -anchor w
213
214    pack [button $box.a -text "Close" -command "destroy $box"] -side top   
215    if {$tcl_platform(platform) == "windows"} {
216        set graph(printout) 1
217        $box.4.a config -state disabled
218        $box.6.a config -fg #888 -state disabled
219    }
220    setprintopt $box
221}
222
223proc aboutwidplot {} {
224    global Revision
225    tk_dialog .warn About "
226GSAS\n\
227A. C. Larson and\n R. B. Von Dreele,\n LANSCE, Los Alamos\n\n\
228WIDPLT/ABSPLT\nB. Toby, NIST\nNot subject to copyright\n\n\
229$Revision\n\
230" {} 0 OK
231}
232
233proc nextcolor {var} {
234    set num [uplevel "incr $var"]
235    return [lindex {red green blue cyan magenta yellow} [expr $num % 6]]
236}
237
238proc NewProfileValues {} {
239    global newmenu datanum
240    incr datanum
241    set base .edit
242    catch {destroy $base}
243    toplevel $base
244    focus $base
245    grab $base
246    wm title $base {Enter a new profile}
247    MakeEditProfileBox $base
248    grid [button $base.bttn1 -text Add \
249            -command "AddProfileValues; destroy $base"] -row 6 -column 6
250    grid [button $base.bttn2 -text Quit \
251            -command "destroy $base"] -row 6 -column 7
252    set newmenu(U) 0
253    set newmenu(V) 0
254    set newmenu(W) 0
255    set newmenu(P) 0
256    set newmenu(X) 0
257    set newmenu(Y) 0
258    set newmenu(min) 5
259    set newmenu(max) 100
260    set newmenu(label) "Curve #$datanum"
261    set newmenu(wave) 1.5418
262}
263
264proc AddProfileValues {} {
265    global newmenu datanum lblarr WidDisplay UVWP XY WidSetList ttrange wave
266    set key new$datanum
267    set UVWP($key) [list $newmenu(U) $newmenu(V) $newmenu(W) $newmenu(P)]
268    set XY($key) [list $newmenu(X) $newmenu(Y)]
269    set lblarr($key) $newmenu(label)
270    set ttrange($key) "$newmenu(min) $newmenu(max)"
271    set wave($key) $newmenu(wave)
272    lappend WidSetList $key
273    MakeCascadeMenus
274}
275
276proc editProfileValues {key} {
277    global newmenu WidSetList lblarr
278
279    set base .edit
280    catch {destroy $base}
281    toplevel $base
282    wm title $base {Edit a profile}
283    MakeEditProfileBox $base
284    grid [button $base.bttn1 -text Apply \
285            -command "SaveProfileEdits $key"] -row 6 -column 6
286    grid [button $base.bttn2 -text Close \
287            -command "destroy $base"] -row 6 -column 7
288
289    global UVWP XY ttrange wave lblarr
290    set newmenu(label) $lblarr($key)
291    set newmenu(U) [lindex $UVWP($key) 0]
292    set newmenu(V) [lindex $UVWP($key) 1]
293    set newmenu(W) [lindex $UVWP($key) 2]
294    set newmenu(P) [lindex $UVWP($key) 3]
295    set newmenu(X) [lindex $XY($key) 0]
296    set newmenu(Y) [lindex $XY($key) 1]
297    set newmenu(min) [lindex $ttrange($key) 0]
298    set newmenu(max) [lindex $ttrange($key) 1]
299    set newmenu(wave) $wave($key)
300}
301
302proc SaveProfileEdits {key} {
303    global newmenu datanum lblarr WidDisplay UVWP XY WidSetList ttrange wave box
304    set UVWP($key) [list $newmenu(U) $newmenu(V) $newmenu(W) $newmenu(P)]
305    set XY($key) [list $newmenu(X) $newmenu(Y)]
306    set ttrange($key) [list $newmenu(min) $newmenu(max)]
307    set wave($key) $newmenu(wave)
308    set lblarr($key) $newmenu(label)
309    MakeCascadeMenus
310    plotdata $box
311}
312
313proc MakeEditProfileBox {base} {
314    grid [label $base.lb7 -text Gaussian] -row 2 -column 1  -columnspan 4
315    grid [label $base.lb8 -text Lorentz] -row 2 -column 6  -columnspan 2
316    grid [label $base.lb1 -text U] -row 3 -column 1
317    grid [label $base.lb2 -text V] -row 3 -column 2
318    grid [label $base.lb3 -text W] -row 3 -column 3
319    grid [label $base.lb4 -text P] -row 3 -column 4
320    grid [label $base.lb5 -text X] -row 3 -column 6
321    grid [label $base.lb6 -text Y] -row 3 -column 7
322    grid [entry $base.ent1 -textvariable newmenu(U) -width 12] \
323            -row 4 -column 1
324    grid [entry $base.ent2 -textvariable newmenu(V) -width 12] \
325            -row 4 -column 2
326    grid [entry $base.ent3 -textvariable newmenu(W) -width 12] \
327            -row 4 -column 3
328    grid [entry $base.ent4 -textvariable newmenu(P) -width 12] \
329            -row 4 -column 4
330    grid [entry $base.ent5 -textvariable newmenu(X) -width 12] \
331            -row 4 -column 6
332    grid [entry $base.ent6 -textvariable newmenu(Y) -width 12] \
333            -row 4 -column 7
334
335    grid [label $base.lb9 -text label] -row 5 -column 1  -sticky e
336    grid [entry $base.ent7 -textvariable newmenu(label)]\
337            -row 5 -column 2  -columnspan 3 -sticky ew
338
339    grid [label $base.lb13 -text Wavelength] -row 5 -column 5 -columnspan 2
340    grid [entry $base.ent11 -textvariable newmenu(wave) -width 8] \
341            -row 5 -column 7
342
343    grid [label $base.lb11 -text {2Theta Min}] -row 6 -column 1
344    grid [entry $base.ent9 -textvariable newmenu(min) -width 9] \
345            -row 6 -column 2
346    grid [label $base.lb12 -text {2Theta Max}] -row 6 -column 3
347    grid [entry $base.ent10 -textvariable newmenu(max) -width 9] \
348            -row 6 -column 4
349    grid rowconfigure $base 5 -weight 0 -pad 40
350    grid columnconfigure $base 5 -weight 0 -minsize 25
351}
352
353proc editAbsValues {key} {
354    global newmenu absSetList lblarr
355
356    set base .edit
357    catch {destroy $base}
358    toplevel $base
359    wm title $base {Edit Absorption Values}
360    MakeEditAbsBox $base
361    grid [button $base.bttn1 -text Apply \
362            -command "SaveAbsorptionEdits $key"] -row 8 -column 6
363    grid [button $base.bttn2 -text Close \
364            -command "destroy $base"] -row 8 -column 7
365
366    global ABS
367    foreach v {1 2 opt range label htype} val $ABS($key) {
368        set newmenu($v) $val
369    }
370    foreach {newmenu(min) newmenu(max)} $newmenu(range) {}
371    if {[string range $newmenu(htype) 2 2] == "T"} {
372        set newmenu(units) "TOF (ms):"
373    } elseif {[string range $newmenu(htype) 2 2] == "C"} {
374        set newmenu(units) "2-Theta (deg):"
375    } elseif {[string range $newmenu(htype) 2 2] == "E"} {
376        set newmenu(units) "Energy (KeV):"
377    }
378}
379
380proc SaveAbsorptionEdits {key} {
381    global ABS newmenu box
382    set ABS($key) [list \
383            $newmenu(1) $newmenu(2) $newmenu(opt) \
384            [list $newmenu(min) $newmenu(max)] \
385            $newmenu(label) \
386            [lindex $ABS($key) 5]]
387    plotdata $box
388}
389
390proc MakeEditAbsBox {base} {
391    grid [label $base.lb1 -text "Absorption Coefficients"] \
392            -row 2 -column 1  -columnspan 2
393    grid [label $base.lb1a -text "1"] -row 3 -column 1
394    grid [label $base.lb2a -text "2"] -row 3 -column 2
395    grid [label $base.lb3 -text Absorption] -row 2 -column 6  -columnspan 2
396    grid [label $base.lb3a -text Function] -row 3 -column 6  -columnspan 2
397    grid [entry $base.ent1 -textvariable newmenu(1) -width 12] \
398            -row 4 -column 1
399    grid [entry $base.ent2 -textvariable newmenu(2) -width 12] \
400            -row 4 -column 2
401    eval tk_optionMenu $base.m1 newmenu(opt) 0 1 2 3 4
402    grid $base.m1 -row 4 -column 6 -columnspan 2
403
404    grid [label $base.lb8 -textvariable newmenu(opttxt) \
405          -wrap 180 -justify left] -row 5 -column 1  -sticky e -columnspan 7
406    grid [label $base.lb9 -text label] -row 7 -column 1  -sticky e
407    grid [entry $base.ent7 -textvariable newmenu(label)]\
408            -row 7 -column 2  -columnspan 3 -sticky ew
409
410    grid [frame $base.f] -row 8 -column 1 -columnspan 4
411    grid [label $base.f.1 -textvariable newmenu(units)] -row 0 -column 1
412    grid [label $base.f.2 -text {Min}] -row 0 -column 2
413    grid [entry $base.f.3 -textvariable newmenu(min) -width 9] \
414            -row 0 -column 3
415    grid [label $base.f.4 -text {Max}] -row 0 -column 4
416    grid [entry $base.f.5 -textvariable newmenu(max) -width 9] \
417            -row 0 -column 5
418    grid rowconfigure $base 6 -min 15
419}
420
421proc plotdata {top} {
422    global program graph
423    global UVWP XY wave lblarr WidSetList WidDisplay ttrange
424    global ABS absSetList AbsDisplay
425    if {$graph(plotunits) == "d"} {
426        $top xaxis configure -title "d (A)"
427    } elseif {$graph(plotunits) == "q"} {
428        $top xaxis configure -title "Q (A-1)"
429    } elseif {$graph(equivwave) == ""} {
430        $top xaxis configure -title "2Theta"
431    } else {
432        $top xaxis configure -title "2Theta @ $graph(equivwave)"
433    }
434    if {$program == "absplt"} {
435        $top yaxis config -title {Abs. Corr.}
436    } else {
437        $top yaxis config -title {FWHM}
438    }
439    $top yaxis configure -min 0
440    $top xaxis configure -min 0
441    # delete all graphs
442    eval $top element delete [$top element names]
443    set num -1
444    if {$program == "absplt"} {
445        foreach item $absSetList {
446            if {$AbsDisplay($item)} {
447                set ttlist {}
448                set abscor1 [lindex $ABS($item) 0]
449                set abscor2 [lindex $ABS($item) 1]
450                set abstype [lindex $ABS($item) 2]
451                set abslbl [lindex $ABS($item) 4]
452                set htype [lindex $ABS($item) 5]
453                set ttmin [lindex [lindex $ABS($item) 3] 0]
454                set ttmax [lindex [lindex $ABS($item) 3] 1]
455                set ttstep [expr {($ttmax - $ttmin)/50.}]
456                if {$graph(equivwave) == ""} {
457                    if {[string range $htype 2 2] == "T"} {
458                        $top xaxis configure -title "TOF (ms)"
459                    } elseif {[string range $htype 2 2] == "E"} {
460                        $top xaxis configure -title "Energy (KeV)"
461                    }
462                }
463                for     {set tt $ttmin} \
464                        {$tt <= $ttmax} \
465                        {set tt [expr {$tt + $ttstep}]} {
466                    catch {
467                        lappend abslist [AbsorbCalc \
468                                $item $tt $abscor1 $abscor2 $abstype]
469                        lappend ttlist $tt
470                    }
471                }
472                if {[llength $ttlist] == 0} continue
473                if {$graph(plotunits) == "d"} {
474                    set ttlist [tod $ttlist $item]
475                } elseif {$graph(plotunits) == "q"} {
476                    set ttlist [toQ $ttlist $item]
477                }
478                catch {
479                    $top element create $item
480                }
481                $top element config $item -label $abslbl \
482                        -xdata $ttlist -ydata $abslist -linewidth 3 \
483                        -color [nextcolor num]
484            }
485        }
486    } else {
487        foreach item $WidSetList {
488            if {$WidDisplay($item)} {
489                if {[expr [lindex $XY($item) 0] + [lindex $XY($item) 1]] != 0} {
490                    set lflag 1
491                } else {
492                    set lflag 0
493                }
494                set ttlist {}
495                set fwhmlist {}
496                set lfwhmlist {}
497                set tfwhmlist {}
498                # loop over two-theta
499                for     {set tt [lindex $ttrange($item) 0]} \
500                        {$tt <= [lindex $ttrange($item) 1]} \
501                        {set tt [expr $tt + 4]} {
502                    set lfwhm 0
503                    catch {
504                        if {$graph(plotunits) == "d"} {
505                            lappend ttlist [tt2d $wave($item) $tt ]
506                            set gfwhm [deltad $wave($item) $tt \
507                                    [eval FWHM $tt $UVWP($item)]]
508                            lappend fwhmlist $gfwhm
509                            if $lflag {
510                                set lfwhm [deltad $wave($item) $tt \
511                                        [eval LFWHM $tt $XY($item)]]
512                                lappend lfwhmlist $lfwhm
513                            }
514                        } elseif {$graph(plotunits) == "q"} {
515                            lappend ttlist [tt2Q $wave($item) $tt ]
516                            set gfwhm [deltaQ $wave($item) $tt \
517                                    [eval FWHM $tt $UVWP($item)]]
518                            lappend fwhmlist $gfwhm
519                            if $lflag {
520                                set lfwhm [deltaQ $wave($item) $tt \
521                                        [eval LFWHM $tt $XY($item)]]
522                                lappend lfwhmlist $lfwhm
523                            }
524                        } elseif {$graph(equivwave) == ""} {
525                            lappend ttlist $tt
526                            set gfwhm [eval FWHM $tt $UVWP($item)]
527                            lappend fwhmlist $gfwhm
528                            if $lflag {
529                                set lfwhm [eval LFWHM $tt $XY($item)]
530                                lappend lfwhmlist $lfwhm
531                            }
532                        } else {
533                            set tteq [ttequiv $wave($item) $tt $graph(equivwave)]
534                            if {$tteq != ""} {
535                                lappend ttlist $tteq
536                                set gfwhm [delta2teq $wave($item) $tt \
537                                        [eval FWHM $tt $UVWP($item)] $graph(equivwave)]
538                                lappend fwhmlist $gfwhm
539                                if $lflag {
540                                    set lfwhm [delta2teq $wave($item) $tt \
541                                            [eval LFWHM $tt $XY($item)] $graph(equivwave)]
542                                    lappend lfwhmlist $lfwhm
543                                }
544                            }
545                        }
546                        # assume FWHM add as square roots
547                        lappend tfwhmlist \
548                                [expr sqrt($gfwhm*$gfwhm + $lfwhm*$lfwhm)]
549                    }
550                }
551                if $lflag {
552                    catch {
553                        $top element create ${item}G -label "$lblarr($item) G"
554                    }
555                    $top element config ${item}G \
556                            -xdata $ttlist -ydata $fwhmlist -linewidth 3 \
557                            -color [nextcolor num]
558                    catch {
559                        $top element create ${item}L -label "$lblarr($item) L"
560                    }
561                    $top element config ${item}L \
562                            -xdata $ttlist -ydata $lfwhmlist -linewidth 3 \
563                            -color [nextcolor num]
564                }
565                catch {
566                    $top element create $item -label $lblarr($item)
567                }
568                $top element config $item \
569                        -xdata $ttlist -ydata $tfwhmlist -linewidth 3 \
570                        -color [nextcolor num]
571            }
572        }
573    }
574}
575proc AbsorbCalc {hst ttof abscor1 abscor2 mode} {
576    global expmap
577    set htype $expmap(htype_$hst)
578    set pi [expr {2.*acos(0.)}]
579    # determine sin(theta) & lambda
580    if {[string range $htype 2 2] == "T"} {
581        set sth [expr {sin($pi * abs([histinfo $hst tofangle])/360.)}]
582        set lamb [expr {2 * [toftod $ttof $hst] * $sth}]
583    } elseif {[string range $htype 2 2] == "C"} {
584        set lamb [histinfo $hst lam1]
585        set sth [expr {sin($pi * ($ttof - [histinfo $hst zero]/100.)/360.)}]
586    } elseif {[string range $htype 2 2] == "E"} {
587        set lamb [expr { 12.398 / $ttof}]
588        set sth [expr {sin($pi * [histinfo $hst lam1] / 360.)}]
589    }
590    set sth2 [expr $sth*$sth]
591    set cth2 [expr {1 - $sth2}]
592    set cth  [expr {sqrt($cth2)}]
593
594    if {$mode == 0} {
595        set murl [expr {$abscor1 * $lamb}]; # Lobanov & Alte da Veiga
596        if {$murl <= 3} {
597            set TERM0 [expr { 16.0/(3*$pi) }]
598            set TERM1 [expr { (25.99978-0.01911*pow($sth2,0.25)) * \
599                    exp(-0.024551*$sth2) + 0.109561*sqrt($sth2)-26.04556 }]
600            set TERM2 [expr {-0.02489 - 0.39499*$sth2 + \
601                    1.219077*pow($sth2,1.5) - 1.31268*pow($sth2,2) + \
602                    0.871081*pow($sth2,2.5) - 0.2327*pow($sth2,3) }]
603            set TERM3 [expr { 0.003045+0.018167*$sth2 - 0.03305*pow($sth2,2) }]
604            set TRANS [expr { -$TERM0*$murl - $TERM1*pow($murl,2) - \
605                    $TERM2*pow($murl,3) - $TERM3*pow($murl,4) }]
606            if {$TRANS <= -20.0} {
607                set TRANS 2.06E-9
608            } elseif {$TRANS >= 20.0} {
609                set TRANS 4.85E8
610            } else {
611                set TRANS [expr {exp($TRANS)}]
612            }
613        } else {
614            set TERM1 [expr { 1.433902 + 11.07504*$sth2 - \
615                    8.77629*pow($sth2,2) + 10.02088*pow($sth2,3) - \
616                    3.36778*pow($sth2,4) }]
617            set TERM2 [expr { (0.013869 - 0.01249*$sth2) * \
618                    exp(3.27094*$sth2) + \
619                    (0.337894 + 13.77317*$sth2) / \
620                    pow((1.0+11.53544*$sth2),1.555039) }]
621            set TERM3 [expr { 1.933433 / pow((1.0+23.12967*$sth2),1.686715) - \
622                    0.13576*sqrt($sth2) + 1.163198}]
623            set TERM4 [expr { 0.044365 - 0.4259 / \
624                    pow((1.0+0.41051*$sth2),148.4202) }]
625            set TRANS [expr { ($TERM1-$TERM4) / \
626                    pow((1.0+$TERM2*($murl-3.0)),$TERM3) + $TERM4 }]
627            set TRANS [expr { $TRANS/100.0}]
628        }
629    } elseif {$mode == 1} {
630        #!Simple linear absorption
631        set TRANS [expr { -$abscor1*$lamb }]
632        set TRANS [expr { exp($TRANS) }]
633    } elseif {$mode == 2} {
634        #!Pitschke, Hermann & Muttern - surface roughness
635        set TERM1 [expr { 1.0/$sth-$abscor2/$sth2 }]
636        set TERM2 [expr { 1.0-$abscor1*(1.0+$abscor2) }]
637        set TRANS [expr { (1.0-$abscor1*$TERM1)/$TERM2 }]
638    } elseif {$mode == 3} {
639        #!Suortti - surface roughness
640        set TERM1 [expr { exp(-$abscor2/$sth) }]
641        set TERM2 [expr { $abscor1 + (1.0-$abscor1) * exp(-$abscor2) }]
642        set TRANS [expr { ($abscor1 +(1.0-$abscor1) * $TERM1)/$TERM2 }]
643    } elseif {$mode == 4} {
644        #!Plate transmission absorption
645        if {abs($abscor2) < 1} {
646            #!Use symmetric fxn. if phi 1 deg or less
647            set TRANS [expr { -$abscor1*$lamb/$cth }]
648            set TRANS [expr { exp($TRANS) }]
649        } else {
650            #!Bigger tilts
651            set SPH [expr { sin($pi/180. * $abscor2) }]
652            set CPH [expr { cos($pi/180. * $abscor2) }]
653            set CTPP [expr { $CPH*$cth - $SPH*$sth }]
654            set CTMP [expr { $CPH*$cth + $SPH*$sth }]
655            set T [expr { -$abscor1*$lamb }]
656            set T1 [expr { $T / $CTPP }]
657            set TRANS1 [expr { exp($T1) }]
658            set T2 [expr { $T/$CTMP }]
659            set TRANS2 [expr { exp($T2) }]
660            set TB [expr { $T * (1.0 - $CTMP / $CTPP) }]
661            set TRANS [expr { ($TRANS1 - $TRANS2) / $TB }]
662        }
663    }
664    return $TRANS
665}
666
667# save some of the global options in ~/.gsas_config
668proc SaveOptions {} {
669    global graph
670    set fp [open [file join ~ .gsas_config] a]
671    puts $fp "set graph(legend) $graph(legend)"
672    puts $fp "set graph(printout) $graph(printout)"
673    puts $fp "set graph(outname) $graph(outname)"
674    puts $fp "set graph(outcmd) $graph(outcmd)"
675    puts $fp "set graph(plotunits) $graph(plotunits)"
676    puts $fp "set graph(equivwave) $graph(equivwave)"
677    close $fp
678}
679
680proc MakeCascadeMenus {} {
681    global WidSetList lblarr box absSetList ABS
682    .a.plot.menu delete 0 end
683    .a.file.menu.edit delete 0 end
684    global program
685    if {$program != "absplt"} {
686        foreach item $WidSetList {
687            .a.plot.menu add checkbutton -label $lblarr($item) \
688                    -command "plotdata $box" -variable WidDisplay($item)
689            .a.file.menu.edit add command -label $lblarr($item) \
690                    -command "editProfileValues $item"
691        }
692    } else {
693        foreach item $absSetList {
694            .a.plot.menu add checkbutton -label [lindex $ABS($item) 4] \
695                    -command "plotdata $box" -variable AbsDisplay($item)
696            .a.file.menu.edit add command -label [lindex $ABS($item) 4] \
697                    -command "editAbsValues $item"
698        }
699    }
700}
701#-------------------------------------------------------------------------
702# converts 2theta(deg) to Q (A-1)
703proc tt2Q {lambda twotheta} {
704    set pi 3.14159
705    set torad [expr $pi / 360.]
706    return [expr 4 * $pi / ($lambda) * sin (($twotheta) * $torad)]
707}
708
709# converts Q (A-1) to 2theta(deg)
710proc Q2tt {lambda Q} {
711    set pi 3.14159
712    set todeg [expr 360. / $pi]
713    set asinarg [expr ($lambda) * $Q * 0.25 / $pi]
714    if {$asinarg <= 1} {
715        return [expr $todeg * asin ($asinarg)]
716    }
717    return {}
718}
719
720# converts a FWHM in 2theta(deg) to a FWHM in Q (A-1)
721proc deltaQ {lambda twotheta FWHM} {
722    return [expr [tt2Q $lambda $twotheta+($FWHM/2.)] - \
723                 [tt2Q $lambda $twotheta-($FWHM/2.)] ]
724}
725
726# converts 2theta(deg) to d (A)
727proc tt2d {lambda twotheta} {
728    set pi 3.14159
729    set torad [expr $pi / 360.]
730    return [expr 0.5 * ($lambda) / sin (($twotheta) * $torad)]
731}
732
733# converts d (A) to 2theta(deg)
734proc d2tt {lambda d} {
735    set pi 3.14159
736    set todeg [expr 360. / $pi]
737    set asinarg [expr ($lambda) * 0.5 / $d]
738    if {$asinarg <= 1} {
739        return [expr $todeg * asin ($asinarg)]
740    }
741    return {}
742}
743
744# converts a FWHM in 2theta(deg) to a FWHM in Q (A-1)
745proc deltad {lambda twotheta FWHM} {
746    return [expr [tt2d $lambda $twotheta-($FWHM/2.)] - \
747                 [tt2d $lambda $twotheta+($FWHM/2.)] ]
748}
749
750# computes an equivalent 2theta at a different wavelength
751proc ttequiv {lambda twotheta lambda_eq} {
752    return [Q2tt $lambda_eq [tt2Q $lambda $twotheta]]
753}
754
755# converts a FWHM in 2theta(deg) to a FWHM at in 2theta
756# at a different wavelength
757proc delta2teq {lambda twotheta FWHM lambda_eq} {
758    return [expr [Q2tt $lambda_eq [tt2Q $lambda $twotheta+($FWHM/2.)]] - \
759                 [Q2tt $lambda_eq [tt2Q $lambda $twotheta-($FWHM/2.)]] ]
760}
761
762# convert x values to d-space
763proc tod {xlist hst} {
764    global expmap
765    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
766        return [toftod $xlist $hst]
767    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
768        return [tttod $xlist $hst]
769    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
770        return [engtod $xlist $hst]
771    } else {
772        return {}
773    }
774}
775
776# convert tof to d-space
777proc toftod {toflist hst} {
778    set difc [expr {[histinfo $hst difc]/1000.}]
779    set difc2 [expr {$difc*$difc}]
780    set difa [expr {[histinfo $hst difa]/1000.}]
781    set zero [expr {[histinfo $hst zero]/1000.}]
782    set ans {}
783    foreach tof $toflist {
784        if {$tof == 0.} {
785            lappend ans 0.
786        } elseif {$tof == 1000.} {
787            lappend ans 1000.
788        } else {
789            set td [expr {$tof-$zero}]
790            lappend ans [expr {$td*($difc2+$difa*$td)/ \
791                    ($difc2*$difc+2.0*$difa*$td)}]
792        }
793    }
794    return $ans
795}
796
797# convert two-theta to d-space
798proc tttod {twotheta hst} {
799    set lamo2 [expr {0.5 * [histinfo $hst lam1]}]
800    set zero [expr [histinfo $hst zero]/100.]
801    set ans {}
802    set cnv [expr {acos(0.)/180.}]
803    foreach tt $twotheta {
804        if {$tt == 0.} {
805            lappend ans 99999.
806        } elseif {$tt == 1000.} {
807            lappend ans 0.
808        } else {
809            lappend ans [expr {$lamo2 / sin($cnv*($tt-$zero))}]
810        }
811    }
812    return $ans
813}
814
815# convert energy (edx-ray) to d-space
816# (note that this ignores the zero correction)
817proc engtod {eng hst} {
818    set lam [histinfo $hst lam1]
819    set zero [histinfo $hst zero]
820    set ans {}
821    set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
822    foreach e $eng {
823        if {$e == 0.} {
824            lappend ans 1000.
825        } elseif {$e == 1000.} {
826            lappend ans 0.
827        } else {
828            lappend ans [expr {$v/$e}]
829        }
830    }
831    return $ans
832}
833
834# convert x values to Q
835proc toQ {xlist hst} {
836    global expmap
837    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
838        return [toftoQ $xlist $hst]
839    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
840        return [tttoQ $xlist $hst]
841    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
842        return [engtoQ $xlist $hst]
843    } else {
844        return {}
845    }
846}
847# convert tof to Q
848proc toftoQ {toflist hst} {
849    set difc [expr {[histinfo $hst difc]/1000.}]
850    set difc2 [expr {$difc*$difc}]
851    set difa [expr {[histinfo $hst difa]/1000.}]
852    set zero [expr {[histinfo $hst zero]/1000.}]
853    set 2pi [expr {4.*acos(0.)}]
854    set ans {}
855    foreach tof $toflist {
856        if {$tof == 0.} {
857            lappend ans 99999.
858        } elseif {$tof == 1000.} {
859            lappend ans 0.
860        } else {
861            set td [expr {$tof-$zero}]
862            lappend ans [expr {$2pi * \
863                    ($difc2*$difc+2.0*$difa*$td)/($td*($difc2+$difa*$td))}]
864        }
865    }
866    return $ans
867}
868
869# convert two-theta to Q
870proc tttoQ {twotheta hst} {
871    set lamo2 [expr {0.5 * [histinfo $hst lam1]}]
872    set zero [expr [histinfo $hst zero]/100.]
873    set ans {}
874    set cnv [expr {acos(0.)/180.}]
875    set 2pi [expr {4.*acos(0.)}]
876    foreach tt $twotheta {
877        if {$tt == 0.} {
878            lappend ans 0.
879        } elseif {$tt == 1000.} {
880            lappend ans 1000.
881        } else {
882            lappend ans [expr {$2pi * sin($cnv*($tt-$zero)) / $lamo2}]
883        }
884    }
885    return $ans
886}
887# convert energy (edx-ray) to Q
888# (note that this ignores the zero correction)
889proc engtoQ {eng hst} {
890    set lam [histinfo $hst lam1]
891    set zero [histinfo $hst zero]
892    set ans {}
893    set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
894    set 2pi [expr {4.*acos(0.)}]
895    foreach e $eng {
896        if {$e == 0.} {
897            lappend ans 0.
898        } elseif {$e == 1000.} {
899            lappend ans 1000.
900        } else {
901            lappend ans [expr {$2pi * $e / $v}]
902        }
903    }
904    return $ans
905}
906proc sind {angle} {
907    return [expr {sin($angle*acos(0.)/90.)}]
908}
909
910proc FWHM {tt U V W P} {
911    set pi 3.14159
912    set torad [expr $pi / 360.]
913    # tan theta
914    set tantt [expr tan($tt * $torad ) ]
915    set costt [expr cos($tt * $torad ) ]
916    return [expr sqrt \
917            (8.* log(2) * ($U * $tantt * $tantt + $V * $tantt + $W \
918            + $P / ($costt * $costt))) / 100.]
919}
920proc LFWHM {tt X Y} {
921    set pi 3.14159
922    set torad [expr $pi / 360.]
923    # tan theta
924    set tantt [expr tan($tt * $torad ) ]
925    set costt [expr cos($tt * $torad ) ]
926    return [expr ($X / $costt + $Y * $tantt) / 100.]
927}
928
929proc setlegend {box legend} {
930    global blt_version
931    if {$blt_version >= 2.3 && $blt_version < 8.0} {
932        if $legend {
933            $box legend config -hide no
934        } else {
935            $box legend config -hide yes
936        }
937    } else {
938        if $legend {
939            $box legend config -mapped yes
940        } else {
941            $box legend config -mapped no
942        }
943    }
944}
945
946set graph(legend) 0
947set graph(equivwave) {}
948set graph(plotunits) tt
949if {$tcl_platform(platform) == "windows"} {
950    set graph(printout) 1
951} else {
952    set graph(printout) 0
953}
954set graph(outname) out.ps
955set graph(outcmd) lpr
956set WidSetList {}
957set absSetList {}
958
959#----------------------------------------------------------------
960# where are we?
961set expgui(script) [info script]
962# translate links -- go six levels deep
963foreach i {1 2 3 4 5 6} {
964    if {[file type $expgui(script)] == "link"} {
965        set link [file readlink $expgui(script)]
966        if { [file  pathtype  $link] == "absolute" } {
967h           set expgui(script) $link
968        } {
969            set expgui(script) [file dirname $expgui(script)]/$link
970        }
971    } else {
972        break
973    }
974}
975# fixup relative paths
976if {[file pathtype $expgui(script)] == "relative"} {
977    set expgui(script) [file join [pwd] $expgui(script)]
978}
979set expgui(scriptdir) [file dirname $expgui(script) ]
980
981# fetch EXP file processing routines
982source [file join $expgui(scriptdir) readexp.tcl]
983
984# override options with locally defined values
985if [file exists [file join $expgui(scriptdir) localconfig]] {
986    source [file join $expgui(scriptdir) localconfig]
987}
988if [file exists [file join ~ .gsas_config]] {
989    source [file join ~ .gsas_config]
990}
991#----------------------------------------------------------------
992
993set datalist {}
994foreach file [glob -nocomplain [file join $expgui(scriptdir) widplt_*]] {
995    source $file
996}
997set WidSetList $datalist
998
999# create the graph
1000if [catch {
1001    set box [graph .g]
1002} errmsg] {
1003    tk_dialog .err "BLT Error" \
1004"BLT Setup Error: could not create a graph (msg: $errmsg). \
1005There is a problem with the setup of BLT on your system.
1006See the expgui.html file for more info." \
1007            error 0 "Quit"
1008exit
1009}
1010if [catch {
1011    Blt_ZoomStack $box
1012    Blt_ActiveLegend $box
1013    Blt_ClosestPoint $box
1014} errmsg] {
1015    tk_dialog .err "BLT Error" \
1016"BLT Setup Error: could not access a Blt_ routine (msg: $errmsg). \
1017The pkgIndex.tcl is probably not loading bltGraph.tcl.
1018See the expgui.html file for more info." \
1019            error 0 "Limp ahead"
1020}
1021$box config -title {}
1022setlegend $box $graph(legend)
1023
1024#frame .a -bd 8 -relief groove
1025frame .a -bd 2 -relief groove
1026
1027pack [menubutton .a.file -text File -underline 0 -menu .a.file.menu] -side left
1028menu .a.file.menu
1029pack [menubutton .a.plot -text "Plot Contents" -underline 0 -menu .a.plot.menu] -side left
1030menu .a.plot.menu
1031#.a.file.menu add cascade -label Tickmarks -menu .a.file.menu.tick
1032if {$expnam != ""} {
1033    .a.file.menu add command -label "Reload from EXP" \
1034            -command "getprofiles $expnam; plotdata $box"
1035}
1036if {$program == "absplt"} {
1037    .a.file.menu add cascade -label "Edit Abs Params" -menu .a.file.menu.edit
1038} else {
1039    .a.file.menu add command -label "Add New Curve" -command NewProfileValues
1040    .a.file.menu add cascade -label "Edit Curve" -menu .a.file.menu.edit
1041}
1042menu .a.file.menu.edit
1043.a.file.menu add command -label "Make PostScript" -command makepostscriptout
1044.a.file.menu add command -label Quit -command "destroy ."
1045pack [menubutton .a.options -text Options -underline 0 -menu .a.options.menu] \
1046        -side left   
1047menu .a.options.menu
1048if {$program == "absplt"} {
1049    .a.options.menu add radiobutton -label "2Theta/Tof/Eng" -value tt \
1050            -variable graph(plotunits) \
1051            -command "plotdata $box"
1052} else {
1053    .a.options.menu add radiobutton -label "2Theta" -value tt \
1054            -variable graph(plotunits) \
1055            -command "plotdata $box"
1056    .a.options.menu add command -label "Set Equiv. Wavelength" \
1057            -command "seteqwave $box"
1058}
1059.a.options.menu add radiobutton -label "d-space" -value d \
1060        -variable graph(plotunits) \
1061        -command "plotdata $box"
1062.a.options.menu add radiobutton -label "Q" -value q \
1063        -variable graph(plotunits) \
1064        -command "plotdata $box"
1065.a.options.menu add checkbutton -label "Include legend" \
1066        -variable graph(legend) \
1067        -command {setlegend $box $graph(legend)}
1068.a.options.menu add command -label "Set PS output" \
1069        -command setpostscriptout
1070.a.options.menu add command -label "Save Options" -underline 1 \
1071        -command "SaveOptions"
1072
1073pack [menubutton .a.help -text Help -underline 0 -menu .a.help.menu] -side right
1074menu .a.help.menu -tearoff 0
1075.a.help.menu add command -command aboutwidplot -label About
1076
1077pack .a -side top -fill both
1078pack $box -fill both -expand yes
1079
1080#----------------------------------------------------------------
1081# OK now go get the profile info
1082if {$expnam != ""} {
1083    getprofiles $expnam
1084}
1085#----------------------------------------------------------------
1086
1087    trace variable newmenu(opt) w setoptmsg
1088
1089proc setoptmsg {args} {
1090    global newmenu
1091    array set opttxt {
1092        0 "Cylindrical samples, Lobanov & Alte da Veiga (TOF, CW, synch.)"
1093        1 "Simple linear (TOF)"
1094        2 "Surface Roughness, Pitschke, Hermann & Muttern (Bragg-Brentano)"
1095        3 "Surface Roughness, Suortti (Bragg-Brentano)"
1096        4 "Flat plate, transmission mode"
1097    }
1098    set newmenu(opttxt) ""
1099    catch {set newmenu(opttxt) [set opttxt($newmenu(opt))]}
1100}
1101set datanum 0
1102donewaitmsg
Note: See TracBrowser for help on using the repository browser.