source: trunk/widplt @ 674

Last change on this file since 674 was 671, checked in by toby, 16 years ago

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