Context Navigation

← Previous Revision
Next Revision →
Normal
Revision Log

source: trunk/widplt

Last change on this file was 1251, checked in by toby, 7 years ago
use svn ps svn:eol-style "native" * to change line ends
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Revision Id`
File size: 42.6 KB

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

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: trunk/widplt

Download in other formats: