source: trunk/widplt @ 540

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

# on 2002/01/22 22:45:19, toby did:
Major revision

Add ABSPLT capability for absorption/reflectivity plots
change edit menu to cascade menu rather than select

curve on plot

correct LY on type 4 to 0
change lots of proc names
make a edit page creator: NewProfileValues? used to create &

edit profile curves
clean code to make ancestry a little less obvious

... hope it works

  • Property rcs:author set to toby
  • Property rcs:date set to 2002/01/22 22:45:19
  • Property rcs:lines set to +622 -311
  • Property rcs:rev set to 1.9
  • 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 540 2009-12-04 23:07:53Z toby $
3set Revision {$Revision: 540 $ $Date: 2009-12-04 23:07:53 +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
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}
388
389proc MakeEditAbsBox {base} {
390    grid [label $base.lb1 -text "Absorption Coefficients"] \
391            -row 2 -column 1  -columnspan 2
392    grid [label $base.lb1a -text "1"] -row 3 -column 1
393    grid [label $base.lb2a -text "2"] -row 3 -column 2
394    grid [label $base.lb3 -text Absorption] -row 2 -column 6  -columnspan 2
395    grid [label $base.lb3a -text Function] -row 3 -column 6  -columnspan 2
396    grid [entry $base.ent1 -textvariable newmenu(1) -width 12] \
397            -row 4 -column 1
398    grid [entry $base.ent2 -textvariable newmenu(2) -width 12] \
399            -row 4 -column 2
400    eval tk_optionMenu $base.m1 newmenu(opt) 0 1 2 3 4
401    grid $base.m1 -row 4 -column 6 -columnspan 2
402
403    grid [label $base.lb8 -textvariable newmenu(opttxt) \
404          -wrap 180 -justify left] -row 5 -column 1  -sticky e -columnspan 7
405    grid [label $base.lb9 -text label] -row 7 -column 1  -sticky e
406    grid [entry $base.ent7 -textvariable newmenu(label)]\
407            -row 7 -column 2  -columnspan 3 -sticky ew
408
409    grid [frame $base.f] -row 8 -column 1 -columnspan 4
410    grid [label $base.f.1 -textvariable newmenu(units)] -row 0 -column 1
411    grid [label $base.f.2 -text {Min}] -row 0 -column 2
412    grid [entry $base.f.3 -textvariable newmenu(min) -width 9] \
413            -row 0 -column 3
414    grid [label $base.f.4 -text {Max}] -row 0 -column 4
415    grid [entry $base.f.5 -textvariable newmenu(max) -width 9] \
416            -row 0 -column 5
417    grid rowconfigure $base 6 -min 15
418}
419
420proc plotdata {top} {
421    global program graph
422    global UVWP XY wave lblarr WidSetList WidDisplay ttrange
423    global ABS absSetList AbsDisplay
424    if {$graph(plotunits) == "d"} {
425        $top xaxis configure -title "d (A)"
426    } elseif {$graph(plotunits) == "q"} {
427        $top xaxis configure -title "Q (A-1)"
428    } elseif {$graph(equivwave) == ""} {
429        $top xaxis configure -title "2Theta"
430    } else {
431        $top xaxis configure -title "2Theta @ $graph(equivwave)"
432    }
433    if {$program == "absplt"} {
434        $top yaxis config -title {Abs. Corr.}
435    } else {
436        $top yaxis config -title {FWHM}
437    }
438    $top yaxis configure -min 0
439    $top xaxis configure -min 0
440    # delete all graphs
441    eval $top element delete [$top element names]
442    set num -1
443    if {$program == "absplt"} {
444        foreach item $absSetList {
445            if {$AbsDisplay($item)} {
446                set ttlist {}
447                set abscor1 [lindex $ABS($item) 0]
448                set abscor2 [lindex $ABS($item) 1]
449                set abstype [lindex $ABS($item) 2]
450                set abslbl [lindex $ABS($item) 4]
451                set htype [lindex $ABS($item) 5]
452                set ttmin [lindex [lindex $ABS($item) 3] 0]
453                set ttmax [lindex [lindex $ABS($item) 3] 1]
454                set ttstep [expr {($ttmax - $ttmin)/50.}]
455                if {$graph(equivwave) == ""} {
456                    if {[string range $htype 2 2] == "T"} {
457                        $top xaxis configure -title "TOF (ms)"
458                    } elseif {[string range $htype 2 2] == "E"} {
459                        $top xaxis configure -title "Energy (KeV)"
460                    }
461                }
462                for     {set tt $ttmin} \
463                        {$tt <= $ttmax} \
464                        {set tt [expr {$tt + $ttstep}]} {
465                    catch {
466                        lappend abslist [AbsorbCalc \
467                                $item $tt $abscor1 $abscor2 $abstype]
468                        lappend ttlist $tt
469                    }
470                }
471                if {[llength $ttlist] == 0} continue
472                if {$graph(plotunits) == "d"} {
473                    set ttlist [tod $ttlist $item]
474                } elseif {$graph(plotunits) == "q"} {
475                    set ttlist [toQ $ttlist $item]
476                }
477                catch {
478                    $top element create $item
479                }
480                $top element config $item -label $abslbl \
481                        -xdata $ttlist -ydata $abslist -linewidth 3 \
482                        -color [nextcolor num]
483            }
484        }
485    } else {
486        foreach item $WidSetList {
487            if {$WidDisplay($item)} {
488                if {[expr [lindex $XY($item) 0] + [lindex $XY($item) 1]] != 0} {
489                    set lflag 1
490                } else {
491                    set lflag 0
492                }
493                set ttlist {}
494                set fwhmlist {}
495                set lfwhmlist {}
496                set tfwhmlist {}
497                # loop over two-theta
498                for     {set tt [lindex $ttrange($item) 0]} \
499                        {$tt <= [lindex $ttrange($item) 1]} \
500                        {set tt [expr $tt + 4]} {
501                    set lfwhm 0
502                    catch {
503                        if {$graph(plotunits) == "d"} {
504                            lappend ttlist [tt2d $wave($item) $tt ]
505                            set gfwhm [deltad $wave($item) $tt \
506                                    [eval FWHM $tt $UVWP($item)]]
507                            lappend fwhmlist $gfwhm
508                            if $lflag {
509                                set lfwhm [deltad $wave($item) $tt \
510                                        [eval LFWHM $tt $XY($item)]]
511                                lappend lfwhmlist $lfwhm
512                            }
513                        } elseif {$graph(plotunits) == "q"} {
514                            lappend ttlist [tt2Q $wave($item) $tt ]
515                            set gfwhm [deltaQ $wave($item) $tt \
516                                    [eval FWHM $tt $UVWP($item)]]
517                            lappend fwhmlist $gfwhm
518                            if $lflag {
519                                set lfwhm [deltaQ $wave($item) $tt \
520                                        [eval LFWHM $tt $XY($item)]]
521                                lappend lfwhmlist $lfwhm
522                            }
523                        } elseif {$graph(equivwave) == ""} {
524                            lappend ttlist $tt
525                            set gfwhm [eval FWHM $tt $UVWP($item)]
526                            lappend fwhmlist $gfwhm
527                            if $lflag {
528                                set lfwhm [eval LFWHM $tt $XY($item)]
529                                lappend lfwhmlist $lfwhm
530                            }
531                        } else {
532                            set tteq [ttequiv $wave($item) $tt $graph(equivwave)]
533                            if {$tteq != ""} {
534                                lappend ttlist $tteq
535                                set gfwhm [delta2teq $wave($item) $tt \
536                                        [eval FWHM $tt $UVWP($item)] $graph(equivwave)]
537                                lappend fwhmlist $gfwhm
538                                if $lflag {
539                                    set lfwhm [delta2teq $wave($item) $tt \
540                                            [eval LFWHM $tt $XY($item)] $graph(equivwave)]
541                                    lappend lfwhmlist $lfwhm
542                                }
543                            }
544                        }
545                        # assume FWHM add as square roots
546                        lappend tfwhmlist \
547                                [expr sqrt($gfwhm*$gfwhm + $lfwhm*$lfwhm)]
548                    }
549                }
550                if $lflag {
551                    catch {
552                        $top element create ${item}G -label "$lblarr($item) G"
553                    }
554                    $top element config ${item}G \
555                            -xdata $ttlist -ydata $fwhmlist -linewidth 3 \
556                            -color [nextcolor num]
557                    catch {
558                        $top element create ${item}L -label "$lblarr($item) L"
559                    }
560                    $top element config ${item}L \
561                            -xdata $ttlist -ydata $lfwhmlist -linewidth 3 \
562                            -color [nextcolor num]
563                }
564                catch {
565                    $top element create $item -label $lblarr($item)
566                }
567                $top element config $item \
568                        -xdata $ttlist -ydata $tfwhmlist -linewidth 3 \
569                        -color [nextcolor num]
570            }
571        }
572    }
573}
574proc AbsorbCalc {hst ttof abscor1 abscor2 mode} {
575    global expmap
576    set htype $expmap(htype_$hst)
577    set pi [expr {2.*acos(0.)}]
578    # determine sin(theta) & lambda
579    if {[string range $htype 2 2] == "T"} {
580        set sth [expr {sin($pi * abs([histinfo $hst tofangle])/360.)}]
581        set lamb [expr {2 * [toftod $ttof $hst] * $sth}]
582    } elseif {[string range $htype 2 2] == "C"} {
583        set lamb [histinfo $hst lam1]
584        set sth [expr {sin($pi * ($ttof - [histinfo $hst zero]/100.)/360.)}]
585    } elseif {[string range $htype 2 2] == "E"} {
586        set lamb [expr { 12.398 / $ttof}]
587        set sth [expr {sin($pi * [histinfo $hst lam1] / 360.)}]
588    }
589    set sth2 [expr $sth*$sth]
590    set cth2 [expr {1 - $sth2}]
591    set cth  [expr {sqrt($cth2)}]
592
593    if {$mode == 0} {
594        set murl [expr {$abscor1 * $lamb}]; # Lobanov & Alte da Veiga
595        if {$murl <= 3} {
596            set TERM0 [expr { 16.0/(3*$pi) }]
597            set TERM1 [expr { (25.99978-0.01911*pow($sth2,0.25)) * \
598                    exp(-0.024551*$sth2) + 0.109561*sqrt($sth2)-26.04556 }]
599            set TERM2 [expr {-0.02489 - 0.39499*$sth2 + \
600                    1.219077*pow($sth2,1.5) - 1.31268*pow($sth2,2) + \
601                    0.871081*pow($sth2,2.5) - 0.2327*pow($sth2,3) }]
602            set TERM3 [expr { 0.003045+0.018167*$sth2 - 0.03305*pow($sth2,2) }]
603            set TRANS [expr { -$TERM0*$murl - $TERM1*pow($murl,2) - \
604                    $TERM2*pow($murl,3) - $TERM3*pow($murl,4) }]
605            if {$TRANS <= -20.0} {
606                set TRANS 2.06E-9
607            } elseif {$TRANS >= 20.0} {
608                set TRANS 4.85E8
609            } else {
610                set TRANS [expr {exp($TRANS)}]
611            }
612        } else {
613            set TERM1 [expr { 1.433902 + 11.07504*$sth2 - \
614                    8.77629*pow($sth2,2) + 10.02088*pow($sth2,3) - \
615                    3.36778*pow($sth2,4) }]
616            set TERM2 [expr { (0.013869 - 0.01249*$sth2) * \
617                    exp(3.27094*$sth2) + \
618                    (0.337894 + 13.77317*$sth2) / \
619                    pow((1.0+11.53544*$sth2),1.555039) }]
620            set TERM3 [expr { 1.933433 / pow((1.0+23.12967*$sth2),1.686715) - \
621                    0.13576*sqrt($sth2) + 1.163198}]
622            set TERM4 [expr { 0.044365 - 0.4259 / \
623                    pow((1.0+0.41051*$sth2),148.4202) }]
624            set TRANS [expr { ($TERM1-$TERM4) / \
625                    pow((1.0+$TERM2*($murl-3.0)),$TERM3) + $TERM4 }]
626            set TRANS [expr { $TRANS/100.0}]
627        }
628    } elseif {$mode == 1} {
629        #!Simple linear absorption
630        set TRANS [expr { -$abscor1*$lamb }]
631        set TRANS [expr { exp($TRANS) }]
632    } elseif {$mode == 2} {
633        #!Pitschke, Hermann & Muttern - surface roughness
634        set TERM1 [expr { 1.0/$sth-$abscor2/$sth2 }]
635        set TERM2 [expr { 1.0-$abscor1*(1.0+$abscor2) }]
636        set TRANS [expr { (1.0-$abscor1*$TERM1)/$TERM2 }]
637    } elseif {$mode == 3} {
638        #!Suortti - surface roughness
639        set TERM1 [expr { exp(-$abscor2/$sth) }]
640        set TERM2 [expr { $abscor1 + (1.0-$abscor1) * exp(-$abscor2) }]
641        set TRANS [expr { ($abscor1 +(1.0-$abscor1) * $TERM1)/$TERM2 }]
642    } elseif {$mode == 4} {
643        #!Plate transmission absorption
644        if {abs($abscor2) < 1} {
645            #!Use symmetric fxn. if phi 1 deg or less
646            set TRANS [expr { -$abscor1*$lamb/$cth }]
647            set TRANS [expr { exp($TRANS) }]
648        } else {
649            #!Bigger tilts
650            set SPH [expr { sin($pi/180. * $abscor2) }]
651            set CPH [expr { cos($pi/180. * $abscor2) }]
652            set CTPP [expr { $CPH*$cth - $SPH*$sth }]
653            set CTMP [expr { $CPH*$cth + $SPH*$sth }]
654            set T [expr { -$abscor1*$lamb }]
655            set T1 [expr { $T / $CTPP }]
656            set TRANS1 [expr { exp($T1) }]
657            set T2 [expr { $T/$CTMP }]
658            set TRANS2 [expr { exp($T2) }]
659            set TB [expr { $T * (1.0 - $CTMP / $CTPP) }]
660            set TRANS [expr { ($TRANS1 - $TRANS2) / $TB }]
661        }
662    }
663    return $TRANS
664}
665
666# save some of the global options in ~/.gsas_config
667proc SaveOptions {} {
668    global graph
669    set fp [open [file join ~ .gsas_config] a]
670    puts $fp "set graph(legend) $graph(legend)"
671    puts $fp "set graph(printout) $graph(printout)"
672    puts $fp "set graph(outname) $graph(outname)"
673    puts $fp "set graph(outcmd) $graph(outcmd)"
674    puts $fp "set graph(plotunits) $graph(plotunits)"
675    puts $fp "set graph(equivwave) $graph(equivwave)"
676    close $fp
677}
678
679proc MakeCascadeMenus {} {
680    global WidSetList lblarr box absSetList ABS
681    .a.plot.menu delete 0 end
682    .a.file.menu.edit delete 0 end
683    global program
684    if {$program != "absplt"} {
685        foreach item $WidSetList {
686            .a.plot.menu add checkbutton -label $lblarr($item) \
687                    -command "plotdata $box" -variable WidDisplay($item)
688            .a.file.menu.edit add command -label $lblarr($item) \
689                    -command "editProfileValues $item"
690        }
691    } else {
692        foreach item $absSetList {
693            .a.plot.menu add checkbutton -label [lindex $ABS($item) 4] \
694                    -command "plotdata $box" -variable AbsDisplay($item)
695            .a.file.menu.edit add command -label [lindex $ABS($item) 4] \
696                    -command "editAbsValues $item"
697        }
698    }
699}
700#-------------------------------------------------------------------------
701# converts 2theta(deg) to Q (A-1)
702proc tt2Q {lambda twotheta} {
703    set pi 3.14159
704    set torad [expr $pi / 360.]
705    return [expr 4 * $pi / ($lambda) * sin (($twotheta) * $torad)]
706}
707
708# converts Q (A-1) to 2theta(deg)
709proc Q2tt {lambda Q} {
710    set pi 3.14159
711    set todeg [expr 360. / $pi]
712    set asinarg [expr ($lambda) * $Q * 0.25 / $pi]
713    if {$asinarg <= 1} {
714        return [expr $todeg * asin ($asinarg)]
715    }
716    return {}
717}
718
719# converts a FWHM in 2theta(deg) to a FWHM in Q (A-1)
720proc deltaQ {lambda twotheta FWHM} {
721    return [expr [tt2Q $lambda $twotheta+($FWHM/2.)] - \
722                 [tt2Q $lambda $twotheta-($FWHM/2.)] ]
723}
724
725# converts 2theta(deg) to d (A)
726proc tt2d {lambda twotheta} {
727    set pi 3.14159
728    set torad [expr $pi / 360.]
729    return [expr 0.5 * ($lambda) / sin (($twotheta) * $torad)]
730}
731
732# converts d (A) to 2theta(deg)
733proc d2tt {lambda d} {
734    set pi 3.14159
735    set todeg [expr 360. / $pi]
736    set asinarg [expr ($lambda) * 0.5 / $d]
737    if {$asinarg <= 1} {
738        return [expr $todeg * asin ($asinarg)]
739    }
740    return {}
741}
742
743# converts a FWHM in 2theta(deg) to a FWHM in Q (A-1)
744proc deltad {lambda twotheta FWHM} {
745    return [expr [tt2d $lambda $twotheta-($FWHM/2.)] - \
746                 [tt2d $lambda $twotheta+($FWHM/2.)] ]
747}
748
749# computes an equivalent 2theta at a different wavelength
750proc ttequiv {lambda twotheta lambda_eq} {
751    return [Q2tt $lambda_eq [tt2Q $lambda $twotheta]]
752}
753
754# converts a FWHM in 2theta(deg) to a FWHM at in 2theta
755# at a different wavelength
756proc delta2teq {lambda twotheta FWHM lambda_eq} {
757    return [expr [Q2tt $lambda_eq [tt2Q $lambda $twotheta+($FWHM/2.)]] - \
758                 [Q2tt $lambda_eq [tt2Q $lambda $twotheta-($FWHM/2.)]] ]
759}
760
761# convert x values to d-space
762proc tod {xlist hst} {
763    global expmap
764    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
765        return [toftod $xlist $hst]
766    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
767        return [tttod $xlist $hst]
768    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
769        return [engtod $xlist $hst]
770    } else {
771        return {}
772    }
773}
774
775# convert tof to d-space
776proc toftod {toflist hst} {
777    set difc [expr {[histinfo $hst difc]/1000.}]
778    set difc2 [expr {$difc*$difc}]
779    set difa [expr {[histinfo $hst difa]/1000.}]
780    set zero [expr {[histinfo $hst zero]/1000.}]
781    set ans {}
782    foreach tof $toflist {
783        if {$tof == 0.} {
784            lappend ans 0.
785        } elseif {$tof == 1000.} {
786            lappend ans 1000.
787        } else {
788            set td [expr {$tof-$zero}]
789            lappend ans [expr {$td*($difc2+$difa*$td)/ \
790                    ($difc2*$difc+2.0*$difa*$td)}]
791        }
792    }
793    return $ans
794}
795
796# convert two-theta to d-space
797proc tttod {twotheta hst} {
798    set lamo2 [expr {0.5 * [histinfo $hst lam1]}]
799    set zero [expr [histinfo $hst zero]/100.]
800    set ans {}
801    set cnv [expr {acos(0.)/180.}]
802    foreach tt $twotheta {
803        if {$tt == 0.} {
804            lappend ans 99999.
805        } elseif {$tt == 1000.} {
806            lappend ans 0.
807        } else {
808            lappend ans [expr {$lamo2 / sin($cnv*($tt-$zero))}]
809        }
810    }
811    return $ans
812}
813
814# convert energy (edx-ray) to d-space
815# (note that this ignores the zero correction)
816proc engtod {eng hst} {
817    set lam [histinfo $hst lam1]
818    set zero [histinfo $hst zero]
819    set ans {}
820    set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
821    foreach e $eng {
822        if {$e == 0.} {
823            lappend ans 1000.
824        } elseif {$e == 1000.} {
825            lappend ans 0.
826        } else {
827            lappend ans [expr {$v/$e}]
828        }
829    }
830    return $ans
831}
832
833# convert x values to Q
834proc toQ {xlist hst} {
835    global expmap
836    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
837        return [toftoQ $xlist $hst]
838    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
839        return [tttoQ $xlist $hst]
840    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
841        return [engtoQ $xlist $hst]
842    } else {
843        return {}
844    }
845}
846# convert tof to Q
847proc toftoQ {toflist hst} {
848    set difc [expr {[histinfo $hst difc]/1000.}]
849    set difc2 [expr {$difc*$difc}]
850    set difa [expr {[histinfo $hst difa]/1000.}]
851    set zero [expr {[histinfo $hst zero]/1000.}]
852    set 2pi [expr {4.*acos(0.)}]
853    set ans {}
854    foreach tof $toflist {
855        if {$tof == 0.} {
856            lappend ans 99999.
857        } elseif {$tof == 1000.} {
858            lappend ans 0.
859        } else {
860            set td [expr {$tof-$zero}]
861            lappend ans [expr {$2pi * \
862                    ($difc2*$difc+2.0*$difa*$td)/($td*($difc2+$difa*$td))}]
863        }
864    }
865    return $ans
866}
867
868# convert two-theta to Q
869proc tttoQ {twotheta hst} {
870    set lamo2 [expr {0.5 * [histinfo $hst lam1]}]
871    set zero [expr [histinfo $hst zero]/100.]
872    set ans {}
873    set cnv [expr {acos(0.)/180.}]
874    set 2pi [expr {4.*acos(0.)}]
875    foreach tt $twotheta {
876        if {$tt == 0.} {
877            lappend ans 0.
878        } elseif {$tt == 1000.} {
879            lappend ans 1000.
880        } else {
881            lappend ans [expr {$2pi * sin($cnv*($tt-$zero)) / $lamo2}]
882        }
883    }
884    return $ans
885}
886# convert energy (edx-ray) to Q
887# (note that this ignores the zero correction)
888proc engtoQ {eng hst} {
889    set lam [histinfo $hst lam1]
890    set zero [histinfo $hst zero]
891    set ans {}
892    set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
893    set 2pi [expr {4.*acos(0.)}]
894    foreach e $eng {
895        if {$e == 0.} {
896            lappend ans 0.
897        } elseif {$e == 1000.} {
898            lappend ans 1000.
899        } else {
900            lappend ans [expr {$2pi * $e / $v}]
901        }
902    }
903    return $ans
904}
905proc sind {angle} {
906    return [expr {sin($angle*acos(0.)/90.)}]
907}
908
909proc FWHM {tt U V W P} {
910    set pi 3.14159
911    set torad [expr $pi / 360.]
912    # tan theta
913    set tantt [expr tan($tt * $torad ) ]
914    set costt [expr cos($tt * $torad ) ]
915    return [expr sqrt \
916            (8.* log(2) * ($U * $tantt * $tantt + $V * $tantt + $W \
917            + $P / ($costt * $costt))) / 100.]
918}
919proc LFWHM {tt X Y} {
920    set pi 3.14159
921    set torad [expr $pi / 360.]
922    # tan theta
923    set tantt [expr tan($tt * $torad ) ]
924    set costt [expr cos($tt * $torad ) ]
925    return [expr ($X / $costt + $Y * $tantt) / 100.]
926}
927
928proc setlegend {box legend} {
929    global blt_version
930    if {$blt_version >= 2.3 && $blt_version < 8.0} {
931        if $legend {
932            $box legend config -hide no
933        } else {
934            $box legend config -hide yes
935        }
936    } else {
937        if $legend {
938            $box legend config -mapped yes
939        } else {
940            $box legend config -mapped no
941        }
942    }
943}
944
945set graph(legend) 0
946set graph(equivwave) {}
947set graph(plotunits) tt
948if {$tcl_platform(platform) == "windows"} {
949    set graph(printout) 1
950} else {
951    set graph(printout) 0
952}
953set graph(outname) out.ps
954set graph(outcmd) lpr
955set WidSetList {}
956set absSetList {}
957
958#----------------------------------------------------------------
959# where are we?
960set expgui(script) [info script]
961# translate links -- go six levels deep
962foreach i {1 2 3 4 5 6} {
963    if {[file type $expgui(script)] == "link"} {
964        set link [file readlink $expgui(script)]
965        if { [file  pathtype  $link] == "absolute" } {
966h           set expgui(script) $link
967        } {
968            set expgui(script) [file dirname $expgui(script)]/$link
969        }
970    } else {
971        break
972    }
973}
974# fixup relative paths
975if {[file pathtype $expgui(script)] == "relative"} {
976    set expgui(script) [file join [pwd] $expgui(script)]
977}
978set expgui(scriptdir) [file dirname $expgui(script) ]
979
980# fetch EXP file processing routines
981source [file join $expgui(scriptdir) readexp.tcl]
982
983# override options with locally defined values
984if [file exists [file join $expgui(scriptdir) localconfig]] {
985    source [file join $expgui(scriptdir) localconfig]
986}
987if [file exists [file join ~ .gsas_config]] {
988    source [file join ~ .gsas_config]
989}
990#----------------------------------------------------------------
991
992set datalist {}
993foreach file [glob -nocomplain [file join $expgui(scriptdir) widplt_*]] {
994    source $file
995}
996set WidSetList $datalist
997
998# create the graph
999if [catch {
1000    set box [graph .g]
1001} errmsg] {
1002    tk_dialog .err "BLT Error" \
1003"BLT Setup Error: could not create a graph (msg: $errmsg). \
1004There is a problem with the setup of BLT on your system.
1005See the expgui.html file for more info." \
1006            error 0 "Quit"
1007exit
1008}
1009if [catch {
1010    Blt_ZoomStack $box
1011    Blt_ActiveLegend $box
1012    Blt_ClosestPoint $box
1013} errmsg] {
1014    tk_dialog .err "BLT Error" \
1015"BLT Setup Error: could not access a Blt_ routine (msg: $errmsg). \
1016The pkgIndex.tcl is probably not loading bltGraph.tcl.
1017See the expgui.html file for more info." \
1018            error 0 "Limp ahead"
1019}
1020$box config -title {}
1021setlegend $box $graph(legend)
1022
1023#frame .a -bd 8 -relief groove
1024frame .a -bd 2 -relief groove
1025
1026pack [menubutton .a.file -text File -underline 0 -menu .a.file.menu] -side left
1027menu .a.file.menu
1028pack [menubutton .a.plot -text "Plot Contents" -underline 0 -menu .a.plot.menu] -side left
1029menu .a.plot.menu
1030#.a.file.menu add cascade -label Tickmarks -menu .a.file.menu.tick
1031if {$expnam != ""} {
1032    .a.file.menu add command -label "Reload from EXP" \
1033            -command "getprofiles $expnam; plotdata $box"
1034}
1035if {$program == "absplt"} {
1036    .a.file.menu add cascade -label "Edit Abs Params" -menu .a.file.menu.edit
1037} else {
1038    .a.file.menu add command -label "Add New Curve" -command NewProfileValues
1039    .a.file.menu add cascade -label "Edit Curve" -menu .a.file.menu.edit
1040}
1041menu .a.file.menu.edit
1042.a.file.menu add command -label "Make PostScript" -command makepostscriptout
1043.a.file.menu add command -label Quit -command "destroy ."
1044pack [menubutton .a.options -text Options -underline 0 -menu .a.options.menu] \
1045        -side left   
1046menu .a.options.menu
1047if {$program == "absplt"} {
1048    .a.options.menu add radiobutton -label "2Theta/Tof/Eng" -value tt \
1049            -variable graph(plotunits) \
1050            -command "plotdata $box"
1051} else {
1052    .a.options.menu add radiobutton -label "2Theta" -value tt \
1053            -variable graph(plotunits) \
1054            -command "plotdata $box"
1055    .a.options.menu add command -label "Set Equiv. Wavelength" \
1056            -command "seteqwave $box"
1057}
1058.a.options.menu add radiobutton -label "d-space" -value d \
1059        -variable graph(plotunits) \
1060        -command "plotdata $box"
1061.a.options.menu add radiobutton -label "Q" -value q \
1062        -variable graph(plotunits) \
1063        -command "plotdata $box"
1064.a.options.menu add checkbutton -label "Include legend" \
1065        -variable graph(legend) \
1066        -command {setlegend $box $graph(legend)}
1067.a.options.menu add command -label "Set PS output" \
1068        -command setpostscriptout
1069.a.options.menu add command -label "Save Options" -underline 1 \
1070        -command "SaveOptions"
1071
1072pack [menubutton .a.help -text Help -underline 0 -menu .a.help.menu] -side right
1073menu .a.help.menu -tearoff 0
1074.a.help.menu add command -command aboutwidplot -label About
1075
1076pack .a -side top -fill both
1077pack $box -fill both -expand yes
1078
1079#----------------------------------------------------------------
1080# OK now go get the profile info
1081if {$expnam != ""} {
1082    getprofiles $expnam
1083}
1084#----------------------------------------------------------------
1085
1086    trace variable newmenu(opt) w setoptmsg
1087
1088proc setoptmsg {args} {
1089    global newmenu
1090    array set opttxt {
1091        0 "Cylindrical samples, Lobanov & Alte da Veiga (TOF, CW, synch.)"
1092        1 "Simple linear (TOF)"
1093        2 "Surface Roughness, Pitschke, Hermann & Muttern (Bragg-Brentano)"
1094        3 "Surface Roughness, Suortti (Bragg-Brentano)"
1095        4 "Flat plate, transmission mode"
1096    }
1097    set newmenu(opttxt) ""
1098    catch {set newmenu(opttxt) [set opttxt($newmenu(opt))]}
1099}
1100set datanum 0
1101donewaitmsg
Note: See TracBrowser for help on using the repository browser.