source: trunk/widplt @ 698

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

# on 2003/05/22 21:41:53, toby did:
Implement windows init file as c:\GSAS\GSAS.CONFIG in place of .GSAS_CONFIG

  • Property rcs:author set to toby
  • Property rcs:date set to 2003/05/22 21:41:53
  • Property rcs:lines set to +16 -7
  • Property rcs:rev set to 1.14
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 34.2 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 698 2009-12-04 23:10:31Z toby $
10set Revision {$Revision: 698 $ $Date: 2009-12-04 23:10:31 +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  tcl_platform
677    if {$tcl_platform(platform) == "windows"} {
678        set fp [open c:/gsas.config a]
679    } else {
680        set fp [open [file join ~ .gsas_config] a]
681    }
682    puts $fp "# WIDPLT saved options from [clock format [clock ticks]]"
683    puts $fp "set graph(legend) [list $graph(legend)]"
684    puts $fp "set graph(printout) [list $graph(printout)]"
685    puts $fp "set graph(outname) [list $graph(outname)]"
686    puts $fp "set graph(outcmd) [list $graph(outcmd)]"
687    puts $fp "set graph(plotunits) [list $graph(plotunits)]"
688    puts $fp "set graph(equivwave) [list $graph(equivwave)]"
689    close $fp
690}
691
692proc MakeCascadeMenus {} {
693    global WidSetList lblarr box absSetList ABS
694    .a.plot.menu delete 0 end
695    .a.file.menu.edit delete 0 end
696    global program
697    if {$program != "absplt"} {
698        foreach item $WidSetList {
699            .a.plot.menu add checkbutton -label $lblarr($item) \
700                    -command "plotdata $box" -variable WidDisplay($item)
701            .a.file.menu.edit add command -label $lblarr($item) \
702                    -command "editProfileValues $item"
703        }
704    } else {
705        foreach item $absSetList {
706            .a.plot.menu add checkbutton -label [lindex $ABS($item) 4] \
707                    -command "plotdata $box" -variable AbsDisplay($item)
708            .a.file.menu.edit add command -label [lindex $ABS($item) 4] \
709                    -command "editAbsValues $item"
710        }
711    }
712}
713#-------------------------------------------------------------------------
714# converts 2theta(deg) to Q (A-1)
715proc tt2Q {lambda twotheta} {
716    set pi 3.14159
717    set torad [expr $pi / 360.]
718    return [expr 4 * $pi / ($lambda) * sin (($twotheta) * $torad)]
719}
720
721# converts Q (A-1) to 2theta(deg)
722proc Q2tt {lambda Q} {
723    set pi 3.14159
724    set todeg [expr 360. / $pi]
725    set asinarg [expr ($lambda) * $Q * 0.25 / $pi]
726    if {$asinarg <= 1} {
727        return [expr $todeg * asin ($asinarg)]
728    }
729    return {}
730}
731
732# converts a FWHM in 2theta(deg) to a FWHM in Q (A-1)
733proc deltaQ {lambda twotheta FWHM} {
734    return [expr [tt2Q $lambda $twotheta+($FWHM/2.)] - \
735                 [tt2Q $lambda $twotheta-($FWHM/2.)] ]
736}
737
738# converts 2theta(deg) to d (A)
739proc tt2d {lambda twotheta} {
740    set pi 3.14159
741    set torad [expr $pi / 360.]
742    return [expr 0.5 * ($lambda) / sin (($twotheta) * $torad)]
743}
744
745# converts d (A) to 2theta(deg)
746proc d2tt {lambda d} {
747    set pi 3.14159
748    set todeg [expr 360. / $pi]
749    set asinarg [expr ($lambda) * 0.5 / $d]
750    if {$asinarg <= 1} {
751        return [expr $todeg * asin ($asinarg)]
752    }
753    return {}
754}
755
756# converts a FWHM in 2theta(deg) to a FWHM in Q (A-1)
757proc deltad {lambda twotheta FWHM} {
758    return [expr [tt2d $lambda $twotheta-($FWHM/2.)] - \
759                 [tt2d $lambda $twotheta+($FWHM/2.)] ]
760}
761
762# computes an equivalent 2theta at a different wavelength
763proc ttequiv {lambda twotheta lambda_eq} {
764    return [Q2tt $lambda_eq [tt2Q $lambda $twotheta]]
765}
766
767# converts a FWHM in 2theta(deg) to a FWHM at in 2theta
768# at a different wavelength
769proc delta2teq {lambda twotheta FWHM lambda_eq} {
770    return [expr [Q2tt $lambda_eq [tt2Q $lambda $twotheta+($FWHM/2.)]] - \
771                 [Q2tt $lambda_eq [tt2Q $lambda $twotheta-($FWHM/2.)]] ]
772}
773
774# convert x values to d-space
775proc tod {xlist hst} {
776    global expmap
777    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
778        return [toftod $xlist $hst]
779    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
780        return [tttod $xlist $hst]
781    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
782        return [engtod $xlist $hst]
783    } else {
784        return {}
785    }
786}
787
788# convert tof to d-space
789proc toftod {toflist hst} {
790    set difc [expr {[histinfo $hst difc]/1000.}]
791    set difc2 [expr {$difc*$difc}]
792    set difa [expr {[histinfo $hst difa]/1000.}]
793    set zero [expr {[histinfo $hst zero]/1000.}]
794    set ans {}
795    foreach tof $toflist {
796        if {$tof == 0.} {
797            lappend ans 0.
798        } elseif {$tof == 1000.} {
799            lappend ans 1000.
800        } else {
801            set td [expr {$tof-$zero}]
802            lappend ans [expr {$td*($difc2+$difa*$td)/ \
803                    ($difc2*$difc+2.0*$difa*$td)}]
804        }
805    }
806    return $ans
807}
808
809# convert two-theta to d-space
810proc tttod {twotheta hst} {
811    set lamo2 [expr {0.5 * [histinfo $hst lam1]}]
812    set zero [expr [histinfo $hst zero]/100.]
813    set ans {}
814    set cnv [expr {acos(0.)/180.}]
815    foreach tt $twotheta {
816        if {$tt == 0.} {
817            lappend ans 99999.
818        } elseif {$tt == 1000.} {
819            lappend ans 0.
820        } else {
821            lappend ans [expr {$lamo2 / sin($cnv*($tt-$zero))}]
822        }
823    }
824    return $ans
825}
826
827# convert energy (edx-ray) to d-space
828# (note that this ignores the zero correction)
829proc engtod {eng hst} {
830    set lam [histinfo $hst lam1]
831    set zero [histinfo $hst zero]
832    set ans {}
833    set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
834    foreach e $eng {
835        if {$e == 0.} {
836            lappend ans 1000.
837        } elseif {$e == 1000.} {
838            lappend ans 0.
839        } else {
840            lappend ans [expr {$v/$e}]
841        }
842    }
843    return $ans
844}
845
846# convert x values to Q
847proc toQ {xlist hst} {
848    global expmap
849    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
850        return [toftoQ $xlist $hst]
851    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
852        return [tttoQ $xlist $hst]
853    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
854        return [engtoQ $xlist $hst]
855    } else {
856        return {}
857    }
858}
859# convert tof to Q
860proc toftoQ {toflist hst} {
861    set difc [expr {[histinfo $hst difc]/1000.}]
862    set difc2 [expr {$difc*$difc}]
863    set difa [expr {[histinfo $hst difa]/1000.}]
864    set zero [expr {[histinfo $hst zero]/1000.}]
865    set 2pi [expr {4.*acos(0.)}]
866    set ans {}
867    foreach tof $toflist {
868        if {$tof == 0.} {
869            lappend ans 99999.
870        } elseif {$tof == 1000.} {
871            lappend ans 0.
872        } else {
873            set td [expr {$tof-$zero}]
874            lappend ans [expr {$2pi * \
875                    ($difc2*$difc+2.0*$difa*$td)/($td*($difc2+$difa*$td))}]
876        }
877    }
878    return $ans
879}
880
881# convert two-theta to Q
882proc tttoQ {twotheta hst} {
883    set lamo2 [expr {0.5 * [histinfo $hst lam1]}]
884    set zero [expr [histinfo $hst zero]/100.]
885    set ans {}
886    set cnv [expr {acos(0.)/180.}]
887    set 2pi [expr {4.*acos(0.)}]
888    foreach tt $twotheta {
889        if {$tt == 0.} {
890            lappend ans 0.
891        } elseif {$tt == 1000.} {
892            lappend ans 1000.
893        } else {
894            lappend ans [expr {$2pi * sin($cnv*($tt-$zero)) / $lamo2}]
895        }
896    }
897    return $ans
898}
899# convert energy (edx-ray) to Q
900# (note that this ignores the zero correction)
901proc engtoQ {eng hst} {
902    set lam [histinfo $hst lam1]
903    set zero [histinfo $hst zero]
904    set ans {}
905    set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
906    set 2pi [expr {4.*acos(0.)}]
907    foreach e $eng {
908        if {$e == 0.} {
909            lappend ans 0.
910        } elseif {$e == 1000.} {
911            lappend ans 1000.
912        } else {
913            lappend ans [expr {$2pi * $e / $v}]
914        }
915    }
916    return $ans
917}
918proc sind {angle} {
919    return [expr {sin($angle*acos(0.)/90.)}]
920}
921
922proc FWHM {tt U V W P} {
923    set pi 3.14159
924    set torad [expr $pi / 360.]
925    # tan theta
926    set tantt [expr tan($tt * $torad ) ]
927    set costt [expr cos($tt * $torad ) ]
928    return [expr sqrt \
929            (8.* log(2) * ($U * $tantt * $tantt + $V * $tantt + $W \
930            + $P / ($costt * $costt))) / 100.]
931}
932proc LFWHM {tt X Y} {
933    set pi 3.14159
934    set torad [expr $pi / 360.]
935    # tan theta
936    set tantt [expr tan($tt * $torad ) ]
937    set costt [expr cos($tt * $torad ) ]
938    return [expr ($X / $costt + $Y * $tantt) / 100.]
939}
940
941proc setlegend {box legend} {
942    global blt_version
943    if {$blt_version >= 2.3 && $blt_version < 8.0} {
944        if $legend {
945            $box legend config -hide no
946        } else {
947            $box legend config -hide yes
948        }
949    } else {
950        if $legend {
951            $box legend config -mapped yes
952        } else {
953            $box legend config -mapped no
954        }
955    }
956}
957
958set graph(legend) 0
959set graph(equivwave) {}
960set graph(plotunits) tt
961if {$tcl_platform(platform) == "windows"} {
962    set graph(printout) 1
963} else {
964    set graph(printout) 0
965}
966set graph(outname) out.ps
967set graph(outcmd) lpr
968set WidSetList {}
969set absSetList {}
970
971#----------------------------------------------------------------
972# where are we?
973set expgui(script) [info script]
974# translate links -- go six levels deep
975foreach i {1 2 3 4 5 6} {
976    if {[file type $expgui(script)] == "link"} {
977        set link [file readlink $expgui(script)]
978        if { [file  pathtype  $link] == "absolute" } {
979h           set expgui(script) $link
980        } {
981            set expgui(script) [file dirname $expgui(script)]/$link
982        }
983    } else {
984        break
985    }
986}
987# fixup relative paths
988if {[file pathtype $expgui(script)] == "relative"} {
989    set expgui(script) [file join [pwd] $expgui(script)]
990}
991set expgui(scriptdir) [file dirname $expgui(script) ]
992set expgui(docdir) [file join $expgui(scriptdir) doc]
993# location for web pages, if not found locally
994set expgui(website) www.ncnr.nist.gov/xtal/software/expgui
995
996# fetch EXP file processing routines
997source [file join $expgui(scriptdir) readexp.tcl]
998source [file join $expgui(scriptdir) gsascmds.tcl]
999
1000# override options with locally defined values
1001set filelist [file join $expgui(scriptdir) localconfig]
1002if {$tcl_platform(platform) == "windows"} {
1003    lappend filelist "c:/gsas.config"
1004} else {
1005    lappend filelist [file join ~ .gsas_config]
1006}
1007if {[catch {
1008    foreach file $filelist {
1009        if [file exists $file] {source $file}
1010    }
1011} errmsg]} {
1012    set msg "Error reading file $file (aka [file nativename $file]): $errmsg"
1013    MyMessageBox -parent . -title "Customize warning" \
1014        -message $msg -icon warning -type Ignore -default ignore \
1015        -helplink "expguierr.html Customizewarning"
1016}
1017#----------------------------------------------------------------
1018
1019set datalist {}
1020foreach file [glob -nocomplain [file join $expgui(scriptdir) widplt_*]] {
1021    source $file
1022}
1023set WidSetList $datalist
1024
1025# create the graph
1026if [catch {
1027    set box [graph .g]
1028} errmsg] {
1029    tk_dialog .err "BLT Error" \
1030"BLT Setup Error: could not create a graph (msg: $errmsg). \
1031There is a problem with the setup of BLT on your system.
1032See the expgui.html file for more info." \
1033            error 0 "Quit"
1034exit
1035}
1036if [catch {
1037    Blt_ZoomStack $box
1038    Blt_ActiveLegend $box
1039    Blt_ClosestPoint $box
1040} errmsg] {
1041    tk_dialog .err "BLT Error" \
1042"BLT Setup Error: could not access a Blt_ routine (msg: $errmsg). \
1043The pkgIndex.tcl is probably not loading bltGraph.tcl.
1044See the expgui.html file for more info." \
1045            error 0 "Limp ahead"
1046}
1047$box config -title {}
1048setlegend $box $graph(legend)
1049
1050#frame .a -bd 8 -relief groove
1051frame .a -bd 2 -relief groove
1052
1053pack [menubutton .a.file -text File -underline 0 -menu .a.file.menu] -side left
1054menu .a.file.menu
1055pack [menubutton .a.plot -text "Plot Contents" -underline 0 -menu .a.plot.menu] -side left
1056menu .a.plot.menu
1057#.a.file.menu add cascade -label Tickmarks -menu .a.file.menu.tick
1058if {$expnam != ""} {
1059    .a.file.menu add command -label "Reload from EXP" \
1060            -command "getprofiles $expnam; plotdata $box"
1061}
1062if {$program == "absplt"} {
1063    .a.file.menu add cascade -label "Edit Abs Params" -menu .a.file.menu.edit
1064} else {
1065    .a.file.menu add command -label "Add New Curve" -command NewProfileValues
1066    .a.file.menu add cascade -label "Edit Curve" -menu .a.file.menu.edit
1067}
1068menu .a.file.menu.edit
1069.a.file.menu add command -label "Make PostScript" -command makepostscriptout
1070.a.file.menu add command -label Quit -command "destroy ."
1071pack [menubutton .a.options -text Options -underline 0 -menu .a.options.menu] \
1072        -side left   
1073menu .a.options.menu
1074if {$program == "absplt"} {
1075    .a.options.menu add radiobutton -label "2Theta/Tof/Eng" -value tt \
1076            -variable graph(plotunits) \
1077            -command "plotdata $box"
1078} else {
1079    .a.options.menu add radiobutton -label "2Theta" -value tt \
1080            -variable graph(plotunits) \
1081            -command "plotdata $box"
1082    .a.options.menu add command -label "Set Equiv. Wavelength" \
1083            -command "seteqwave $box"
1084}
1085.a.options.menu add radiobutton -label "d-space" -value d \
1086        -variable graph(plotunits) \
1087        -command "plotdata $box"
1088.a.options.menu add radiobutton -label "Q" -value q \
1089        -variable graph(plotunits) \
1090        -command "plotdata $box"
1091.a.options.menu add checkbutton -label "Include legend" \
1092        -variable graph(legend) \
1093        -command {setlegend $box $graph(legend)}
1094.a.options.menu add command -label "Set PS output" \
1095        -command setpostscriptout
1096.a.options.menu add command -label "Save Options" -underline 1 \
1097        -command "SaveOptions"
1098
1099pack [menubutton .a.help -text Help -underline 0 -menu .a.help.menu] -side right
1100menu .a.help.menu -tearoff 0
1101.a.help.menu add command -command aboutwidplot -label About
1102
1103pack .a -side top -fill both
1104pack $box -fill both -expand yes
1105
1106#----------------------------------------------------------------
1107# OK now go get the profile info
1108if {$expnam != ""} {
1109    getprofiles $expnam
1110}
1111#----------------------------------------------------------------
1112
1113    trace variable newmenu(opt) w setoptmsg
1114
1115proc setoptmsg {args} {
1116    global newmenu
1117    array set opttxt {
1118        0 "Cylindrical samples, Lobanov & Alte da Veiga (TOF, CW, synch.)"
1119        1 "Simple linear (TOF)"
1120        2 "Surface Roughness, Pitschke, Hermann & Muttern (Bragg-Brentano)"
1121        3 "Surface Roughness, Suortti (Bragg-Brentano)"
1122        4 "Flat plate, transmission mode"
1123    }
1124    set newmenu(opttxt) ""
1125    catch {set newmenu(opttxt) [set opttxt($newmenu(opt))]}
1126}
1127set datanum 0
1128donewaitmsg
Note: See TracBrowser for help on using the repository browser.