source: trunk/widplt @ 8

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

# on 1998/11/23 20:06:43, toby did:
Fix revision

  • Property rcs:author set to toby
  • Property rcs:date set to 1998/11/23 20:06:43
  • Property rcs:lines set to +8 -8
  • Property rcs:rev set to 1.2
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 24.5 KB
Line 
1#!/usr/local/bin/wish
2set Revision {$Revision: 8 $ $Date: 2009-12-04 22:58:49 +0000 (Fri, 04 Dec 2009) $}
3bind all <Control-KeyPress-c> {destroy .}
4# hope for the best
5set gsasexe {/usr/local/gsas}
6if {[lindex $argv 0] != ""} {set gsasexe [lindex $argv 0]}
7set expnam [file root [lindex $argv 1]]
8#if {$expnam == ""} {puts "error -- no experiment name"; destroy .}
9if [catch {package require BLT} errmsg] {
10    tk_dialog .err "BLT Error" "Error -- Unable to load the BLT package" \
11            error 0 Quit
12    destroy .
13}
14
15# handle Tcl/Tk v8+ where BLT is in a namespace
16#  use the command so that it is loaded
17catch {blt::graph}
18catch {
19    namespace import blt::graph
20    namespace import blt::vector
21}
22# old versions of blt don't report a version number
23if [catch {set blt_version}] {set blt_version 0}
24
25proc waitmsg {message} {
26    set w .wait
27    # kill any window/frame with this name
28    catch {destroy $w}
29    pack [frame $w]
30    frame $w.bot -relief raised -bd 1
31    pack $w.bot -side bottom -fill both
32    frame $w.top -relief raised -bd 1
33    pack $w.top -side top -fill both -expand 1
34    label $w.msg -justify left -text $message -wrap 3i
35    catch {$w.msg configure -font \
36                -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-*
37    }
38    pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
39    label $w.bitmap -bitmap info
40    pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
41    update
42}
43
44proc donewait {} {
45    catch {destroy .wait}
46    update
47}
48
49if {$expnam != ""} {waitmsg "Loading $expnam.EXP, Please wait"}
50
51# read an EXP file into an array
52proc expload {file} {
53    global exparray gsasexe
54    if [catch {
55        set fil [open $file r]
56    }] {return 1}
57    set len [gets $fil line]
58    # is this a direct access file?
59    if {$len > 160} {
60        close $fil
61        # use convdtos because tcl can't handle null characters
62        if ![file executable $gsasexe/convdtos] {
63        tk_dialog .err \
64                "Warning" "Warning -- Unable to read direct access EXP file, convdtos not found." \
65            error 0 Continue
66          return
67        }
68        set fil [open "| $gsasexe/convdtos < $file" r]
69        set len [gets $fil line]
70    }
71    while {$len > 0} {
72        set key [string range $line 0 11]
73        set exparray($key) [string range $line 12 end]
74        set len [gets $fil line]
75    }
76    close $fil
77    return 0
78}
79
80proc readexp {key} {
81    global exparray
82    # truncate long keys & pad short ones
83    set key [string range "$key          " 0 11]
84    if [catch {set val $exparray($key)}] return
85    return $val
86}
87
88# get profile information out from a EXP file
89proc getprofiles {} {
90    global datalist wave XY UVWP lblarr ttrange
91    set nhist [string trim [readexp { EXPR  NHST }]]
92    set n 0
93    # get the histogram types
94    for {set i 0} {$i < $nhist} {incr i} {
95        if {[expr $i % 12] == 0} {
96            incr n
97            set line [readexp " EXPR  HTYP$n"]
98        }
99        set ihist [expr $i + 1]
100        set htype($ihist) [lindex $line $i]
101    }
102    for {set i 0} {$i < $nhist} {incr i} {
103        set ihist [expr $i + 1]
104        set line [lrange $line 1 end]
105
106        # process powder data only
107        if {[string range $htype($ihist) 0 0] != "P"} continue
108        # for now skip TOF data as well
109        if {[string range $htype($ihist) 2 2] != "C"} continue
110        set line [readexp "HST  $ihist NPHAS"]
111
112        # loop over phases
113        set iph 0
114        foreach flag $line {
115            incr iph
116            if !$flag continue
117            # wavelength
118            set line [readexp "HST  $ihist ICONS"]
119            set lambda1 [lindex $line 0]
120            # data range
121            set drange [readexp "HST  $ihist TRNGE"]
122            set key [format %s%1d%2d%s HAP $iph $ihist PRCF]
123            set line [readexp $key]
124            set ptype [lindex $line 0]
125            set pterms  [lindex $line 1]
126            set it 0
127            set line {}
128            while {$it < ($pterms+3)/4} {
129                set key [format %s%1d%2d%s%2d HAP $iph $ihist PRCF $it]
130                append line [readexp $key]
131                incr it
132            }
133            set key "H${ihist}P$iph"
134            lappend datalist $key
135            set lblarr($key) "Histogram $ihist Phase $iph"
136            set wave($key) $lambda1
137            set ttrange($key) $drange
138            if {$ptype == 1} {
139                set UVWP($key) "[lrange $line 0 2] 0"
140                set XY($key) {0 0}
141            } elseif {$ptype == 2} {
142                set UVWP($key) "[lrange $line 0 2] [lindex $line 8]"
143                set XY($key) [lrange $line 3 4]
144            } elseif {$ptype == 3} {
145                set UVWP($key) "[lrange $line 0 3]"
146                set XY($key) [lrange $line 4 5]
147            }
148        }
149    }
150}
151
152proc makepostscriptout {} {
153    global graph box
154    if !$graph(printout) {
155        set out [open "| $graph(outcmd) >& /tmp/liveplot.msg" w]
156        catch {
157            puts $out [$box postscript output -landscape 1 \
158                -decorations no -height 7.i -width 9.5i]
159            close $out
160        } msg
161        catch {
162            set out [open /tmp/liveplot.msg r]
163            if {$msg != ""} {append msg "\n"}
164            append msg [read $out]
165            close $out
166            file delete /tmp/liveplot.msg
167        }
168        if {$msg != ""} {
169            tk_dialog .msg "file created" \
170                    "Postscript file processed with command \
171                    $graph(outcmd). Result: $msg" "" 0 OK
172        } else {
173            tk_dialog .msg "file created" \
174                    "Postscript file processed with command \
175                    $graph(outcmd)" "" 0 OK
176        }
177    } else {
178        $box postscript output $graph(outname) -landscape 1 \
179                -decorations no -height 7.i -width 9.5i   
180        tk_dialog .msg "file created" \
181                "Postscript file $graph(outname) created" "" 0 OK
182    }
183}
184
185proc setprintopt {page} {
186    global graph
187    if $graph(printout) {
188        $page.4.1 config -fg black
189        $page.4.2 config -fg black -state normal
190        $page.6.1 config -fg #888
191        $page.6.2 config -fg #888 -state disabled
192    } else {
193        $page.4.1 config -fg #888
194        $page.4.2 config -fg #888 -state disabled
195        $page.6.1 config -fg black
196        $page.6.2 config -fg black -state normal
197    }
198}
199
200proc seteqwave {top} {
201    global equivwave
202    set box .wave
203    catch {destroy $box}
204    toplevel $box
205    focus $box
206    grab $box
207    pack [frame $box.1] -side top
208    pack [label $box.1.a -text "Equivalent wavelength:"] -side top
209    pack [entry $box.1.b -textvariable equivwave] -side top
210    pack [frame $box.2] -side top
211    pack [button $box.2.c -text Clear -command "set equivwave {}; destroy $box"]
212    pack [button $box.2.u -text Use -command "destroy $box"]
213    tkwait window $box
214    plotdata $top
215}
216
217proc setpostscriptout {} {
218    global graph tcl_platform
219    set box .out
220    catch {destroy $box}
221    toplevel $box
222    focus $box
223    grab $box
224    pack [frame $box.4] -side top -anchor w -fill x
225    pack [checkbutton $box.4.a -text "Write PostScript files" \
226            -variable graph(printout) -offvalue 0 -onvalue 1 \
227            -command "setprintopt $box"] -side left -anchor w
228    pack [entry $box.4.2 -textvariable graph(outname)] -side right -anchor w
229    pack [label $box.4.1 -text "PostScript file name:"] -side right -anchor w
230    pack [frame $box.6] -side top -anchor w -fill x
231    pack [checkbutton $box.6.a -text "Print PostScript files" \
232            -variable graph(printout) -offvalue 1 -onvalue 0 \
233            -command "setprintopt $box" ] -side left -anchor w
234    pack [entry $box.6.2 -textvariable graph(outcmd)] -side right -anchor w
235    pack [label $box.6.1 -text "Command to print files:"] -side right -anchor w
236
237    pack [button $box.a -text "Close" -command "destroy $box"] -side top   
238    if {$tcl_platform(platform) == "windows"} {
239        set graph(printout) 1
240        $box.4.a config -state disabled
241        $box.6.a config -fg #888 -state disabled
242    }
243    setprintopt $box
244}
245
246proc aboutwidplot {} {
247    global Revision
248    tk_dialog .warn About "
249GSAS\n\
250A. C. Larson and\n R. B. Von Dreele,\n LANSCE, Los Alamos\n\n\
251WIDPLT\nB. Toby, NIST\nNot subject to copyright\n\n\
252$Revision\n\
253" {} 0 OK
254}
255
256proc nextcolor {var} {
257    set num [uplevel "incr $var"]
258    return [lindex {red green blue cyan magenta yellow} [expr $num % 6]]
259}
260
261proc newmenu {} {
262    global newmenu datanum
263    incr datanum
264    set base .new
265    catch {destroy $base}
266    toplevel $base
267    focus $base
268    grab $base
269    wm title $base {Enter a new profile}
270    label $base.label#7 -text Gaussian
271    label $base.label#8 -text Lorentz
272    label $base.label#1 -text U
273    label $base.label#2 -text V
274    label $base.label#3 -text W
275    label $base.label#4 -text P
276    label $base.label#5 -text X
277    label $base.label#6 -text Y
278    entry $base.entry#1 -textvariable newmenu(U) -width 8
279    entry $base.entry#2 -textvariable newmenu(V) -width 8
280    entry $base.entry#3 -textvariable newmenu(W) -width 8
281    entry $base.entry#4 -textvariable newmenu(P) -width 8
282    entry $base.entry#5 -textvariable newmenu(X) -width 8
283    entry $base.entry#6 -textvariable newmenu(Y) -width 8
284
285    label $base.label#9 -text label
286    entry $base.entry#7 -textvariable newmenu(label)
287   
288    label $base.label#11 -text {2Theta Min}
289    entry $base.entry#9 -textvariable newmenu(min) -width 6
290    label $base.label#12 -text {2Theta Max}
291    entry $base.entry#10 -textvariable newmenu(max) -width 6
292   
293    label $base.label#13 -text Wavelength
294
295    entry $base.entry#11 -textvariable newmenu(wave) -width 8
296   
297    button $base.button#1 -text Add -command "addopt; destroy $base"
298    button $base.button#2 -text Quit -command "destroy $base"
299   
300    # Geometry management
301
302    grid $base.label#7 -in $base        -row 2 -column 1  -columnspan 4
303    grid $base.label#8 -in $base        -row 2 -column 6  -columnspan 2
304    grid $base.label#1 -in $base        -row 3 -column 1
305    grid $base.label#2 -in $base        -row 3 -column 2
306    grid $base.label#3 -in $base        -row 3 -column 3
307    grid $base.label#4 -in $base        -row 3 -column 4
308    grid $base.label#5 -in $base        -row 3 -column 6
309    grid $base.label#6 -in $base        -row 3 -column 7
310    grid $base.entry#1 -in $base        -row 4 -column 1
311    grid $base.entry#2 -in $base        -row 4 -column 2
312    grid $base.entry#3 -in $base        -row 4 -column 3
313    grid $base.entry#4 -in $base        -row 4 -column 4
314    grid $base.entry#5 -in $base        -row 4 -column 6
315    grid $base.entry#6 -in $base        -row 4 -column 7
316    grid $base.label#9 -in $base        -row 5 -column 1
317    grid $base.entry#7 -in $base        -row 5 -column 2  -columnspan 3
318    grid $base.label#13 -in $base       -row 5 -column 5  -columnspan 2
319    grid $base.entry#11 -in $base       -row 5 -column 7
320    grid $base.label#11 -in $base       -row 6 -column 1
321    grid $base.entry#9 -in $base        -row 6 -column 2
322    grid $base.label#12 -in $base       -row 6 -column 3
323    grid $base.entry#10 -in $base       -row 6 -column 4
324    grid $base.button#1 -in $base       -row 6 -column 6
325    grid $base.button#2 -in $base       -row 6 -column 7
326   
327    # Resize behavior management
328
329    grid rowconfigure $base 2 -weight 1 -minsize 17
330    grid rowconfigure $base 3 -weight 0 -minsize 19
331    grid rowconfigure $base 4 -weight 0 -minsize 30
332    grid rowconfigure $base 5 -weight 0 -minsize 30
333    grid rowconfigure $base 6 -weight 0 -minsize 30
334    grid columnconfigure $base 1 -weight 0 -minsize 26
335    grid columnconfigure $base 2 -weight 0 -minsize 30
336    grid columnconfigure $base 3 -weight 0 -minsize 30
337    grid columnconfigure $base 4 -weight 0 -minsize 65
338    grid columnconfigure $base 5 -weight 1 -minsize 26
339    grid columnconfigure $base 6 -weight 0 -minsize 30
340    grid columnconfigure $base 7 -weight 0 -minsize 30
341    set newmenu(U) 0
342    set newmenu(V) 0
343    set newmenu(W) 0
344    set newmenu(P) 0
345    set newmenu(X) 0
346    set newmenu(Y) 0
347    set newmenu(min) 5
348    set newmenu(max) 100
349    set newmenu(label) "Curve #$datanum"
350    set newmenu(wave) 1.5418
351}
352
353proc addopt {} {
354    global newmenu datanum lblarr display UVWP XY datalist ttrange wave
355    set key new$datanum
356    set UVWP($key) [list $newmenu(U) $newmenu(V) $newmenu(W) $newmenu(P)]
357    set XY($key) [list $newmenu(X) $newmenu(Y)]
358    set lblarr($key) $newmenu(label)
359    set ttrange($key) "$newmenu(min) $newmenu(max)"
360    set wave($key) $newmenu(wave)
361    lappend datalist $key
362    .a.plot.menu add checkbutton -label $lblarr($key) \
363            -command {plotdata $box} -variable display($key)
364}
365
366proc editmenu {} {
367    global newmenu datalist lblarr
368    set base .edit
369    catch {destroy $base}
370    toplevel $base
371    focus $base
372    grab $base
373    wm title $base {Edit a profile}
374    label $base.label#7 -text Gaussian
375    label $base.label#8 -text Lorentz
376    label $base.label#1 -text U
377    label $base.label#2 -text V
378    label $base.label#3 -text W
379    label $base.label#4 -text P
380    label $base.label#5 -text X
381    label $base.label#6 -text Y
382    entry $base.entry#1 -textvariable newmenu(U) -width 8
383    entry $base.entry#2 -textvariable newmenu(V) -width 8
384    entry $base.entry#3 -textvariable newmenu(W) -width 8
385    entry $base.entry#4 -textvariable newmenu(P) -width 8
386    entry $base.entry#5 -textvariable newmenu(X) -width 8
387    entry $base.entry#6 -textvariable newmenu(Y) -width 8
388
389    label $base.label#9 -text {Select an option}
390    set llist {}
391    foreach item $datalist {lappend llist $lblarr($item)}
392    eval tk_optionMenu $base.entry#7 newmenu(opt) $llist
393
394    label $base.label#11 -text {2Theta Min}
395    entry $base.entry#9 -textvariable newmenu(min) -width 6
396    label $base.label#12 -text {2Theta Max}
397    entry $base.entry#10 -textvariable newmenu(max) -width 6
398   
399    label $base.label#13 -text Wavelength
400
401    entry $base.entry#11 -textvariable newmenu(wave) -width 8
402
403    button $base.button#1 -text Save -command "saveopt"
404    button $base.button#2 -text Quit -command "destroy $base"
405   
406    # Geometry management
407
408    grid $base.label#9 -in $base        -row 1 -column 1  -columnspan 2 \
409            -sticky e
410    grid $base.entry#7 -in $base        -row 1 -column 3  -columnspan 3 \
411            -sticky w
412    grid $base.label#7 -in $base        -row 2 -column 1  -columnspan 4
413    grid $base.label#8 -in $base        -row 2 -column 6  -columnspan 2
414    grid $base.label#1 -in $base        -row 3 -column 1
415    grid $base.label#2 -in $base        -row 3 -column 2
416    grid $base.label#3 -in $base        -row 3 -column 3
417    grid $base.label#4 -in $base        -row 3 -column 4
418    grid $base.label#5 -in $base        -row 3 -column 6
419    grid $base.label#6 -in $base        -row 3 -column 7
420    grid $base.entry#1 -in $base        -row 4 -column 1
421    grid $base.entry#2 -in $base        -row 4 -column 2
422    grid $base.entry#3 -in $base        -row 4 -column 3
423    grid $base.entry#4 -in $base        -row 4 -column 4
424    grid $base.entry#5 -in $base        -row 4 -column 6
425    grid $base.entry#6 -in $base        -row 4 -column 7
426    grid $base.label#13 -in $base       -row 5 -column 5  -columnspan 2
427    grid $base.entry#11 -in $base       -row 5 -column 7
428    grid $base.label#11 -in $base       -row 6 -column 1
429    grid $base.entry#9 -in $base        -row 6 -column 2
430    grid $base.label#12 -in $base       -row 6 -column 3
431    grid $base.entry#10 -in $base       -row 6 -column 4
432    grid $base.button#1 -in $base       -row 6 -column 6
433    grid $base.button#2 -in $base       -row 6 -column 7
434
435    # Resize behavior management
436   
437    grid rowconfigure $base 1 -weight 0 -minsize 30
438    grid rowconfigure $base 2 -weight 1 -minsize 17
439    grid rowconfigure $base 3 -weight 0 -minsize 19
440    grid rowconfigure $base 4 -weight 0 -minsize 30
441    grid rowconfigure $base 5 -weight 0 -minsize 30
442    grid rowconfigure $base 6 -weight 0 -minsize 30
443    grid columnconfigure $base 1 -weight 0 -minsize 26
444    grid columnconfigure $base 2 -weight 0 -minsize 30
445    grid columnconfigure $base 3 -weight 0 -minsize 30
446    grid columnconfigure $base 4 -weight 0 -minsize 65
447    grid columnconfigure $base 5 -weight 1 -minsize 26
448    grid columnconfigure $base 6 -weight 0 -minsize 30
449    grid columnconfigure $base 7 -weight 0 -minsize 30
450    set newmenu(U) {}
451    set newmenu(V) {}
452    set newmenu(W) {}
453    set newmenu(P) {}
454    set newmenu(X) {}
455    set newmenu(Y) {}
456    set newmenu(min) {}
457    set newmenu(max) {}
458    set newmenu(label) {}
459    set newmenu(wave) {}
460    set newmenu(opt) {}
461}
462
463proc saveopt {} {
464    global newmenu datanum lblarr display UVWP XY datalist ttrange wave box
465    set key {}
466    foreach item $datalist {
467        if {$lblarr($item) == $newmenu(opt)} {set key $item; break}
468    }
469    if {$key == ""} return
470    set UVWP($key) [list $newmenu(U) $newmenu(V) $newmenu(W) $newmenu(P)]
471    set XY($key) [list $newmenu(X) $newmenu(Y)]
472    set ttrange($key) "$newmenu(min) $newmenu(max)"
473    set wave($key) $newmenu(wave)
474    plotdata $box
475}
476
477proc loadopt {a1 a2 a3} {
478    global newmenu lblarr display UVWP XY datalist ttrange newmenu wave
479    set key {}
480    foreach item $datalist {
481        if {$lblarr($item) == $newmenu(opt)} {set key $item; break}
482    }
483    if {$key == ""} return
484    set newmenu(U) [lindex $UVWP($key) 0]
485    set newmenu(V) [lindex $UVWP($key) 1]
486    set newmenu(W) [lindex $UVWP($key) 2]
487    set newmenu(P) [lindex $UVWP($key) 3]
488    set newmenu(X) [lindex $XY($key) 0]
489    set newmenu(Y) [lindex $XY($key) 1]
490    set newmenu(min) [lindex $ttrange($key) 0]
491    set newmenu(max) [lindex $ttrange($key) 1]
492    set newmenu(wave) $wave($key)
493}
494
495proc plotdata {graph} {
496    global UVWP XY wave lblarr datalist display plotunits ttrange equivwave
497    if {$plotunits == "d"} {
498        $graph xaxis configure -title "d (A)"
499    } elseif {$plotunits == "q"} {
500        $graph xaxis configure -title "Q (A-1)"
501    } elseif {$equivwave == ""} {
502        $graph xaxis configure -title "2Theta"
503    } else {
504        $graph xaxis configure -title "2Theta @ $equivwave"
505    }
506    $graph yaxis configure -min 0
507    $graph xaxis configure -min 0
508    # delete all graphs
509    eval $graph element delete [$graph element names]
510    set num -1
511    foreach item $datalist {
512        if {$display($item)} {
513            if {[expr [lindex $XY($item) 0] + [lindex $XY($item) 1]] != 0} {
514                set lflag 1
515            } else {
516                set lflag 0
517            }
518            set ttlist {}
519            set fwhmlist {}
520            set lfwhmlist {}
521            set tfwhmlist {}
522            # loop over two-theta
523            for     {set tt [lindex $ttrange($item) 0]} \
524                    {$tt <= [lindex $ttrange($item) 1]} \
525                    {set tt [expr $tt + 4]} {
526                set lfwhm 0
527                if {$plotunits == "d"} {
528                    lappend ttlist [tt2d $wave($item) $tt ]
529                    set gfwhm [deltad $wave($item) $tt \
530                            [eval FWHM $tt $UVWP($item)]]
531                    lappend fwhmlist $gfwhm
532                    if $lflag {
533                        set lfwhm [deltad $wave($item) $tt \
534                                [eval LFWHM $tt $XY($item)]]
535                        lappend lfwhmlist $lfwhm
536                    }
537                } elseif {$plotunits == "q"} {
538                    lappend ttlist [tt2Q $wave($item) $tt ]
539                    set gfwhm [deltaQ $wave($item) $tt \
540                            [eval FWHM $tt $UVWP($item)]]
541                    lappend fwhmlist $gfwhm
542                    if $lflag {
543                        set lfwhm [deltaQ $wave($item) $tt \
544                            [eval LFWHM $tt $XY($item)]]
545                        lappend lfwhmlist $lfwhm
546                    }
547                } elseif {$equivwave == ""} {
548                    lappend ttlist $tt
549                    set gfwhm [eval FWHM $tt $UVWP($item)]
550                    lappend fwhmlist $gfwhm
551                    if $lflag {
552                        set lfwhm [eval LFWHM $tt $XY($item)]
553                        lappend lfwhmlist $lfwhm
554                    }
555                } else {
556                    set tteq [ttequiv $wave($item) $tt $equivwave]
557                    if {$tteq != ""} {
558                        lappend ttlist $tteq
559                        set gfwhm [delta2teq $wave($item) $tt \
560                                [eval FWHM $tt $UVWP($item)] $equivwave]
561                        lappend fwhmlist $gfwhm
562                        if $lflag {
563                            set lfwhm [delta2teq $wave($item) $tt \
564                                    [eval LFWHM $tt $XY($item)] $equivwave]
565                            lappend lfwhmlist $lfwhm
566                        }
567                    }
568                }
569                # assume FWHM add as square roots
570                lappend tfwhmlist \
571                        [expr sqrt($gfwhm*$gfwhm + $lfwhm*$lfwhm)]
572            }
573            if $lflag {
574                catch {
575                    $graph element create ${item}G -label "$lblarr($item) G"
576                }
577                $graph element config ${item}G \
578                    -xdata $ttlist -ydata $fwhmlist -linewidth 3 \
579                    -color [nextcolor num]
580                catch {
581                    $graph element create ${item}L -label "$lblarr($item) L"
582                }
583                $graph element config ${item}L \
584                        -xdata $ttlist -ydata $lfwhmlist -linewidth 3 \
585                        -color [nextcolor num]
586            }
587            catch {
588                $graph element create $item -label $lblarr($item)
589            }
590            $graph element config $item \
591                    -xdata $ttlist -ydata $tfwhmlist -linewidth 3 \
592                    -color [nextcolor num]
593        }
594    }
595}
596#-------------------------------------------------------------------------
597# converts 2theta(deg) to Q (A-1)
598proc tt2Q {lambda twotheta} {
599    set pi 3.14159
600    set torad [expr $pi / 360.]
601    return [expr 4 * $pi / ($lambda) * sin (($twotheta) * $torad)]
602}
603
604# converts Q (A-1) to 2theta(deg)
605proc Q2tt {lambda Q} {
606    set pi 3.14159
607    set todeg [expr 360. / $pi]
608    set asinarg [expr ($lambda) * $Q * 0.25 / $pi]
609    if {$asinarg <= 1} {
610        return [expr $todeg * asin ($asinarg)]
611    }
612    return {}
613}
614
615# converts a FWHM in 2theta(deg) to a FWHM in Q (A-1)
616proc deltaQ {lambda twotheta FWHM} {
617    return [expr [tt2Q $lambda $twotheta+($FWHM/2.)] - \
618                 [tt2Q $lambda $twotheta-($FWHM/2.)] ]
619}
620
621# converts 2theta(deg) to d (A)
622proc tt2d {lambda twotheta} {
623    set pi 3.14159
624    set torad [expr $pi / 360.]
625    return [expr 0.5 * ($lambda) / sin (($twotheta) * $torad)]
626}
627
628# converts d (A) to 2theta(deg)
629proc d2tt {lambda d} {
630    set pi 3.14159
631    set todeg [expr 360. / $pi]
632    set asinarg [expr ($lambda) * 0.5 / $d]
633    if {$asinarg <= 1} {
634        return [expr $todeg * asin ($asinarg)]
635    }
636    return {}
637}
638
639# converts a FWHM in 2theta(deg) to a FWHM in Q (A-1)
640proc deltad {lambda twotheta FWHM} {
641    return [expr [tt2d $lambda $twotheta-($FWHM/2.)] - \
642                 [tt2d $lambda $twotheta+($FWHM/2.)] ]
643}
644
645# computes an equivalent 2theta at a different wavelength
646proc ttequiv {lambda twotheta lambda_eq} {
647    return [Q2tt $lambda_eq [tt2Q $lambda $twotheta]]
648}
649
650# converts a FWHM in 2theta(deg) to a FWHM at in 2theta
651# at a different wavelength
652proc delta2teq {lambda twotheta FWHM lambda_eq} {
653    return [expr [Q2tt $lambda_eq [tt2Q $lambda $twotheta+($FWHM/2.)]] - \
654                 [Q2tt $lambda_eq [tt2Q $lambda $twotheta-($FWHM/2.)]] ]
655}
656
657proc FWHM {tt U V W P} {
658    set pi 3.14159
659    set torad [expr $pi / 360.]
660    # tan theta
661    set tantt [expr tan($tt * $torad ) ]
662    set costt [expr cos($tt * $torad ) ]
663    return [expr sqrt \
664            (8.* log(2) * ($U * $tantt * $tantt + $V * $tantt + $W \
665            + $P / ($costt * $costt))) / 100.]
666}
667proc LFWHM {tt X Y} {
668    set pi 3.14159
669    set torad [expr $pi / 360.]
670    # tan theta
671    set tantt [expr tan($tt * $torad ) ]
672    set costt [expr cos($tt * $torad ) ]
673    return [expr ($X / $costt + $Y * $tantt) / 100.]
674}
675
676proc setlegend {box legend} {
677    global blt_version
678    if {$blt_version >= 2.3 && $blt_version < 8.0} {
679        if $legend {
680            $box legend config -hide no
681        } else {
682            $box legend config -hide yes
683        }
684    } else {
685        if $legend {
686            $box legend config -mapped yes
687        } else {
688            $box legend config -mapped no
689        }
690    }
691}
692
693trace variable newmenu(opt) w loadopt
694
695set legend 0
696set equivwave {}
697set plotunits tt
698if {$tcl_platform(platform) == "windows"} {
699    set graph(printout) 1
700} else {
701    set graph(printout) 0
702}
703set graph(outname) out.ps
704set graph(outcmd) lpr
705set datalist {}
706
707if {$expnam != ""} {
708    if [expload $expnam.EXP] {
709        tk_dialog .err "EXP Error" "Error -- Unable to read $expnam.EXP" \
710                error 0 Quit
711        destroy .
712    }
713    # OK now go get the profile info
714    getprofiles
715}
716
717# get the location of the script but translate up to n levels of links
718set scriptname [info script]
719set i -1
720while {[file type $scriptname] == "link"} {
721    if {[incr i] >= 20} {
722        puts "More than $i links for [info script], giving up"
723        destroy .
724    }
725    if {[file pathtype [set link [file readlink $scriptname]]] == "absolute"} {
726        set scriptname $link
727    } {
728        set scriptname [file dirname $scriptname]/$link
729    }
730}
731set scriptdir [file dirname $scriptname]
732
733foreach file [glob -nocomplain [file join $scriptdir widplt_*]] {
734    source $file
735}
736
737# create the graph
738set box [graph .g]
739Blt_ZoomStack $box
740Blt_ActiveLegend $box
741Blt_ClosestPoint $box
742$box config -title {}
743$box yaxis config -title {FWHM}
744setlegend $box $legend
745#frame .a -bd 8 -relief groove
746frame .a -bd 2 -relief groove
747
748pack [menubutton .a.file -text File -underline 0 -menu .a.file.menu] -side left
749menu .a.file.menu
750pack [menubutton .a.plot -text "Plot Contents" -underline 0 -menu .a.plot.menu] -side left
751menu .a.plot.menu
752#.a.file.menu add cascade -label Tickmarks -menu .a.file.menu.tick
753if {$expnam != ""} {
754    .a.file.menu add command -label "Reload from EXP" -command getprofiles
755}
756.a.file.menu add command -label "Add New Curve" -command newmenu
757.a.file.menu add command -label "Edit Curve" -command editmenu
758.a.file.menu add command -label "Make PostScript" -command makepostscriptout
759.a.file.menu add command -label Quit -command "destroy ."
760pack [menubutton .a.options -text Options -underline 0 -menu .a.options.menu] \
761        -side left   
762menu .a.options.menu
763.a.options.menu add radiobutton -label "2Theta" -value tt -variable plotunits \
764        -command "plotdata $box"
765.a.options.menu add command -label "Set Equiv. Wavelength" -command "seteqwave $box"
766.a.options.menu add radiobutton -label "d-space" -value d -variable plotunits \
767        -command "plotdata $box"
768.a.options.menu add radiobutton -label "Q" -value q -variable plotunits \
769        -command "plotdata $box"
770.a.options.menu add checkbutton -label "Include legend" -variable legend \
771        -command {setlegend $box $legend}
772.a.options.menu add command -label "Set PS output" -command setpostscriptout
773
774pack [menubutton .a.help -text Help -underline 0 -menu .a.help.menu] -side right
775menu .a.help.menu -tearoff 0
776.a.help.menu add command -command aboutwidplot -label About
777
778foreach item $datalist {
779    .a.plot.menu add checkbutton -label $lblarr($item) \
780            -command {plotdata $box} -variable display($item)
781}
782
783pack .a -side top -fill both
784pack $box -fill both -expand yes
785set datanum 0
786donewait
Note: See TracBrowser for help on using the repository browser.