Context Navigation

source: trunk/gsascmds.tcl @ 481

Last change on this file since 481 was 479, checked in by toby, 13 years ago
# on 2001/10/31 20:07:41, toby did: change excledt to run "in-line"
Property rcs:author set to `toby` Property rcs:date set to `2001/10/31 20:07:41` Property rcs:lines set to `+22 -30` Property rcs:rev set to `1.40` Property rcs:state set to `Exp` Property svn:keywords set to `Author Date Revision Id`
File size: 80.8 KB

Line
1	# $Id: gsascmds.tcl 479 2009-12-04 23:06:51Z toby $
2	#------------------------------------------------------------------------------
3	# display routines
4	#------------------------------------------------------------------------------
5	# Message box code that centers the message box over the parent.
6	# or along the edge, if too close,
7	# but leave a border along +x & +y for reasons I don't remember
8	# It also allows the button names to be defined using
9	# -type $list -- where $list has a list of button names
10	# larger messages are placed in a scrolled text widget
11	# capitalization is now ignored for -default
12	# The command returns the name button in all lower case letters
13	# otherwise see tk_messageBox for a description
14	#
15	# This is a modification of tkMessageBox (msgbox.tcl v1.5)
16	#
17	proc MyMessageBox {args} {
18	global tkPriv tcl_platform
19
20	set w tkPrivMsgBox
21	upvar #0 $w data
22
23	#
24	# The default value of the title is space (" ") not the empty string
25	# because for some window managers, a
26	# wm title .foo ""
27	# causes the window title to be "foo" instead of the empty string.
28	#
29	set specs {
30	{-default "" "" ""}
31	{-icon "" "" "info"}
32	{-message "" "" ""}
33	{-parent "" "" .}
34	{-title "" "" " "}
35	{-type "" "" "ok"}
36	{-helplink "" "" ""}
37	}
38
39	tclParseConfigSpec $w $specs "" $args
40
41	if {[lsearch {info warning error question} $data(-icon)] == -1} {
42	error "bad -icon value \"$data(-icon)\": must be error, info, question, or warning"
43	}
44	if {![string compare $tcl_platform(platform) "macintosh"]} {
45	switch -- $data(-icon) {
46	"error" {set data(-icon) "stop"}
47	"warning" {set data(-icon) "caution"}
48	"info" {set data(-icon) "note"}
49	}
50	}
51
52	if {![winfo exists $data(-parent)]} {
53	error "bad window path name \"$data(-parent)\""
54	}
55
56	switch -- $data(-type) {
57	abortretryignore {
58	set buttons {
59	{abort -width 6 -text Abort -under 0}
60	{retry -width 6 -text Retry -under 0}
61	{ignore -width 6 -text Ignore -under 0}
62	}
63	}
64	ok {
65	set buttons {
66	{ok -width 6 -text OK -under 0}
67	}
68	if {![string compare $data(-default) ""]} {
69	set data(-default) "ok"
70	}
71	}
72	okcancel {
73	set buttons {
74	{ok -width 6 -text OK -under 0}
75	{cancel -width 6 -text Cancel -under 0}
76	}
77	}
78	retrycancel {
79	set buttons {
80	{retry -width 6 -text Retry -under 0}
81	{cancel -width 6 -text Cancel -under 0}
82	}
83	}
84	yesno {
85	set buttons {
86	{yes -width 6 -text Yes -under 0}
87	{no -width 6 -text No -under 0}
88	}
89	}
90	yesnocancel {
91	set buttons {
92	{yes -width 6 -text Yes -under 0}
93	{no -width 6 -text No -under 0}
94	{cancel -width 6 -text Cancel -under 0}
95	}
96	}
97	default {
98	# error "bad -type value \"$data(-type)\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel"
99	foreach item $data(-type) {
100	lappend buttons [list [string tolower $item] -text $item -under 0]
101	}
102	}
103	}
104
105	if {[string compare $data(-default) ""]} {
106	set valid 0
107	foreach btn $buttons {
108	if {![string compare [lindex $btn 0] [string tolower $data(-default)]]} {
109	set valid 1
110	break
111	}
112	}
113	if {!$valid} {
114	error "invalid default button \"$data(-default)\""
115	}
116	}
117
118	# 2. Set the dialog to be a child window of $parent
119	#
120	#
121	if {[string compare $data(-parent) .]} {
122	set w $data(-parent).__tk__messagebox
123	} else {
124	set w .__tk__messagebox
125	}
126
127	# 3. Create the top-level window and divide it into top
128	# and bottom parts.
129
130	catch {destroy $w}
131	toplevel $w -class Dialog
132	wm title $w $data(-title)
133	wm iconname $w Dialog
134	wm protocol $w WM_DELETE_WINDOW { }
135	wm transient $w $data(-parent)
136	if {![string compare $tcl_platform(platform) "macintosh"]} {
137	unsupported1 style $w dBoxProc
138	}
139
140	frame $w.bot
141	pack $w.bot -side bottom -fill both
142	frame $w.top
143	pack $w.top -side top -fill both -expand 1
144	if {$data(-helplink) != ""} {
145	# frame $w.help
146	# pack $w.help -side top -fill both
147	pack [button $w.top.1 -text Help -bg yellow \
148	-command "MakeWWWHelp $data(-helplink)"] \
149	-side right -anchor ne
150	bind $w <Key-F1> "MakeWWWHelp $data(-helplink)"
151	}
152	if {[string compare $tcl_platform(platform) "macintosh"]} {
153	$w.bot configure -relief raised -bd 1
154	$w.top configure -relief raised -bd 1
155	}
156
157	# 4. Fill the top part with bitmap and message (use the option
158	# database for -wraplength and -font so that they can be
159	# overridden by the caller).
160
161	option add *Dialog.msg.wrapLength 6i widgetDefault
162
163	if {[string length $data(-message)] > 300} {
164	if {![string compare $tcl_platform(platform) "macintosh"]} {
165	option add *Dialog.msg.t.font system widgetDefault
166	} else {
167	option add *Dialog.msg.t.font {Times 18} widgetDefault
168	}
169	frame $w.msg
170	grid [text $w.msg.t \
171	-height 20 -width 55 -relief flat -wrap word \
172	-yscrollcommand "$w.msg.rscr set" \
173	] -row 1 -column 0 -sticky news
174	grid [scrollbar $w.msg.rscr -command "$w.msg.t yview" \
175	] -row 1 -column 1 -sticky ns
176	# give extra space to the text box
177	grid columnconfigure $w.msg 0 -weight 1
178	grid rowconfigure $w.msg 1 -weight 1
179	$w.msg.t insert end $data(-message)
180	} else {
181	if {![string compare $tcl_platform(platform) "macintosh"]} {
182	option add *Dialog.msg.font system widgetDefault
183	} else {
184	option add *Dialog.msg.font {Times 18} widgetDefault
185	}
186	label $w.msg -justify left -text $data(-message)
187	}
188	pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
189	if {[string compare $data(-icon) ""]} {
190	label $w.bitmap -bitmap $data(-icon)
191	pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
192	}
193
194	# 5. Create a row of buttons at the bottom of the dialog.
195
196	set i 0
197	foreach but $buttons {
198	set name [lindex $but 0]
199	set opts [lrange $but 1 end]
200	if {![llength $opts]} {
201	# Capitalize the first letter of $name
202	set capName [string toupper \
203	[string index $name 0]][string range $name 1 end]
204	set opts [list -text $capName]
205	}
206
207	eval button [list $w.$name] $opts [list -command [list set tkPriv(button) $name]]
208
209	if {![string compare $name [string tolower $data(-default)]]} {
210	$w.$name configure -default active
211	}
212	pack $w.$name -in $w.bot -side left -expand 1 -padx 3m -pady 2m
213
214	# create the binding for the key accelerator, based on the underline
215	#
216	set underIdx [$w.$name cget -under]
217	if {$underIdx >= 0} {
218	set key [string index [$w.$name cget -text] $underIdx]
219	bind $w <Alt-[string tolower $key]> [list $w.$name invoke]
220	bind $w <Alt-[string toupper $key]> [list $w.$name invoke]
221	}
222	incr i
223	}
224
225	# 6. Create a binding for <Return> on the dialog if there is a
226	# default button.
227
228	if {[string compare $data(-default) ""]} {
229	bind $w <Return> [list tkButtonInvoke $w.[string tolower $data(-default)]]
230	}
231
232	# 7. Withdraw the window, then update all the geometry information
233	# so we know how big it wants to be, then center the window in the
234	# display and de-iconify it.
235
236	wm withdraw $w
237	update idletasks
238	set wp $data(-parent)
239	# center the new window in the middle of the parent
240	set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
241	[winfo reqwidth $w]/2 - [winfo vrootx $wp]]
242	set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
243	[winfo reqheight $w]/2 - [winfo vrooty $wp]]
244	# make sure that we can see the entire window
245	set xborder 10
246	set yborder 25
247	if {$x < 0} {set x 0}
248	if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
249	incr x [expr \
250	[winfo screenwidth $w] - ($x+[winfo reqwidth $w] + $xborder)]
251	}
252	if {$y < 0} {set y 0}
253	if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
254	incr y [expr \
255	[winfo screenheight $w] - ($y+[winfo reqheight $w] + $yborder)]
256	}
257	wm geom $w +$x+$y
258	wm deiconify $w
259
260	# 8. Set a grab and claim the focus too.
261
262	catch {set oldFocus [focus]}
263	catch {set oldGrab [grab current $w]}
264	catch {
265	grab $w
266	if {[string compare $data(-default) ""]} {
267	focus $w.[string tolower $data(-default)]
268	} else {
269	focus $w
270	}
271	}
272
273	# 9. Wait for the user to respond, then restore the focus and
274	# return the index of the selected button. Restore the focus
275	# before deleting the window, since otherwise the window manager
276	# may take the focus away so we can't redirect it. Finally,
277	# restore any grab that was in effect.
278
279	tkwait variable tkPriv(button)
280	catch {focus $oldFocus}
281	destroy $w
282	catch {grab $oldGrab}
283	return $tkPriv(button)
284	}
285
286	# tell'em what is happening
287	proc pleasewait {{message {}}} {
288	catch {destroy .msg}
289	toplevel .msg
290	wm transient .msg [winfo toplevel .]
291	pack [frame .msg.f -bd 4 -relief groove]
292	pack [message .msg.f.m -text "Please wait $message"]
293	wm withdraw .msg
294	update idletasks
295	# place the message on top of the main window
296	set x [expr [winfo x .] + [winfo width .]/2 - \
297	[winfo reqwidth .msg]/2 - [winfo vrootx .]]
298	if {$x < 0} {set x 0}
299	set y [expr [winfo y .] + [winfo height .]/2 - \
300	[winfo reqheight .msg]/2 - [winfo vrooty .]]
301	if {$y < 0} {set y 0}
302	wm geom .msg +$x+$y
303	wm deiconify .msg
304	global makenew
305	set makenew(OldGrab) ""
306	set makenew(OldFocus) ""
307	# save focus & grab
308	catch {set makenew(OldFocus) [focus]}
309	catch {set makenew(OldGrab) [grab current .msg]}
310	catch {grab .msg}
311	update
312	}
313
314	# clear the message
315	proc donewait {} {
316	global makenew
317	catch {destroy .msg}
318	# reset focus & grab
319	catch {
320	if {$makenew(OldFocus) != ""} {
321	focus $makenew(OldFocus)
322	}
323	}
324	catch {
325	if {$makenew(OldGrab) != ""} {
326	grab $makenew(OldGrab)
327	}
328	}
329	}
330
331	proc putontop {w} {
332	# center window $w above its parent and make it stay on top
333	set wp [winfo parent $w]
334	wm transient $w [winfo toplevel $wp]
335	wm withdraw $w
336	update idletasks
337	# center the new window in the middle of the parent
338	set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
339	[winfo reqwidth $w]/2 - [winfo vrootx $wp]]
340	if {$x < 0} {set x 0}
341	set xborder 10
342	if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
343	incr x [expr \
344	[winfo screenwidth $w] - ($x+[winfo reqwidth $w] + $xborder)]
345	}
346	set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
347	[winfo reqheight $w]/2 - [winfo vrooty $wp]]
348	if {$y < 0} {set y 0}
349	set yborder 25
350	if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
351	incr y [expr \
352	[winfo screenheight $w] - ($y+[winfo reqheight $w] + $yborder)]
353	}
354	wm geom $w +$x+$y
355	wm deiconify $w
356
357	global makenew
358	set makenew(OldGrab) ""
359	set makenew(OldFocus) ""
360	catch {set makenew(OldFocus) [focus]}
361	catch {set makenew(OldGrab) [grab current $w]}
362	catch {grab $w}
363	}
364
365	proc afterputontop {} {
366	# restore focus
367	global makenew
368	# reset focus & grab
369	catch {
370	if {$makenew(OldFocus) != ""} {
371	focus $makenew(OldFocus)
372	}
373	}
374	catch {
375	if {$makenew(OldGrab) != ""} {
376	grab $makenew(OldGrab)
377	}
378	}
379	}
380
381	proc ShowBigMessage {win labeltext msg "optionlist OK" "link {}" "err 0"} {
382	catch {destroy $win}
383	toplevel $win
384
385	pack [label $win.l1 -text $labeltext] -side top
386	if {$err} {$win.l1 config -fg red}
387	pack [frame $win.f1] -side top -expand yes -fill both
388	grid [text $win.f1.t \
389	-height 20 -width 55 -wrap none -font Courier \
390	-xscrollcommand "$win.f1.bscr set" \
391	-yscrollcommand "$win.f1.rscr set" \
392	] -row 1 -column 0 -sticky news
393	grid [scrollbar $win.f1.bscr -orient horizontal \
394	-command "$win.f1.t xview" \
395	] -row 2 -column 0 -sticky ew
396	grid [scrollbar $win.f1.rscr -command "$win.f1.t yview" \
397	] -row 1 -column 1 -sticky ns
398	# give extra space to the text box
399	grid columnconfigure $win.f1 0 -weight 1
400	grid rowconfigure $win.f1 1 -weight 1
401	$win.f1.t insert end $msg
402
403	global makenew
404	set makenew(result) 0
405	bind $win <Return> "destroy $win"
406	bind $win <KeyPress-Prior> "$win.f1.t yview scroll -1 page"
407	bind $win <KeyPress-Next> "$win.f1.t yview scroll 1 page"
408	bind $win <KeyPress-Right> "$win.f1.t xview scroll 1 unit"
409	bind $win <KeyPress-Left> "$win.f1.t xview scroll -1 unit"
410	bind $win <KeyPress-Up> "$win.f1.t yview scroll -1 unit"
411	bind $win <KeyPress-Down> "$win.f1.t yview scroll 1 unit"
412	bind $win <KeyPress-Home> "$win.f1.t yview 0"
413	bind $win <KeyPress-End> "$win.f1.t yview end"
414	set i 0
415	foreach item $optionlist {
416	pack [button $win.q[incr i] \
417	-command "set makenew(result) $i; destroy $win" -text $item] -side left
418	}
419	if {$link != ""} {
420	pack [button $win.help -text Help -bg yellow \
421	-command "MakeWWWHelp $link"] \
422	-side right
423	bind $win <Key-F1> "MakeWWWHelp $link"
424	}
425	putontop $win
426	tkwait window $win
427
428	# fix grab...
429	afterputontop
430	return $makenew(result)
431	}
432
433	# get a value in a modal dialog
434	proc getstring {what "chars 40" "quit 1" "initvalue {}"} {
435	global expgui expmap
436	set w .global
437	catch {destroy $w}
438	toplevel $w -bg beige
439	bind $w <Key-F1> "MakeWWWHelp expguierr.html Input[lindex $what 0]"
440	wm title $w "Input $what"
441	set expgui(temp) {}
442	pack [frame $w.0 -bd 6 -relief groove -bg beige] \
443	-side top -expand yes -fill both
444	grid [label $w.0.a -text "Input a value for the $what" \
445	-bg beige] \
446	-row 0 -column 0 -columnspan 10
447	grid [entry $w.0.b -textvariable expgui(temp) -width $chars] \
448	-row 1 -column 0
449
450	set expgui(temp) $initvalue
451	pack [frame $w.b -bg beige] -side top -fill x -expand yes
452	pack [button $w.b.2 -text Set -command "destroy $w"] -side left
453	if $quit {
454	pack [button $w.b.3 -text Quit \
455	-command "set expgui(temp) {}; destroy $w"] -side left
456	}
457	bind $w <Return> "destroy $w"
458	pack [button $w.b.help -text Help -bg yellow \
459	-command "MakeWWWHelp expguierr.html Input[lindex $what 0]"] \
460	-side right
461
462	# force the window to stay on top
463	putontop $w
464
465	focus $w.b.2
466	tkwait window $w
467	afterputontop
468
469	return $expgui(temp)
470	}
471
472	#------------------------------------------------------------------------------
473	# profile/symmetry routines
474	#------------------------------------------------------------------------------
475	# profile terms
476	array set expgui {
477	prof-T-1 {alp-0 alp-1 bet-0 bet-1 sig-0 sig-1 sig-2 rstr rsta \
478	rsca s1ec s2ec }
479	prof-T-2 {alp-0 alp-1 beta switch sig-0 sig-1 sig-2 gam-0 gam-1 \
480	gam-2 ptec stec difc difa zero }
481	prof-T-3 {alp bet-0 bet-1 sig-0 sig-1 sig-2 gam-0 gam-1 \
482	gam-2 gsf g1ec g2ec rstr rsta rsca L11 L22 L33 L12 L13 L23 }
483	prof-T-4 {alp bet-0 bet-1 sig-1 sig-2 gam-2 g2ec gsf \
484	rstr rsta rsca eta}
485	prof-C-1 {GU GV GW asym F1 F2 }
486	prof-C-2 {GU GV GW LX LY trns asym shft GP stec ptec sfec \
487	L11 L22 L33 L12 L13 L23 }
488	prof-C-3 {GU GV GW GP LX LY S/L H/L trns shft stec ptec sfec \
489	L11 L22 L33 L12 L13 L23 }
490	prof-C-4 {GU GV GW GP LX ptec trns shft sfec S/L H/L eta}
491	prof-E-1 {A B C ds cds}
492	}
493
494	# number of profile terms depends on the histogram type
495	# the LAUE symmetry and the profile number
496	proc GetProfileTerms {phase hist ptype} {
497	global expmap expgui
498	if {$hist == "C" \|\| $hist == "T" \|\| $hist == "E"} {
499	set htype $hist
500	} else {
501	set htype [string range $expmap(htype_$hist) 2 2]
502	}
503	# get the cached copy of the profile term labels, when possible
504	set lbls {}
505	catch {
506	set lbls $expmap(ProfileTerms${phase}_${ptype}_${htype})
507	}
508	if {$lbls != ""} {return $lbls}
509
510	catch {set lbls $expgui(prof-$htype-$ptype)}
511	if {$lbls == ""} {return}
512	# add terms based on the Laue symmetry
513	if {($htype == "C" \|\| $htype == "T") && $ptype == 4} {
514	set laueaxis [GetLaue [phaseinfo $phase spacegroup]]
515	eval lappend lbls [Profile4Terms $laueaxis]
516	}
517	set expmap(ProfileTerms${phase}_${ptype}_${htype}) $lbls
518	return $lbls
519	}
520
521	proc Profile4Terms {laueaxis} {
522	switch -exact $laueaxis {
523	1bar {return \
524	"S400 S040 S004 S220 S202 S022 S310 S103 S031 \
525	S130 S301 S013 S211 S121 S112"}
526	2/ma {return "S400 S040 S004 S220 S202 S022 S013 S031 S211"}
527	2/mb {return "S400 S040 S004 S220 S202 S022 S301 S103 S121"}
528	2/mc {return "S400 S040 S004 S220 S202 S022 S130 S310 S112"}
529	mmm {return "S400 S040 S004 S220 S202 S022"}
530	4/m {return "S400 S004 S220 S202"}
531	4/mmm {return "S400 S004 S220 S202"}
532	3barR {return "S400 S220 S310 S211"}
533	"3bar mR" {return "S400 S220 S310 S211"}
534	3bar {return "S400 S004 S202 S211"}
535	3barm1 {return "S400 S004 S202"}
536	3bar1m {return "S400 S004 S202 S211"}
537	6/m {return "S400 S004 S202"}
538	6/mmm {return "S400 S004 S202"}
539	"m 3" {return "S400 S220"}
540	m3m {return "S400 S220"}
541	default {return ""}
542	}
543	}
544
545	proc GetLaue {spg} {
546	global tcl_platform expgui
547	# check the space group
548	set fp [open spg.in w]
549	puts $fp "N"
550	puts $fp "N"
551	puts $fp $spg
552	puts $fp "Q"
553	close $fp
554	catch {
555	if {$tcl_platform(platform) == "windows"} {
556	exec [file join $expgui(gsasexe) spcgroup.exe] < spg.in >& spg.out
557	} else {
558	exec [file join $expgui(gsasexe) spcgroup] < spg.in >& spg.out
559	}
560	}
561	set fp [open spg.out r]
562	set laue {}
563	set uniqueaxis {}
564	while {[gets $fp line] >= 0} {
565	regexp {Laue symmetry (.*)} $line junk laue
566	regexp {The unique axis is (.*)} $line junk uniqueaxis
567	}
568	close $fp
569	catch {file delete -force spg.in spg.out}
570	set laue [string trim $laue]
571	# add a R suffix for rhombohedral settings
572	if {[string range [string trim $spg] end end] == "R"} {
573	return "${laue}${uniqueaxis}R"
574	}
575	return "${laue}$uniqueaxis"
576	}
577
578	# set up to change the profile type for a series of histogram/phase entries
579	# (histlist & phaselist should be lists of the same length)
580	#
581	proc ChangeProfileType {histlist phaselist} {
582	global expgui expmap
583	set w .profile
584	catch {destroy $w}
585	toplevel $w -bg beige
586	wm title $w "Change Profile Function"
587
588	# all histogram/phases better be the same type, so we can just use the 1st
589	set hist [lindex $histlist 0]
590	set phase [lindex $phaselist 0]
591	set ptype [string trim [hapinfo $hist $phase proftype]]
592
593	# get list of allowed profile terms for the current histogram type
594	set i 1
595	while {[set lbls [GetProfileTerms $phase $hist $i]] != ""} {
596	lappend lbllist $lbls
597	incr i
598	}
599	# labels for the current type
600	set i $ptype
601	set oldlbls [lindex $lbllist [incr i -1]]
602
603	if {[llength $histlist] == 1} {
604	pack [label $w.a -bg beige \
605	-text "Change profile function for Histogram #$hist Phase #$phase" \
606	] -side top
607	} else {
608	# make a list of histograms by phase
609	foreach h $histlist p $phaselist {
610	lappend phlist($p) $h
611	}
612	set num 0
613	pack [frame $w.a -bg beige] -side top
614	pack [label $w.a.$num -bg beige \
615	-text "Change profile function for:" \
616	] -side top -anchor w
617	foreach i [lsort [array names phlist]] {
618	incr num
619	pack [label $w.a.$num -bg beige -text \
620	"\tPhase #$i, Histograms [CompressList $phlist($i)]" \
621	] -side top -anchor w
622	}
623	}
624	pack [label $w.e1 \
625	-text "Current function is type $ptype." \
626	-bg beige] -side top -anchor w
627	pack [frame $w.e -bg beige] -side top -expand yes -fill both
628	pack [label $w.e.1 \
629	-text "Set function to type" \
630	-bg beige] -side left
631	set menu [tk_optionMenu $w.e.2 expgui(newpeaktype) junk]
632	pack $w.e.2 -side left -anchor w
633
634	pack [radiobutton $w.e.4 -bg beige -variable expgui(DefaultPeakType) \
635	-command "set expgui(newpeaktype) $ptype; \
636	FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
637	-value 1 -text "Current value overrides"] -side right
638	pack [radiobutton $w.e.3 -bg beige -variable expgui(DefaultPeakType) \
639	-command \
640	"set expgui(newpeaktype) $ptype; \
641	FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
642	-value 0 -text "Default value overrides"] -side right
643
644	$w.e.2 config -bg beige
645	pack [frame $w.c -bg beige] -side top -expand yes -fill both
646	pack [frame $w.d -bg beige] -side top -expand yes -fill both
647	pack [button $w.d.2 -text Set \
648	-command "SaveChangeProfileType $w.c $histlist $phaselist; destroy $w"\
649	] -side left
650	pack [button $w.d.3 -text Quit \
651	-command "destroy $w"] -side left
652	pack [button $w.d.help -text Help -bg yellow \
653	-command "MakeWWWHelp expgui5.html ChangeType"] \
654	-side right
655	bind $w <Key-F1> "MakeWWWHelp expgui5.html ChangeType"
656	bind $w <Return> "destroy $w"
657
658	$menu delete 0 end
659	set i 0
660	foreach lbls $lbllist {
661	incr i
662	$menu add command -label $i -command \
663	"set expgui(newpeaktype) $i; \
664	FillChangeProfileType $w.c $hist $phase $i [list $lbls] [list $oldlbls]"
665	}
666	set expgui(newpeaktype) $ptype
667	FillChangeProfileType $w.c $hist $phase $ptype $oldlbls $oldlbls
668
669	# force the window to stay on top
670	putontop $w
671	focus $w.e.2
672	tkwait window $w
673	afterputontop
674	sethistlist
675	}
676
677	# save the changes to the profile
678	proc SaveChangeProfileType {w histlist phaselist} {
679	global expgui
680	foreach phase $phaselist hist $histlist {
681	hapinfo $hist $phase proftype set $expgui(newpeaktype)
682	hapinfo $hist $phase profterms set $expgui(newProfileTerms)
683	for {set i 1} {$i <= $expgui(newProfileTerms)} {incr i} {
684	hapinfo $hist $phase pterm$i set [$w.ent${i} get]
685	hapinfo $hist $phase pref$i set $expgui(ProfRef$i)
686	}
687	set i [expr 1+$expgui(newProfileTerms)]
688	hapinfo $hist $phase pcut set [$w.ent$i get]
689	incr expgui(changed) [expr 3 + $expgui(newProfileTerms)]
690	}
691	}
692
693	# file the contents of the "Change Profile Type" Menu
694	proc FillChangeProfileType {w hist phase newtype lbls oldlbls} {
695	global expgui expmap
696	set ptype [string trim [hapinfo $hist $phase proftype]]
697	catch {unset oldval}
698	# loop through the old terms and set up an array of starting values
699	set num 0
700	foreach term $oldlbls {
701	incr num
702	set oldval($term) [hapinfo $hist $phase pterm$num]
703	}
704	set oldval(Peak\nCutoff) [hapinfo $hist $phase pcut]
705
706	# is the new type the same as the current?
707	if {$ptype == $newtype} {
708	set nterms [hapinfo $hist $phase profterms]
709	} else {
710	set nterms [llength $lbls]
711	}
712	set expgui(newProfileTerms) $nterms
713	set expgui(CurrentProfileTerms) $nterms
714	# which default profile set matches the new type
715	set setnum {}
716	foreach j {" " 1 2 3 4 5 6 7 8 9} {
717	set i [profdefinfo $hist $j proftype]
718	if {$i == ""} continue
719	if {$i == $newtype} {
720	set setnum $j
721	break
722	}
723	}
724
725	eval destroy [winfo children $w]
726
727	set colstr 0
728	set row 2
729	set maxrow [expr $row + $nterms/2]
730	for { set num 1 } { $num <= $nterms + 1} { incr num } {
731	# get the default value (originally from the in .INS file)
732	set val {}
733	if {$setnum != ""} {
734	set val 0.0
735	catch {
736	set val [profdefinfo $hist $setnum pterm$num]
737	# pretty up the number
738	if {$val == 0.0} {
739	set val 0.0
740	} elseif {abs($val) < 1e-2 \|\| abs($val) > 1e6} {
741	set val [format %.3e $val]
742	} elseif {abs($val) > 1e-2 && abs($val) < 10} {
743	set val [format %.5f $val]
744	} elseif {abs($val) < 9999} {
745	set val [format %.2f $val]
746	} elseif {abs($val) < 1e6} {
747	set val [format %.0f $val]
748	}
749	}
750	}
751	# heading
752	if {$row == 2} {
753	set col $colstr
754	grid [label $w.h0${num} -text "lbl" -bg beige] \
755	-row $row -column $col
756	grid [label $w.h2${num} -text "ref" -bg beige] \
757	-row $row -column [incr col]
758	grid [label $w.h3${num} -text "next value" -bg beige] \
759	-row $row -column [incr col]
760	grid [label $w.h4${num} -text "default" -bg beige] \
761	-row $row -column [incr col]
762	grid [label $w.h5${num} -text "current" -bg beige] \
763	-row $row -column [incr col]
764	}
765	set col $colstr
766	incr row
767	set term {}
768	catch {set term [lindex $lbls [expr $num-1]]}
769	if {$term == ""} {set term $num}
770	if {$num == $nterms + 1} {
771	set term "Peak\nCutoff"
772	set val {}
773	if {$setnum != ""} {
774	set val 0.0
775	catch {set val [profdefinfo $hist $setnum pcut]}
776	}
777	}
778
779	grid [label $w.l${num} -text "$term" -bg beige] \
780	-row $row -column $col
781	grid [checkbutton $w.chk${num} -variable expgui(ProfRef$num) \
782	-bg beige -activebackground beige] -row $row -column [incr col]
783	grid [entry $w.ent${num} \
784	-width 12] -row $row -column [incr col]
785	if {$val != ""} {
786	grid [button $w.def${num} -text $val -command \
787	"$w.ent${num} delete 0 end; $w.ent${num} insert end $val" \
788	] -row $row -column [incr col] -sticky ew
789	} else {
790	grid [label $w.def${num} -text (none) \
791	] -row $row -column [incr col]
792	}
793	set curval {}
794	catch {
795	set curval [expr $oldval($term)]
796	# pretty up the number
797	if {$curval == 0.0} {
798	set curval 0.0
799	} elseif {abs($curval) < 1e-2 \|\| abs($curval) > 1e6} {
800	set curval [format %.3e $curval]
801	} elseif {abs($curval) > 1e-2 && abs($curval) < 10} {
802	set curval [format %.5f $curval]
803	} elseif {abs($curval) < 9999} {
804	set curval [format %.2f $curval]
805	} elseif {abs($curval) < 1e6} {
806	set curval [format %.0f $curval]
807	}
808	grid [button $w.cur${num} -text $curval -command \
809	"$w.ent${num} delete 0 end; $w.ent${num} insert end $curval" \
810	] -row $row -column [incr col] -sticky ew
811	}
812	# set default values for flag and value
813	set ref 0
814	if {$setnum != ""} {
815	catch {
816	if {[profdefinfo $hist $setnum pref$num] == "Y"} {set ref 1}
817	}
818	}
819	set expgui(ProfRef$num) $ref
820
821	$w.ent${num} delete 0 end
822	if {!$expgui(DefaultPeakType) && $val != ""} {
823	$w.ent${num} insert end $val
824	} elseif {$curval != ""} {
825	$w.ent${num} insert end $curval
826	} elseif {$val != ""} {
827	$w.ent${num} insert end $val
828	} else {
829	$w.ent${num} insert end 0.0
830	}
831	if {$row > $maxrow} {
832	set row 2
833	incr colstr 5
834	}
835	}
836	}
837
838	#------------------------------------------------------------------------------
839	# WWW/help routines
840	#------------------------------------------------------------------------------
841	# browse a WWW page with URL. The URL may contain a #anchor
842	# On UNIX assume netscape is in the path or env(BROWSER) is loaded.
843	# On Windows search the registry for a browser. Mac branch not tested.
844	# This is taken from http://mini.net/cgi-bin/wikit/557.html with many thanks
845	# to the contributers
846	proc urlOpen {url} {
847	global env tcl_platform
848	switch $tcl_platform(platform) {
849	"unix" {
850	if {![info exists env(BROWSER)]} {
851	set progs [auto_execok netscape]
852	if {[llength $progs]} {
853	set env(BROWSER) [list $progs]
854	}
855	}
856	if {[info exists env(BROWSER)]} {
857	if {[catch {exec $env(BROWSER) -remote openURL($url)}]} {
858	# perhaps browser doesn't understand -remote flag
859	if {[catch {exec $env(BROWSER) $url &} emsg]} {
860	error "Error displaying $url in browser\n$emsg"
861	}
862	}
863	} else {
864	MyMessageBox -parent . -title "No Browser" \
865	-message "Could not find a browser. Netscape is not in path. Define environment variable BROWSER to be full path name of browser." \
866	-icon warn
867	}
868	}
869	"windows" {
870	package require registry
871	# Look for the application under
872	# HKEY_CLASSES_ROOT
873	set root HKEY_CLASSES_ROOT
874
875	# Get the application key for HTML files
876	set appKey [registry get $root\\.html ""]
877
878	# Get the command for opening HTML files
879	set appCmd [registry get \
880	$root\\$appKey\\shell\\open\\command ""]
881
882	# Substitute the HTML filename into the command for %1
883	# or stick it on the end
884	if {[string first %1 $appCmd] != -1} {
885	regsub %1 $appCmd $url appCmd
886	} else {
887	append appCmd " " $url
888	}
889
890	# Double up the backslashes for eval (below)
891	regsub -all {\\} $appCmd {\\\\} appCmd
892
893	# Invoke the command
894	eval exec $appCmd &
895	}
896	"macintosh" {
897	if {0 == [info exists env(BROWSER)]} {
898	set env(BROWSER) "Browse the Internet"
899	}
900	if {[catch {
901	AppleScript execute\
902	"tell application \"$env(BROWSER)\"
903	open url \"$url\"
904	end tell
905	"} emsg]
906	} then {
907	error "Error displaying $url in browser\n$emsg"
908	}
909	}
910	}
911	}
912
913	proc NetHelp {file anchor localloc netloc} {
914	if {[file exists [file join $localloc $file]]} {
915	set url "[file join $localloc $file]"
916	} else {
917	set url "http://$netloc/$file"
918	}
919	catch {
920	pleasewait "Starting web browser..."
921	after 2000 donewait
922	}
923	if {$anchor != ""} {
924	append url # $anchor
925	}
926	urlOpen $url
927	}
928
929	proc MakeWWWHelp {"topic {}" "anchor {}"} {
930	global expgui
931	if {$topic == ""} {
932	foreach item $expgui(notebookpagelist) {
933	if {[lindex $item 0] == $expgui(pagenow)} {
934	NetHelp [lindex $item 5] [lindex $item 6] $expgui(docdir) $expgui(website)
935	return
936	}
937	}
938	# this should not happen
939	NetHelp expgui.html "" $expgui(docdir) $expgui(website)
940	} elseif {$topic == "menu"} {
941	NetHelp expguic.html "" $expgui(docdir) $expgui(website)
942	} else {
943	NetHelp $topic $anchor $expgui(docdir) $expgui(website)
944	}
945	}
946
947	# show help information
948	proc showhelp {} {
949	global expgui_helplist helpmsg
950	set helpmsg {}
951	set frm .help
952	catch {destroy $frm}
953	toplevel $frm
954	wm title $frm "Help Summary"
955	grid [label $frm.0 -text \
956	"Click on an entry below to see information on the EXPGUI/GSAS topic" ] \
957	-column 0 -columnspan 4 -row 0
958	# grid [message $frm.help -textvariable helpmsg -relief groove] \
959	# -column 0 -columnspan 4 -row 2 -sticky nsew
960	grid [text $frm.help -relief groove -bg beige -width 0\
961	-height 0 -wrap word -yscrollcommand "$frm.escroll set"] \
962	-column 0 -columnspan 3 -row 2 -sticky nsew
963	grid [scrollbar $frm.escroll -command "$frm.help yview"] \
964	-column 4 -row 2 -sticky nsew
965	grid rowconfig $frm 1 -weight 1 -minsize 50
966	grid rowconfig $frm 2 -weight 2 -pad 20 -minsize 150
967	grid columnconfig $frm 0 -weight 1
968	grid columnconfig $frm 2 -weight 1
969	set lst [array names expgui_helplist]
970	grid [listbox $frm.cmds -relief raised -bd 2 \
971	-yscrollcommand "$frm.scroll set" \
972	-height 8 -width 0 -exportselection 0 ] \
973	-column 0 -row 1 -sticky nse
974	grid [scrollbar $frm.scroll -command "$frm.cmds yview"] \
975	-column 1 -row 1 -sticky nsew
976	foreach item [lsort -dictionary $lst] {
977	$frm.cmds insert end $item
978	}
979	if {[$frm.cmds curselection] == ""} {$frm.cmds selection set 0}
980	grid [button $frm.done -text Done -command "destroy $frm"] \
981	-column 2 -row 1
982	# bind $frm.cmds <ButtonRelease-1> \
983	# "+set helpmsg \$expgui_helplist(\[$frm.cmds get \[$frm.cmds curselection\]\])"
984	bind $frm.cmds <ButtonRelease-1> \
985	"+$frm.help config -state normal; $frm.help delete 0.0 end; \
986	$frm.help insert end \$expgui_helplist(\[$frm.cmds get \[$frm.cmds curselection\]\]); \
987	$frm.help config -state disabled"
988
989	# get the size of the window and expand the message boxes to match
990	# update
991	# $frm.help config -width [winfo width $frm.help ]
992	}
993
994
995	#------------------------------------------------------------------------------
996	# utilities
997	#------------------------------------------------------------------------------
998	# run liveplot
999	proc liveplot {} {
1000	global expgui liveplot wishshell expmap
1001	set expnam [file root [file tail $expgui(expfile)]]
1002	# which histograms are ready for use?
1003	set validlist {}
1004	foreach ihist $expmap(powderlist) {
1005	if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" \|\| \
1006	[string range $expmap(htype_$ihist) 3 3] == "D"} {
1007	lappend validlist $ihist
1008	}
1009	}
1010	if {[llength $validlist] == 0} {
1011	MyMessageBox -parent . -title "No Valid Histograms" \
1012	-message "No histograms are ready to plot. Run GENLES and try again" \
1013	-icon warning -helplink "expguierr.html NoValidHist"
1014	return
1015	}
1016	# use $liveplot(hst) if valid, the 1st entry otherwise
1017	if {[lsearch $validlist $liveplot(hst)] != -1} {
1018	exec $wishshell [file join $expgui(scriptdir) liveplot] \
1019	$expnam $liveplot(hst) $liveplot(legend) &
1020	} else {
1021	exec $wishshell [file join $expgui(scriptdir) liveplot] \
1022	$expnam [lindex $validlist 0] $liveplot(legend) &
1023	}
1024	}
1025
1026	# run lstview
1027	proc lstview {} {
1028	global expgui wishshell
1029	set expnam [file root [file tail $expgui(expfile)]]
1030	exec $wishshell [file join $expgui(scriptdir) lstview] $expnam &
1031	}
1032
1033	# run widplt
1034	proc widplt {} {
1035	global expgui wishshell
1036	exec $wishshell [file join $expgui(scriptdir) widplt] \
1037	$expgui(expfile) &
1038	}
1039
1040	# run bkgedit
1041	proc bkgedit {"hst {}"} {
1042	global expgui liveplot wishshell expmap
1043	set expnam [file root [file tail $expgui(expfile)]]
1044	if {$hst == ""} {
1045	# which histograms are ready for use?
1046	set validlist {}
1047	foreach ihist $expmap(powderlist) {
1048	if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" \|\| \
1049	[string range $expmap(htype_$ihist) 3 3] == "*"} {
1050	lappend validlist $ihist
1051	}
1052	}
1053	if {[llength $validlist] == 0} {
1054	MyMessageBox -parent . -title "No Valid Histograms" \
1055	-message "No histograms are ready to plot. Run POWPREF and try again" \
1056	-icon warning -helplink "expguierr.html NoValidHist"
1057	return
1058	}
1059	# use $liveplot(hst) if valid, the 1st entry otherwise
1060	if {[lsearch $validlist $liveplot(hst)] != -1} {
1061	set hst $liveplot(hst)
1062	} else {
1063	set hst [lindex $validlist 0]
1064	}
1065	}
1066	if {$expgui(autoiconify)} {wm iconify .}
1067	exec $wishshell [file join $expgui(scriptdir) bkgedit] \
1068	$expnam $hst $liveplot(legend)
1069	if {$expgui(autoiconify)} {wm deiconify .}
1070	# check for changes in the .EXP file immediately
1071	whenidle
1072	}
1073
1074	# run excledt
1075	proc excledit {} {
1076	global expgui liveplot wishshell expmap
1077	set expnam [file root [file tail $expgui(expfile)]]
1078	# which histograms are ready for use?
1079	set validlist {}
1080	foreach ihist $expmap(powderlist) {
1081	if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" \|\| \
1082	[string range $expmap(htype_$ihist) 3 3] == "*" \|\| \
1083	[string range $expmap(htype_$ihist) 3 3] == "D"} {
1084	lappend validlist $ihist
1085	}
1086	}
1087	if {[llength $validlist] == 0} {
1088	MyMessageBox -parent . -title "No Valid Histograms" \
1089	-message "No histograms are ready to plot. Run POWPREF and try again" \
1090	-icon warning -helplink "expguierr.html NoValidHist"
1091	return
1092	}
1093	if {$expgui(autoiconify)} {wm iconify .}
1094	StartExcl
1095	if {$expgui(autoiconify)} {wm deiconify .}
1096	}
1097
1098	# compute the composition for each phase and display in a dialog
1099	proc composition {} {
1100	global expmap expgui
1101	set Z 1
1102	foreach phase $expmap(phaselist) type $expmap(phasetype) {
1103	if {$type > 2} continue
1104	catch {unset total}
1105	foreach atom $expmap(atomlist_$phase) {
1106	set type [atominfo $phase $atom type]
1107	set mult [atominfo $phase $atom mult]
1108	if [catch {set total($type)}] {
1109	set total($type) [expr \
1110	$mult * [atominfo $phase $atom frac]]
1111	} else {
1112	set total($type) [expr $total($type) + \
1113	$mult * [atominfo $phase $atom frac]]
1114	}
1115	if {$mult > $Z} {set Z $mult}
1116	}
1117	append text "\nPhase $phase\n"
1118	append text " Unit cell contents\n"
1119	foreach type [lsort [array names total]] {
1120	append text " $type[format %8.3f $total($type)]"
1121	}
1122	append text "\n\n"
1123
1124	append text " Asymmetric Unit contents (Z=$Z)\n"
1125	foreach type [lsort [array names total]] {
1126	append text " $type[format %8.3f [expr $total($type)/$Z]]"
1127	}
1128	append text "\n"
1129	}
1130
1131	catch {destroy .comp}
1132	toplevel .comp -class MonoSpc
1133	bind .comp <Key-F1> "MakeWWWHelp expgui.html Composition"
1134	wm title .comp Composition
1135	pack [label .comp.results -text $text \
1136	-justify left] -side top
1137	pack [frame .comp.box] -side top -expand y -fill x
1138	pack [button .comp.box.1 -text Close -command "destroy .comp"] -side left
1139
1140	set lstnam [string toupper [file tail [file rootname $expgui(expfile)].LST]]
1141	pack [button .comp.box.2 -text "Save to $lstnam file" \
1142	-command "writelst [list $text] ; destroy .comp"] -side left
1143	pack [button .comp.box.help -text Help -bg yellow \
1144	-command "MakeWWWHelp expgui.html Composition"] \
1145	-side right
1146	}
1147
1148	# save coordinates in an MSI .xtl file
1149	proc exp2xtl {} {
1150	global expmap expgui
1151	catch {destroy .export}
1152	toplevel .export
1153	wm title .export "Export coordinates"
1154	bind .export <Key-F1> "MakeWWWHelp expgui.html ExportMSI"
1155	pack [label .export.lbl -text "Export coordinates in MSI .xtl format"\
1156	] -side top -anchor center
1157	pack [frame .export.ps] -side top -anchor w
1158	pack [label .export.ps.lbl -text "Select phase: "] -side left
1159	foreach num $expmap(phaselist) type $expmap(phasetype) {
1160	pack [button .export.ps.$num -text $num \
1161	-command "SetExportPhase $num"] -side left
1162	if {$type == 4} {
1163	.export.ps.$num config -state disabled
1164	}
1165	}
1166	pack [frame .export.sg] -side top
1167	pack [label .export.sg.1 -text "Space Group: "] -side left
1168	pack [entry .export.sg.2 -textvariable expgui(export_sg) -width 8] -side left
1169	pack [checkbutton .export.sg.3 -variable expgui(export_orig) -text "Origin 2"] -side left
1170	pack [frame .export.but] -side top -fill x -expand yes
1171	if {[llength $expmap(phaselist)] > 0} {
1172	pack [button .export.but.1 -text Write -command writextl] -side left
1173	SetExportPhase [lindex $expmap(phaselist) 0]
1174	}
1175	pack [button .export.but.2 -text Quit -command "destroy .export"] -side left
1176	pack [button .export.but.help -text Help -bg yellow \
1177	-command "MakeWWWHelp expgui.html ExportMSI"] \
1178	-side right
1179	# force the window to stay on top
1180	putontop .export
1181	afterputontop
1182	}
1183
1184	proc SetExportPhase {phase} {
1185	global expmap expgui
1186	foreach n $expmap(phaselist) type $expmap(phasetype) {
1187	if {$n == $phase && $type != 4} {
1188	.export.ps.$n config -relief sunken
1189	set expgui(export_phase) $phase
1190	# remove spaces from space group
1191	set spacegroup [phaseinfo $phase spacegroup]
1192	if {[string toupper [string range $spacegroup end end]] == "R"} {
1193	set spacegroup [string range $spacegroup 0 \
1194	[expr [string length $spacegroup]-2]]
1195	}
1196	regsub -all " " $spacegroup "" expgui(export_sg)
1197	} else {
1198	.export.ps.$n config -relief raised
1199	}
1200	}
1201	}
1202
1203
1204	proc writextl {} {
1205	global expgui expmap
1206	if ![catch {
1207	set phase $expgui(export_phase)
1208	set origin $expgui(export_orig)
1209	set spsymbol $expgui(export_sg)
1210	} errmsg] {
1211	set errmsg {}
1212	if {$phase == ""} {
1213	set errmsg "Error: invalid phase number $phase"
1214	} elseif {$spsymbol == ""} {
1215	set errmsg "Error: invalid Space Group: $spsymbol"
1216	}
1217	}
1218	if {$errmsg != ""} {
1219	MyMessageBox -parent . -title "Export error" \
1220	-message "Export error: $errmsg" -icon warning
1221	return
1222	}
1223
1224	if [catch {
1225	set filnam [file rootname $expgui(expfile)]_${phase}.xtl
1226	set spacegroup [phaseinfo $phase spacegroup]
1227	set fp [open $filnam w]
1228	puts $fp "TITLE from $expgui(expfile)"
1229	puts $fp "TITLE history [string trim [lindex [exphistory last] 1]]"
1230	puts $fp "TITLE phase [phaseinfo $phase name]"
1231	puts $fp "CELL"
1232	puts $fp " [phaseinfo $phase a] [phaseinfo $phase b] [phaseinfo $phase c] [phaseinfo $phase alpha] [phaseinfo $phase beta] [phaseinfo $phase gamma]"
1233
1234	puts $fp "Symmetry Label $spsymbol"
1235	set rhomb 0
1236	if {[string toupper [string range $spacegroup end end]] == "R"} {
1237	set rhomb 1
1238	}
1239	if $origin {
1240	puts $fp "Symmetry Qualifier origin_2"
1241	}
1242	if $rhomb {
1243	puts $fp "Symmetry Qualifier rhombohedral"
1244	}
1245
1246	puts $fp "ATOMS"
1247	puts $fp "NAME X Y Z UISO OCCUP"
1248	foreach atom $expmap(atomlist_$phase) {
1249	set label [atominfo $phase $atom label]
1250	# remove () characters
1251	regsub -all "\[()\]" $label "" label
1252	# are there anisotropic atoms?
1253	if {[atominfo $phase $atom temptype] == "A"} {
1254	set uiso [expr \
1255	([atominfo $phase $atom U11] + \
1256	[atominfo $phase $atom U22] + \
1257	[atominfo $phase $atom U33]) / 3.]
1258	} else {
1259	set uiso [atominfo $phase $atom Uiso]
1260	}
1261	puts $fp "$label [atominfo $phase $atom x] \
1262	[atominfo $phase $atom y] [atominfo $phase $atom z] \
1263	$uiso [atominfo $phase $atom frac]"
1264	}
1265	} errmsg] {
1266	catch {close $fp}
1267	MyMessageBox -parent . -title "Export error" \
1268	-message "Export error: $errmsg" -icon warning
1269	} else {
1270	catch {close $fp}
1271	MyMessageBox -parent . -title "Done" \
1272	-message "File [file tail $filnam] was written in directory [file dirname $filnam]"
1273	}
1274	if {[llength $expmap(phaselist)] == 1} {destroy .export}
1275	}
1276
1277	# Delete History Records
1278	proc DeleteHistoryRecords {{msg ""}} {
1279	global expgui
1280	set frm .history
1281	catch {destroy $frm}
1282	toplevel $frm
1283	bind $frm <Key-F1> "MakeWWWHelp expgui.html DeleteHistoryRecords"
1284	if {[string trim $msg] == ""} {
1285	set msg "There are [CountHistory] history records"
1286	}
1287	pack [frame $frm.1 -bd 2 -relief groove] -padx 3 -pady 3 -side left
1288	pack [label $frm.1.0 -text $msg] -side top
1289	pack [frame $frm.1.1] -side top
1290	pack [label $frm.1.1.1 -text "Number of entries to keep"] -side left
1291	pack [entry $frm.1.1.2 -width 3 -textvariable expgui(historyKeep)\
1292	] -side left
1293	set expgui(historyKeep) 10
1294	pack [checkbutton $frm.1.2 -text renumber -variable expgui(renumber)] -side top
1295	set expgui(renumber) 1
1296	pack [frame $frm.2] -padx 3 -pady 3 -side left -fill both -expand yes
1297	pack [button $frm.2.help -text Help -bg yellow \
1298	-command "MakeWWWHelp expgui.html DeleteHistoryRecords"] -side top
1299	pack [button $frm.2.4 -text Quit \
1300	-command {destroy .history}] -side bottom
1301	pack [button $frm.2.3 -text OK \
1302	-command {
1303	if ![catch {expr $expgui(historyKeep)}] {
1304	DeleteHistory $expgui(historyKeep) $expgui(renumber)
1305	set expgui(changed) 1
1306	destroy .history
1307	}
1308	}] -side bottom
1309	bind $frm <Return> "$frm.2.3 invoke"
1310
1311	# force the window to stay on top
1312	putontop $frm
1313	focus $frm.2.3
1314	tkwait window $frm
1315	afterputontop
1316	}
1317
1318	proc archiveexp {} {
1319	global expgui tcl_platform
1320	# is there a file to archive?
1321	if {![file exists $expgui(expfile)]} return
1322	set expnam [file rootname $expgui(expfile)]
1323	# get the last archived version
1324	set lastf [lindex [lsort [glob -nocomplain $expnam.{O\[0-9A-F\]\[0-9A-F\]}]] end]
1325	if {$lastf == ""} {
1326	set num 01
1327	} else {
1328	regexp {.*\.O([0-9A-F][0-9A-F])$} $lastf a num
1329	scan $num %x num
1330	if {$num >= 255} {
1331	set num FF
1332	} else {
1333	set num [string toupper [format %.2x [incr num]]]
1334	}
1335	}
1336	catch {
1337	set file $expnam.O$num
1338	file rename -force $expgui(expfile) $file
1339	exec echo "\n----------------------------------------------" >> $expnam.LST
1340	exec echo " Archiving [file tail $expnam.EXP] as [file tail $file]" >> $expnam.LST
1341	exec echo "----------------------------------------------\n" >> $expnam.LST
1342	} errmsg
1343	if {$errmsg != ""} {
1344	tk_dialog .warn Confirm "Error archiving the current .EXP file: $errmsg" warning 0 OK
1345	}
1346	}
1347
1348	# save and optionally archive the expfile
1349	proc savearchiveexp {} {
1350	global expgui expmap
1351	if {$expgui(expfile) == ""} {
1352	SaveAsFile
1353	return
1354	}
1355	if !$expgui(changed) return
1356	if {$expgui(archive)} archiveexp
1357	# add a history record
1358	exphistory add " EXPGUI [lindex $expgui(Revision) 1] [lindex $expmap(Revision) 1] ($expgui(changed) changes) -- [clock format [clock seconds]]"
1359	# now save the file
1360	expwrite $expgui(expfile)
1361	set expgui(changed) 0
1362	set expgui(expModifiedLast) [file mtime $expgui(expfile)]
1363	set expgui(last_History) [string range [string trim [lindex [exphistory last] 1]] 0 50 ]
1364	wm title . $expgui(expfile)
1365	set expgui(titleunchanged) 1
1366	# set convergence criterion
1367	InitLSvars
1368	}
1369
1370	#------------------------------------------------------------------------------
1371	# GSAS interface routines
1372	#------------------------------------------------------------------------------
1373	# run a GSAS program that does not require an experiment file
1374	proc runGSASprog {proglist "concurrent 1"} {
1375	# if concurrent is 0, EXPGUI runs the GSAS program in background
1376	# -- this is not currently needed anywhere where the .EXP file is not.
1377	global expgui tcl_platform
1378	set cmd {}
1379	foreach prog $proglist {
1380	if {$tcl_platform(platform) == "windows"} {
1381	append cmd " \"$expgui(gsasexe)/${prog}.exe \" "
1382	} else {
1383	if {$cmd != ""} {append cmd "\;"}
1384	append cmd "[file join $expgui(gsasexe) $prog]"
1385	}
1386	}
1387	forknewterm $prog $cmd [expr !$concurrent] 1
1388	}
1389
1390	# run a GSAS program that requires an experiment file for input/output
1391	proc runGSASwEXP {proglist "concurrent 0"} {
1392	# most programs that require the .EXP file change it and
1393	# cannot be run concurrently
1394	global expgui tcl_platform
1395	# Save the current exp file
1396	savearchiveexp
1397	# load the changed .EXP file automatically?
1398	if {$expgui(autoexpload)} {
1399	# disable the file changed monitor
1400	set expgui(expModifiedLast) 0
1401	}
1402	set cmd {}
1403	set expnam [file root [file tail $expgui(expfile)]]
1404	foreach prog $proglist {
1405	if {$tcl_platform(platform) == "windows"} {
1406	append cmd " \"$expgui(gsasexe)/${prog}.exe $expnam \" "
1407	} else {
1408	if {$cmd != ""} {append cmd "\;"}
1409	append cmd "[file join $expgui(gsasexe) $prog] $expnam"
1410	}
1411	}
1412	forknewterm "$prog -- $expnam" $cmd [expr !$concurrent] 1
1413	# load the changed .EXP file automatically?
1414	if {$expgui(autoexpload)} {
1415	# load the revised exp file
1416	loadexp $expgui(expfile)
1417	}
1418	}
1419
1420	# write text to the .LST file
1421	proc writelst {text} {
1422	global expgui
1423	set lstnam [file rootname $expgui(expfile)].LST
1424	set fp [open $lstnam a]
1425	puts $fp "\n-----------------------------------------------------------------"
1426	puts $fp $text
1427	puts $fp "-----------------------------------------------------------------\n"
1428	close $fp
1429	}
1430
1431
1432	# optionally run disagl as a windowless process, w/results in a separate window
1433	proc rundisagl {} {
1434	global expgui txtvw tcl_version tcl_platform
1435	if {$expgui(disaglSeparateBox)} {
1436	set root [file root $expgui(expfile)]
1437	catch {file delete -force $root.tmp}
1438	catch {file rename -force $root.LST $root.OLS}
1439	# PSW reports this does not happen right away on windows
1440	set i 0
1441	while {$i < 10 && [file exists $root.LST]} {
1442	# debug code
1443	#catch {console show}
1444	#puts "try $i"
1445	# end debug code
1446	after 100
1447	incr i
1448	}
1449	if {[file exists $root.LST]} {
1450	# it was not possible to rename the file
1451	MyMessageBox -parent . -title "Rename Problem" \
1452	-message "Unable to rename $root.LST. Please close LSTVIEW and try again" \
1453	-icon warning -helplink "expguierr.html NoRename"
1454	return
1455	}
1456
1457	#run the program
1458	pleasewait "Running DISAGL"
1459	# create an empty input file
1460	close [open disagl.inp w]
1461	catch {exec [file join $expgui(gsasexe) disagl] \
1462	[file tail $root] < disagl.inp > disagl.out}
1463	catch {file rename -force $root.LST $root.tmp}
1464	catch {file delete -force disagl.inp disagl.out}
1465	catch {file rename -force $root.OLS $root.LST}
1466	donewait
1467	# open a new window
1468	catch {toplevel .disagl}
1469	catch {eval grid forget [grid slaves .disagl]}
1470	text .disagl.txt -width 100 -wrap none \
1471	-yscrollcommand ".disagl.yscroll set" \
1472	-xscrollcommand ".disagl.xscroll set"
1473	scrollbar .disagl.yscroll -command ".disagl.txt yview"
1474	scrollbar .disagl.xscroll -command ".disagl.txt xview" -orient horizontal
1475	grid .disagl.xscroll -column 0 -row 2 -sticky ew
1476	grid .disagl.txt -column 0 -row 1 -sticky nsew
1477	grid .disagl.yscroll -column 1 -row 1 -sticky ns
1478	grid [frame .disagl.f] -column 0 -columnspan 2 -row 3 -sticky ew
1479	grid columnconfig .disagl.f 2 -weight 1
1480	grid [button .disagl.f.close -text "Close & Delete" \
1481	-command "destroy .disagl; file delete $root.tmp"] \
1482	-column 3 -row 0 -sticky e
1483	grid [button .disagl.f.rename -text "Close & Save as .DIS" \
1484	-command "destroy .disagl; file rename -force $root.tmp $root.DIS"] \
1485	-column 4 -row 0 -sticky e
1486	# allow font changes on the fly
1487	if {$tcl_version >= 8.0} {
1488	.disagl.txt config -font $txtvw(font)
1489	set fontbut [tk_optionMenu .disagl.f.font txtvw(font) ""]
1490	grid .disagl.f.font -column 1 -row 0 -sticky w
1491	grid [label .disagl.f.t -text font:] -column 0 -row 0 -sticky w
1492	$fontbut delete 0 end
1493	foreach f {5 6 7 8 9 10 11 12 13 14 15 16} {
1494	$fontbut add command -label "Courier $f" -font "Courier $f"\
1495	-command "set txtvw(font) \"Courier $f\"; \
1496	.disagl.txt config -font \$txtvw(font)"
1497	}
1498	}
1499
1500	grid columnconfigure .disagl 0 -weight 1
1501	grid rowconfigure .disagl 1 -weight 1
1502	wm title .disagl "DISAGL results $expgui(expfile)"
1503	wm iconname .disagl "DISAGL $root"
1504	set in [open $root.tmp r]
1505	.disagl.txt insert end [read $in]
1506	close $in
1507	bind all {destroy .disagl}
1508	bind .disagl ".disagl.txt yview scroll -1 page"
1509	bind .disagl ".disagl.txt yview scroll 1 page"
1510	bind .disagl ".disagl.txt xview scroll 1 unit"
1511	bind .disagl ".disagl.txt xview scroll -1 unit"
1512	bind .disagl ".disagl.txt yview scroll -1 unit"
1513	bind .disagl ".disagl.txt yview scroll 1 unit"
1514	bind .disagl ".disagl.txt yview 0"
1515	bind .disagl ".disagl.txt yview end"
1516	# don't disable in Win as this prevents the highlighting of selected text
1517	if {$tcl_platform(platform) != "windows"} {
1518	.disagl.txt config -state disabled
1519	}
1520	} else {
1521	runGSASwEXP disagl
1522	}
1523	}
1524
1525	#------------------------------------------------------------------------------
1526	# file conversions
1527	#------------------------------------------------------------------------------
1528	proc convfile {} {
1529	global expgui
1530	set frm .file
1531	catch {destroy $frm}
1532	toplevel $frm
1533	wm title $frm "Convert File"
1534	bind $frm <Key-F1> "MakeWWWHelp expgui.html ConvertWin"
1535	pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1536	pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 \
1537	-side left -fill y -expand yes
1538	pack [button $frmC.help -text Help -bg yellow \
1539	-command "MakeWWWHelp expgui.html ConvertWin"] -side top
1540	pack [button $frmC.q -text Quit -command "destroy $frm"] -side bottom
1541	pack [button $frmC.b -text Convert -command "ValidWinCnv $frm"] \
1542	-side bottom
1543	pack [label $frmA.0 -text "Select a file to convert"] -side top -anchor center
1544	winfilebox $frm
1545	bind $frm <Return> "ValidWinCnv $frm"
1546
1547	# force the window to stay on top
1548	putontop $frm
1549	focus $frmC.q
1550	tkwait window $frm
1551	afterputontop
1552	}
1553
1554	# validate the files and make the conversion
1555	proc ValidWinCnv {frm} {
1556	global expgui
1557	# change backslashes to something sensible
1558	regsub -all {\\} $expgui(FileMenuCnvName) / expgui(FileMenuCnvName)
1559	# allow entry of D: for D:/ and D:TEST for d:/TEST
1560	if {[string first : $expgui(FileMenuCnvName)] != -1 && \
1561	[string first :/ $expgui(FileMenuCnvName)] == -1} {
1562	regsub : $expgui(FileMenuCnvName) :/ expgui(FileMenuCnvName)
1563	}
1564	if {$expgui(FileMenuCnvName) == "<Parent>"} {
1565	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1566	ChooseWinCnv $frm
1567	return
1568	} elseif [file isdirectory \
1569	[file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]] {
1570	if {$expgui(FileMenuCnvName) != "."} {
1571	set expgui(FileMenuDir) \
1572	[file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1573	}
1574	ChooseWinCnv $frm
1575	return
1576	}
1577
1578	set file [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1579	if ![file exists $file] {
1580	MyMessageBox -parent $frm -title "Convert Error" \
1581	-message "File $file does not exist" -icon error
1582	return
1583	}
1584
1585	set tmpname "[file join [file dirname $file] tempfile.xxx]"
1586	set oldname "[file rootname $file].org"
1587	if [file exists $oldname] {
1588	set ans [MyMessageBox -parent . -title "Overwrite?" \
1589	-message "File [file tail $oldname] exists in [file dirname $oldname]. OK to overwrite?" \
1590	-icon warning -type {Overwrite Cancel} -default Overwrite \
1591	-helplink "expguierr.html OverwriteCnv"]
1592	if {[string tolower $ans] == "cancel"} return
1593	catch {file delete $oldname}
1594	}
1595
1596	if [catch {
1597	set in [open $file r]
1598	set out [open $tmpname w]
1599	fconfigure $out -translation crlf
1600	set len [gets $in line]
1601	if {$len > 160} {
1602	# this is a UNIX file. Hope there are no control characters
1603	set i 0
1604	set j 79
1605	while {$j < $len} {
1606	puts $out [string range $line $i $j]
1607	incr i 80
1608	incr j 80
1609	}
1610	} else {
1611	while {$len >= 0} {
1612	append line " "
1613	append line " "
1614	set line [string range $line 0 79]
1615	puts $out $line
1616	set len [gets $in line]
1617	}
1618	}
1619	close $in
1620	close $out
1621	file rename -force $file $oldname
1622	file rename -force $tmpname $file
1623	} errmsg] {
1624	MyMessageBox -parent $frm -title "Conversion error" \
1625	-message "Error in conversion:\n$errmsg" -icon warning
1626	} else {
1627	set ans [MyMessageBox -parent $frm -title "More?" \
1628	-message "File [file tail $file] converted.\n(Original saved as [file tail $oldname]).\n\n Convert more files?" \
1629	-type yesno -default no]
1630	if {$ans == "no"} {destroy $frm}
1631	}
1632	}
1633
1634	# create a file box
1635	proc winfilebox {frm} {
1636	global expgui
1637	set bx $frm.1
1638	pack [frame $bx.top] -side top
1639	pack [label $bx.top.a -text "Directory" ] -side left
1640	set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1641	pack $bx.top.d -side left
1642	set expgui(FileMenuDir) [pwd]
1643	# the icon below is from tk8.0/tkfbox.tcl
1644	set upfolder [image create bitmap -data {
1645	#define updir_width 28
1646	#define updir_height 16
1647	static char updir_bits[] = {
1648	0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1649	0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1650	0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1651	0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1652	0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1653	0xf0, 0xff, 0xff, 0x01};}]
1654
1655	pack [button $bx.top.b -image $upfolder \
1656	-command "updir; ChooseWinCnv $frm" ]
1657	pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1658	listbox $bx.a.files -relief raised -bd 2 \
1659	-yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
1660	-height 15 -width 0 -exportselection 0
1661	listbox $bx.a.dates -relief raised -bd 2 \
1662	-yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
1663	-height 15 -width 0 -takefocus 0 -exportselection 0
1664	scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1665	ChooseWinCnv $frm
1666	bind $bx.a.files <ButtonRelease-1> "ReleaseWinCnv $frm"
1667	bind $bx.a.dates <ButtonRelease-1> "ReleaseWinCnv $frm"
1668	bind $bx.a.files <Double-1> "SelectWinCnv $frm"
1669	bind $bx.a.dates <Double-1> "SelectWinCnv $frm"
1670	pack $bx.a.scroll -side left -fill y
1671	pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1672	pack [entry $bx.c -textvariable expgui(FileMenuCnvName)] -side top
1673	}
1674
1675	# set the box or file in the selection window
1676	proc ReleaseWinCnv {frm} {
1677	global expgui
1678	set files $frm.1.a.files
1679	set dates $frm.1.a.dates
1680	set select [$files curselection]
1681	if {$select == ""} {
1682	set select [$dates curselection]
1683	}
1684	if {$select == ""} {
1685	set expgui(FileMenuCnvName) ""
1686	} else {
1687	set expgui(FileMenuCnvName) [string trim [$files get $select]]
1688	}
1689	if {$expgui(FileMenuCnvName) == "<Parent>"} {
1690	set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
1691	ChooseWinCnv $frm
1692	} elseif [file isdirectory \
1693	[file join [set expgui(FileMenuDir)] $expgui(FileMenuCnvName)]] {
1694	if {$expgui(FileMenuCnvName) != "."} {
1695	set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1696	ChooseWinCnv $frm
1697	}
1698	}
1699	return
1700	}
1701
1702	# select a file or directory -- called on double click
1703	proc SelectWinCnv {frm} {
1704	global expgui
1705	set files $frm.1.a.files
1706	set dates $frm.1.a.dates
1707	set select [$files curselection]
1708	if {$select == ""} {
1709	set select [$dates curselection]
1710	}
1711	if {$select == ""} {
1712	set file .
1713	} else {
1714	set file [string trim [$files get $select]]
1715	}
1716	if {$file == "<Parent>"} {
1717	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1718	ChooseWinCnv $frm
1719	} elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
1720	if {$file != "."} {
1721	set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
1722	ChooseWinCnv $frm
1723	}
1724	} else {
1725	set expgui(FileMenuCnvName) [file tail $file]
1726	ValidWinCnv $frm
1727	}
1728	}
1729
1730	# fill the files & dates & Directory selection box with current directory,
1731	# also called when box is created to fill it
1732	proc ChooseWinCnv {frm} {
1733	global expgui
1734	set files $frm.1.a.files
1735	set dates $frm.1.a.dates
1736	set expgui(FileMenuCnvName) {}
1737	$files delete 0 end
1738	$dates delete 0 end
1739	$files insert end {<Parent>}
1740	$dates insert end {(Directory)}
1741	set filelist [glob -nocomplain \
1742	[file join [set expgui(FileMenuDir)] *] ]
1743	foreach file [lsort -dictionary $filelist] {
1744	if {[file isdirectory $file]} {
1745	$files insert end [file tail $file]
1746	$dates insert end {(Directory)}
1747	}
1748	}
1749	foreach file [lsort -dictionary $filelist] {
1750	if {![file isdirectory $file]} {
1751	set modified [clock format [file mtime $file] -format "%T %D"]
1752	$files insert end [file tail $file]
1753	$dates insert end $modified
1754	}
1755	}
1756	$expgui(FileDirButtonMenu) delete 0 end
1757	set list ""
1758	global tcl_version
1759	if {$tcl_version > 8.0} {
1760	catch {set list [string tolower [file volume]]}
1761	}
1762	set dir ""
1763	foreach subdir [file split [set expgui(FileMenuDir)]] {
1764	set dir [string tolower [file join $dir $subdir]]
1765	if {[lsearch $list $dir] == -1} {lappend list $dir}
1766	}
1767	foreach path $list {
1768	$expgui(FileDirButtonMenu) add command -label $path \
1769	-command "[list set expgui(FileMenuDir) $path]; \
1770	ChooseWinCnv $frm"
1771	}
1772	return
1773	}
1774
1775	#------------------------------------------------------------------------------
1776	# set options for liveplot
1777	proc liveplotopt {} {
1778	global liveplot expmap
1779	set frm .file
1780	catch {destroy $frm}
1781	toplevel $frm
1782	pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1783	set last [lindex [lsort -integer $expmap(powderlist)] end]
1784	if {$last == ""} {set last 1}
1785	pack [scale $frmA.1 -label "Histogram number" -from 1 -to $last \
1786	-length 150 -orient horizontal -variable liveplot(hst)] -side top
1787	pack [checkbutton $frmA.2 -text {include plot legend}\
1788	-variable liveplot(legend)] -side top
1789	pack [button $frm.2 -text OK \
1790	-command {if ![catch {expr $liveplot(hst)}] "destroy .file"} \
1791	] -side top
1792	bind $frm <Return> {if ![catch {expr $liveplot(hst)}] "destroy .file"}
1793
1794	# force the window to stay on top
1795	putontop $frm
1796	focus $frm.2
1797	tkwait window $frm
1798	afterputontop
1799	}
1800
1801	#------------------------------------------------------------------------------
1802	# get an experiment file name
1803	#------------------------------------------------------------------------------
1804	proc getExpFileName {mode} {
1805	global expgui tcl_platform
1806	set frm .file
1807	catch {destroy $frm}
1808	toplevel $frm
1809	wm title $frm "Experiment file"
1810	bind $frm <Key-F1> "MakeWWWHelp expguierr.html open"
1811	pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1812	pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left \
1813	-fill y -expand yes
1814	pack [button $frmC.help -text Help -bg yellow \
1815	-command "MakeWWWHelp expguierr.html open"] \
1816	-side top -anchor e
1817	pack [label $frmC.2 -text "Sort .EXP files by" ] -side top
1818	pack [radiobutton $frmC.1 -text "File Name" -value 1 \
1819	-variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1820	pack [radiobutton $frmC.0 -text "Mod. Date" -value 0 \
1821	-variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1822
1823	set expgui(includearchived) 0
1824	if {$mode == "old"} {
1825	pack [checkbutton $frmC.ar -text "Include Archived Files" \
1826	-variable expgui(includearchived) \
1827	-command "ChooseExpFil $frmA"] -side top -pady 10
1828	}
1829	pack [button $frmC.b -text Read \
1830	-command "valid_exp_file $frmA $mode"] -side bottom
1831	if {$mode == "new"} {
1832	$frmC.b config -text Save
1833	}
1834	pack [button $frmC.q -text Quit \
1835	-command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side bottom
1836	bind $frm <Return> "$frmC.b invoke"
1837
1838	if {$mode == "new"} {
1839	pack [label $frmA.0 -text "Enter an experiment file to create"] \
1840	-side top -anchor center
1841	} else {
1842	pack [label $frmA.0 -text "Select an experiment file to read"] \
1843	-side top -anchor center
1844	}
1845	expfilebox $frmA $mode
1846	# force the window to stay on top
1847	putontop $frm
1848	focus $frmC.b
1849	tkwait window $frm
1850	afterputontop
1851	if {$expgui(FileMenuEXPNAM) == ""} return
1852	return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1853	}
1854
1855	# validation routine
1856	proc valid_exp_file {frm mode} {
1857	global expgui tcl_platform
1858	# windows fixes
1859	if {$tcl_platform(platform) == "windows"} {
1860	# change backslashes to something sensible
1861	regsub -all {\\} $expgui(FileMenuEXPNAM) / expgui(FileMenuEXPNAM)
1862	# allow entry of D: for D:/ and D:TEST for d:/TEST
1863	if {[string first : $expgui(FileMenuEXPNAM)] != -1 && \
1864	[string first :/ $expgui(FileMenuEXPNAM)] == -1} {
1865	regsub : $expgui(FileMenuEXPNAM) :/ expgui(FileMenuEXPNAM)
1866	}
1867	}
1868	if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
1869	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1870	ChooseExpFil $frm
1871	return
1872	} elseif [file isdirectory \
1873	[file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]] {
1874	if {$expgui(FileMenuEXPNAM) != "."} {
1875	set expgui(FileMenuDir) \
1876	[file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1877	}
1878	ChooseExpFil $frm
1879	return
1880	}
1881	# append a .EXP if not present
1882	if {[file extension $expgui(FileMenuEXPNAM)] == ""} {
1883	append expgui(FileMenuEXPNAM) ".EXP"
1884	}
1885	# check for archive files
1886	if {[string match {*.O[0-9A-F][0-9A-F]} $expgui(FileMenuEXPNAM)] && \
1887	$mode == "old" && [file exists $expgui(FileMenuEXPNAM)]} {
1888	destroy .file
1889	return
1890	} elseif {[string toupper [file extension $expgui(FileMenuEXPNAM)]] != ".EXP"} {
1891	# check for files that end in something other than .EXP .exp or .Exp...
1892	MyMessageBox -parent . -title "File Open Error" \
1893	-message "File [file tail $expgui(FileMenuEXPNAM)] is not a valid name. Experiment files must end in \".EXP\"" \
1894	-icon error
1895	return
1896	}
1897	# check on the file status
1898	set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1899	if {$mode == "new" && [file exists $file]} {
1900	set ans [
1901	MyMessageBox -parent . -title "File Open Error" \
1902	-message "File [file tail $file] already exists in [file dirname $file]. OK to overwrite?" \
1903	-icon question -type {"Select other" "Overwrite"} -default "select other" \
1904	-helplink "expguierr.html OverwriteErr"
1905	]
1906	if {[string tolower $ans] == "overwrite"} {destroy .file}
1907	return
1908	}
1909	# if file does not exist in case provided, set the name to all
1910	# upper case letters, since that is the best choice.
1911	# if it does exist, read from it as is. For UNIX we will force uppercase later.
1912	if {![file exists $file]} {
1913	set expgui(FileMenuEXPNAM) [string toupper $expgui(FileMenuEXPNAM)]
1914	set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1915	}
1916	if {$mode == "old" && ![file exists $file]} {
1917	set ans [
1918	MyMessageBox -parent . -title "File Open Error" \
1919	-message "File [file tail $file] does not exist in [file dirname $file]. OK to create?" \
1920	-icon question -type {"Select other" "Create"} -default "select other" \
1921	-helplink "expguierr.html OpenErr"
1922	]
1923	if {[string tolower $ans] == "create"} {destroy .file}
1924	return
1925	}
1926	destroy .file
1927	}
1928
1929	proc updir {} {
1930	global expgui
1931	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)]]
1932	}
1933
1934	# create a file box
1935	proc expfilebox {bx mode} {
1936	global expgui
1937	pack [frame $bx.top] -side top
1938	pack [label $bx.top.a -text "Directory" ] -side left
1939	set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1940	pack $bx.top.d -side left
1941	set expgui(FileMenuDir) [pwd]
1942	# the icon below is from tk8.0/tkfbox.tcl
1943	set upfolder [image create bitmap -data {
1944	#define updir_width 28
1945	#define updir_height 16
1946	static char updir_bits[] = {
1947	0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1948	0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1949	0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1950	0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1951	0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1952	0xf0, 0xff, 0xff, 0x01};}]
1953
1954	pack [button $bx.top.b -image $upfolder \
1955	-command "updir; ChooseExpFil $bx" ]
1956	pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1957	listbox $bx.a.files -relief raised -bd 2 \
1958	-yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
1959	-height 15 -width 0 -exportselection 0
1960	listbox $bx.a.dates -relief raised -bd 2 \
1961	-yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
1962	-height 15 -width 0 -takefocus 0 -exportselection 0
1963	scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1964	ChooseExpFil $bx
1965	bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
1966	bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
1967	bind $bx.a.files <Double-1> "SelectExpFil $bx $mode"
1968	bind $bx.a.dates <Double-1> "SelectExpFil $bx $mode"
1969	pack $bx.a.scroll -side left -fill y
1970	pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1971	pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
1972	}
1973	proc sync2boxesX {master slave scroll args} {
1974	$slave xview moveto [lindex [$master xview] 0]
1975	eval $scroll set $args
1976	}
1977	proc move2boxesX {boxlist args} {
1978	foreach listbox $boxlist {
1979	eval $listbox xview $args
1980	}
1981	}
1982	proc sync2boxesY {master slave scroll args} {
1983	$slave yview moveto [lindex [$master yview] 0]
1984	eval $scroll set $args
1985	}
1986	proc move2boxesY {boxlist args} {
1987	foreach listbox $boxlist {
1988	eval $listbox yview $args
1989	}
1990	}
1991
1992	# creates a table that is scrollable in both x and y, use ResizeScrollTable
1993	# to set sizes after gridding the boxes
1994	proc MakeScrollTable {box} {
1995	grid [label $box.0] -col 0 -row 0
1996	grid [set tbox [canvas $box.top \
1997	-scrollregion {0 0 10 10} \
1998	-xscrollcommand "sync2boxesX $box.top $box.can $box.scroll" \
1999	-width 10 -height 10]] \
2000	-sticky sew -row 0 -column 1
2001	grid [set sbox [canvas $box.side \
2002	-scrollregion {0 0 10 10} \
2003	-yscrollcommand "sync2boxesY $box.side $box.can $box.yscroll" \
2004	-width 10 -height 10]] \
2005	-sticky nes -row 1 -column 0
2006	grid [set bbox [canvas $box.can \
2007	-scrollregion {0 0 10 10} \
2008	-yscrollcommand "sync2boxesY $box.can $box.side $box.yscroll" \
2009	-xscrollcommand "sync2boxesX $box.can $box.top $box.scroll" \
2010	-width 200 -height 200 -bg lightgrey]] \
2011	-sticky news -row 1 -column 1
2012	grid [set sxbox [scrollbar $box.scroll -orient horizontal \
2013	-command "move2boxesX \" $box.can $box.top \" "]] \
2014	-sticky ew -row 2 -column 1
2015	grid [set sybox [scrollbar $box.yscroll \
2016	-command "move2boxesY \" $box.can $box.side \" "]] \
2017	-sticky ns -row 1 -column 2
2018	frame $tbox.f -bd 0
2019	$tbox create window 0 0 -anchor nw -window $tbox.f
2020	frame $bbox.f -bd 2
2021	$bbox create window 0 0 -anchor nw -window $bbox.f
2022	frame $sbox.f -bd 2 -relief raised
2023	$sbox create window 0 0 -anchor nw -window $sbox.f
2024	grid columnconfig $box 1 -weight 1
2025	grid rowconfig $box 1 -weight 1
2026	return [list $tbox.f $bbox.f $sbox.f $box.0]
2027	}
2028
2029	proc ResizeScrollTable {box} {
2030	update idletasks
2031	for {set i 0} {$i < [lindex [grid size $box.can.f] 0]} {incr i} {
2032	set x1 [lindex [grid bbox $box.can.f 0 $i] 2]
2033	set x2 [lindex [grid bbox $box.top.f 0 $i] 2]
2034	if {$x2 > $x1} {set x1 $x2}
2035	grid columnconfigure $box.top.f $i -minsize $x2
2036	grid columnconfigure $box.can.f $i -minsize $x2
2037	}
2038	for {set i 0} {$i < [lindex [grid size $box.can.f] 1]} {incr i} {
2039	set x1 [lindex [grid bbox $box.can.f 0 $i] 3]
2040	set x2 [lindex [grid bbox $box.side.f 0 $i] 3]
2041	if {$x2 > $x1} {set x1 $x2}
2042	grid rowconfigure $box.can.f $i -minsize $x1
2043	grid rowconfigure $box.side.f $i -minsize $x1
2044	}
2045	update idletasks
2046	set sizes [grid bbox $box.can.f]
2047	$box.can config -scrollregion $sizes
2048	$box.side config -scrollregion $sizes
2049	$box.top config -scrollregion $sizes
2050	$box.top config -height [lindex [grid bbox $box.top.f] 3]
2051	$box.side config -width [lindex [grid bbox $box.side.f] 2]
2052	}
2053
2054
2055	# support routine for SetHistUseFlags
2056	proc InitHistUseFlags {} {
2057	global expmap expgui
2058	for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2059	if {[string range $expmap(htype_$i) 0 0] == "P"} {
2060	set expgui(useflag_$i) [histinfo $i use]
2061	}
2062	}
2063	}
2064
2065	# show all Powder histograms; set use/do not use flags
2066	proc SetHistUseFlags {} {
2067	set box .test
2068	catch {toplevel $box}
2069	eval destroy [winfo children $box]
2070	grid [label $box.0 -text "Set histogram \"Use/Do Not Use\" flags" -bg white] -row 0 -column 0 -columnspan 2
2071	grid [frame $box.a] -row 1 -column 0 -columnspan 2
2072	grid [button $box.b -text Save -command "destroy $box"] -row 2 -column 0 -sticky e
2073	grid [button $box.c -text Cancel -command "InitHistUseFlags;destroy $box"] -row 2 -column 1 -sticky w
2074	grid columnconfig $box 0 -weight 1
2075	grid columnconfig $box 1 -weight 1
2076	foreach a [MakeScrollTable $box.a] b {tbox bbox sbox cbox} {set $b $a}
2077	$cbox config -text "Use\nFlag"
2078	[winfo parent $bbox] config -height 250 -width 400
2079	global expmap expgui
2080	set px 5
2081	set row -1
2082	for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2083	if {[string range $expmap(htype_$i) 2 2] == "T"} {
2084	set det [format %8.2f [histinfo $i tofangle]]
2085	} elseif {[string range $expmap(htype_$i) 2 2] == "C"} {
2086	set det [format %8.5f [histinfo $i lam1]]
2087	} elseif {[string range $expmap(htype_$i) 2 2] == "E"} {
2088	set det [format %8.2f [histinfo $i lam1]]
2089	} else {
2090	set det {}
2091	}
2092	incr row
2093	if {[string range $expmap(htype_$i) 0 0] == "P"} {
2094	grid [checkbutton $sbox.$i -text $i -variable expgui(useflag_$i)] -row $row -col 0
2095	set expgui(useflag_$i) [histinfo $i use]
2096	}
2097	grid [label $bbox.0$i \
2098	-text [string range $expmap(htype_$i) 1 3] \
2099	] -row $row -col 0 -padx $px
2100	grid [label $bbox.1$i -text [histinfo $i bank] \
2101	] -row $row -col 1 -padx $px
2102	grid [label $bbox.2$i -text $det] -row $row -col 2 -padx $px
2103	grid [label $bbox.3$i -text [string range [histinfo $i title] 0 66] \
2104	] -row $row -col 3 -padx $px -sticky ew
2105	}
2106	grid [label $tbox.0 -text type -bd 2 -relief raised] -row 0 -col 0 -padx $px
2107	grid [label $tbox.1 -text bank -bd 2 -relief raised] -row 0 -col 1 -padx $px
2108	grid [label $tbox.2 -text "ang/wave" -bd 2 -relief raised] -row 0 -col 2 -padx $px
2109	grid [label $tbox.3 -text "histogram title" -bd 2 -relief raised] -row 0 -col 3 -sticky w -padx $px
2110	ResizeScrollTable $box.a
2111	InitHistUseFlags
2112	putontop $box
2113	tkwait window $box
2114	afterputontop
2115	set prevchages $expgui(changed)
2116	for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2117	if {[string range $expmap(htype_$i) 0 0] == "P"} {
2118	if {$expgui(useflag_$i) != [histinfo $i use]} {
2119	histinfo $i use set $expgui(useflag_$i)
2120	incr expgui(changed)
2121	}
2122	}
2123	}
2124	if {$prevchages != $expgui(changed)} {
2125	set msg "You have changed [expr $expgui(changed)-$prevchages] "
2126	append msg "histogram flag(s). You must run POWPREF "
2127	append msg "to include/remove these histograms. Do you want to "
2128	append msg "run POWPREF?"
2129	set ans [MyMessageBox -parent . -message $msg \
2130	-title "Process changes?"\
2131	-helplink "expguierr.html ProcessUse" \
2132	-default {Run POWPREF} \
2133	-type {{Run POWPREF} Skip}]
2134
2135	if {$ans == "skip"} {
2136	# save and reload the experiment file
2137	savearchiveexp
2138	loadexp $expgui(expfile)
2139	} else {
2140	# run powpref and force a reload
2141	set saveautoload $expgui(autoexpload)
2142	set expgui(autoexpload) 1
2143	runGSASwEXP powpref
2144	set expgui(autoexpload) $saveautoload
2145	}
2146	}
2147	}
2148
2149	# set the box or file in the selection window
2150	proc ReleaseExpFil {frm} {
2151	global expgui
2152	set files $frm.a.files
2153	set dates $frm.a.dates
2154	set select [$files curselection]
2155	if {$select == ""} {
2156	set select [$dates curselection]
2157	}
2158	if {$select == ""} {
2159	set expgui(FileMenuEXPNAM) ""
2160	} else {
2161	set expgui(FileMenuEXPNAM) [string trim [$files get $select]]
2162	}
2163	if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
2164	set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
2165	ChooseExpFil $frm
2166	} elseif [file isdirectory \
2167	[file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]] {
2168	if {$expgui(FileMenuEXPNAM) != "."} {
2169	set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2170	ChooseExpFil $frm
2171	}
2172	}
2173	return
2174	}
2175
2176	# select a file or directory -- called on double click
2177	proc SelectExpFil {frm mode} {
2178	global expgui
2179	set files $frm.a.files
2180	set dates $frm.a.dates
2181	set select [$files curselection]
2182	if {$select == ""} {
2183	set select [$dates curselection]
2184	}
2185	if {$select == ""} {
2186	set file .
2187	} else {
2188	set file [string trim [$files get $select]]
2189	}
2190	if {$file == "<Parent>"} {
2191	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
2192	ChooseExpFil $frm
2193	} elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
2194	if {$file != "."} {
2195	set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
2196	ChooseExpFil $frm
2197	}
2198	} else {
2199	set expgui(FileMenuEXPNAM) [file tail $file]
2200	valid_exp_file $frm $mode
2201	}
2202	}
2203
2204	# fill the files & dates & Directory selection box with current directory,
2205	# also called when box is created to fill it
2206	proc ChooseExpFil {frm} {
2207	global expgui
2208	set files $frm.a.files
2209	set dates $frm.a.dates
2210	set expgui(FileMenuEXPNAM) {}
2211	$files delete 0 end
2212	$dates delete 0 end
2213	$files insert end {<Parent>}
2214	$dates insert end {(Directory)}
2215	set filelist [glob -nocomplain \
2216	[file join [set expgui(FileMenuDir)] *] ]
2217	foreach file [lsort -dictionary $filelist] {
2218	if {[file isdirectory $file]} {
2219	$files insert end [file tail $file]
2220	$dates insert end {(Directory)}
2221	}
2222	}
2223	set pairlist {}
2224	foreach file [lsort -dictionary $filelist] {
2225	if {![file isdirectory $file] && \
2226	[string toupper [file extension $file]] == ".EXP"} {
2227	set modified [file mtime $file]
2228	lappend pairlist [list $file $modified]
2229	} elseif {![file isdirectory $file] && $expgui(includearchived) && \
2230	[string match {*.O[0-9A-F][0-9A-F]} $file]} {
2231	set modified [file mtime $file]
2232	lappend pairlist [list $file $modified]
2233	}
2234	}
2235	if {$expgui(filesort) == 0} {
2236	foreach pair [lsort -index 1 -integer $pairlist] {
2237	set file [lindex $pair 0]
2238	set modified [clock format [lindex $pair 1] -format "%T %D"]
2239	$files insert end [file tail $file]
2240	$dates insert end $modified
2241	}
2242	} else {
2243	foreach pair [lsort -dictionary -index 0 $pairlist] {
2244	set file [lindex $pair 0]
2245	set modified [clock format [lindex $pair 1] -format "%T %D"]
2246	$files insert end [file tail $file]
2247	$dates insert end $modified
2248	}
2249	}
2250	$expgui(FileDirButtonMenu) delete 0 end
2251	set list ""
2252	global tcl_platform tcl_version
2253	if {$tcl_platform(platform) == "windows" && $tcl_version > 8.0} {
2254	catch {set list [string tolower [file volume]]}
2255	}
2256	set dir ""
2257	foreach subdir [file split [set expgui(FileMenuDir)]] {
2258	set dir [file join $dir $subdir]
2259	if {$tcl_platform(platform) == "windows"} {
2260	set dir [string tolower $dir]
2261	if {[lsearch $list $dir] == -1} {lappend list $dir}
2262	} else {
2263	lappend list $dir
2264	}
2265	}
2266	foreach path $list {
2267	$expgui(FileDirButtonMenu) add command -label $path \
2268	-command "[list set expgui(FileMenuDir) $path]; \
2269	ChooseExpFil $frm"
2270	}
2271	# highlight the current experiment -- if present
2272	for {set i 0} {$i < [$files size]} {incr i} {
2273	set file [$files get $i]
2274	if {$expgui(expfile) == [file join $expgui(FileMenuDir) $file]} {
2275	$files selection set $i
2276	}
2277	}
2278	return
2279	}
2280
2281
2282	#------------------------------------------------------------------------------
2283	# platform-specific definitions
2284	if {$tcl_platform(platform) == "windows" && $tcl_platform(os) == "Windows 95"} {
2285	# windows-95, -98 and presumably -me do not allow Tcl/Tk to run the
2286	# DOS box synchronously, so we create a "lock" file that is deleted
2287	# at the end of the DOS run so we can tell when the run is done.
2288	# We create a window to force the deleting of the file so that if
2289	# the DOS process crashes, the user can continue anyway.
2290	#
2291	# procedure to check if the lock file is still there (Win-9x/me only)
2292	proc checklockfile {file window} {
2293	if [file exists $file] {
2294	after 500 checklockfile $file $window
2295	} else {
2296	catch {destroy $window}
2297	}
2298	}
2299	# this creates a DOS box to run a program in
2300	proc forknewterm {title command "wait 1" "scrollbar 1"} {
2301	global env expgui
2302	# Windows environment variables
2303	set env(GSAS) [file nativename $expgui(gsasdir)]
2304	# PGPLOT_FONT is needed by PGPLOT
2305	set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) pgl grfont.dat]]
2306	# this is the number of lines/page in the .LST (etc.) file
2307	set env(LENPAGE) 60
2308	set pwd [file nativename [pwd]]
2309
2310	# check the .EXP path -- can DOS use it?
2311	if {[string first // [pwd]] != -1} {
2312	MyMessageBox -parent . -title "Invalid Path" \
2313	-message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2314	-icon error -type ok -default ok \
2315	-helplink "expgui_Win_readme.html NetPath"
2316	return
2317	}
2318	# pause is hard coded in the .BAT file
2319	#
2320	# loop over multiple commands
2321	foreach cmd $command {
2322	# simulate the wait with a lock file
2323	if {$wait} {
2324	if {$expgui(autoiconify)} {wm iconify .}
2325	# create a blank lock file and a message window
2326	close [open expgui.lck w]
2327	toplevel .lock
2328	grid [button .lock.0 -text Help -bg yellow \
2329	-command "MakeWWWHelp expguierr.html lock"] \
2330	-column 1 -row 0
2331	grid [label .lock.1 \
2332	-text "Please wait while the GSAS program finishes."] \
2333	-column 0 -row 0
2334	grid [label .lock.2 -text \
2335	"In case a problem occurs, close the DOS box"] \
2336	-column 0 -columnspan 2 -row 1
2337	grid [label .lock.3 -text \
2338	"and press the \"Continue\" button (below)"] \
2339	-column 0 -columnspan 2 -row 2
2340	grid [button .lock.b -text "Continue" \
2341	-command "destroy .lock; wm deiconify ."] \
2342	-column 0 -columnspan 2 -row 3
2343	putontop .lock
2344	update
2345	checklockfile expgui.lck .lock
2346	}
2347	# replace the forward slashes with backward
2348	regsub -all / $cmd \\ cmd
2349	winexec -d [file nativename [pwd]] \
2350	[file join $expgui(scriptdir) gsastcl.bat] $cmd
2351	if {$wait} {
2352	tkwait window .lock
2353	file delete -force expgui.lck
2354	}
2355	}
2356	if {$expgui(autoiconify) && $wait} {wm deiconify .}
2357	# check for changes in the .EXP file immediately
2358	whenidle
2359	}
2360	} elseif {$tcl_platform(platform) == "windows"} {
2361	# now for Windows-NT, where we can run synchronously
2362	#
2363	# this creates a DOS box to run a program in
2364	proc forknewterm {title command "wait 1" "scrollbar 1"} {
2365	global env expgui
2366	# Windows environment variables
2367	set env(GSAS) [file nativename $expgui(gsasdir)]
2368	# PGPLOT_FONT is needed by PGPLOT
2369	set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) pgl grfont.dat]]
2370	# this is the number of lines/page in the .LST (etc.) file
2371	set env(LENPAGE) 60
2372	set pwd [file nativename [pwd]]
2373	# check the path -- can DOS use it?
2374	if {[string first // [pwd]] != -1} {
2375	MyMessageBox -parent . -title "Invalid Path" \
2376	-message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2377	-icon error -type ok -default ok \
2378	-helplink "expgui_Win_readme.html NetPath"
2379	return
2380	}
2381	# pause is hard coded in the .BAT file
2382
2383	if {$wait} {
2384	if {$expgui(autoiconify)} {wm iconify .}
2385	# create a blank lock file (keep liveplot from running)
2386	close [open expgui.lck w]
2387	# loop over commands
2388	foreach cmd $command {
2389	# replace the forward slashes with backward
2390	regsub -all / $cmd \\ cmd
2391	exec $env(COMSPEC) /c \
2392	"start [file join $expgui(scriptdir) gsastcl.bat] $cmd"
2393	}
2394	file delete -force expgui.lck
2395	if {$expgui(autoiconify)} {wm deiconify .}
2396	# check for changes in the .EXP file immediately
2397	whenidle
2398	} else {
2399	# loop over commands
2400	foreach cmd $command {
2401	# replace the forward slashes with backward
2402	regsub -all / $cmd \\ cmd
2403	# run in background
2404	exec $env(COMSPEC) /c \
2405	"start [file join $expgui(scriptdir) gsastcl.bat] $cmd" &
2406	}
2407	}
2408	}
2409	} else {
2410	# this creates a xterm window to run a program in
2411	proc forknewterm {title command "wait 1" "scrollbar 1"} {
2412	global env expgui
2413	# UNIX environment variables
2414	set env(GSAS) [file nativename $expgui(gsasdir)]
2415	set env(gsas) [file nativename $expgui(gsasdir)]
2416	set env(GSASEXE) $expgui(gsasexe)
2417	set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
2418	set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
2419	# PGPLOT_DIR is needed by PGPLOT
2420	set env(PGPLOT_DIR) [file join $expgui(gsasdir) pgl]
2421	# this is the number of lines/page in the .LST (etc.) file
2422	set env(LENPAGE) 60
2423	set termopts {}
2424	if $env(GSASBACKSPACE) {
2425	append termopts \
2426	{-xrm "xterm*VT100.Translations: #override\\n <KeyPress>BackSpace: string(\\177)"}
2427	}
2428	if $scrollbar {
2429	append termopts " -sb"
2430	} else {
2431	append termopts " +sb"
2432	}
2433	if {$wait} {
2434	set suffix {}
2435	} else {
2436	set suffix {&}
2437	}
2438	#
2439	#if $wait {
2440	append command "\; echo -n Press Enter to continue \; read x"
2441	#}
2442	if {$wait && $expgui(autoiconify)} {wm iconify .}
2443	catch {eval exec xterm $termopts -title [list $title] \
2444	-e /bin/sh -c [list $command] $suffix} errmsg
2445	if $expgui(debug) {puts "xterm result = $errmsg"}
2446	if {$wait} {
2447	if {$expgui(autoiconify)} {wm deiconify .}
2448	# check for changes in the .EXP file immediately
2449	whenidle
2450	}
2451	}
2452	}

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

Download in other formats: