source: trunk/gsascmds.tcl @ 470

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

# on 2001/10/18 23:30:15, toby did:
fix web page display problem in windows-NT
move EXP archiving here & now use the .O?? files

  • Property rcs:author set to toby
  • Property rcs:date set to 2001/10/18 23:30:15
  • Property rcs:lines set to +62 -9
  • Property rcs:rev set to 1.39
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 81.1 KB
Line 
1# $Id: gsascmds.tcl 470 2009-12-04 23:06:42Z 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#
17proc 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
287proc 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
315proc 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
331proc 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
365proc 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
381proc 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
434proc 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
476array 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
496proc 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
521proc 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/{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
545proc 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#
581proc 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
678proc 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
694proc 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
846proc 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
913proc 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
929proc 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
948proc 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
999proc 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
1027proc 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
1034proc widplt {} {
1035    global expgui wishshell
1036    exec $wishshell [file join $expgui(scriptdir) widplt] \
1037            $expgui(expfile) &
1038}
1039
1040# run bkgedit
1041proc 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
1075proc excledit {"hst {}"} {
1076    global expgui liveplot wishshell expmap
1077    set expnam [file root [file tail $expgui(expfile)]]
1078    if {$hst == ""} {
1079        # which histograms are ready for use?
1080        set validlist {}
1081        foreach ihist $expmap(powderlist) {
1082            if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" || \
1083                    [string range $expmap(htype_$ihist) 3 3] == "*"} {
1084# someday support DUMMY
1085#                   [string range $expmap(htype_$ihist) 3 3] == "D"
1086                lappend validlist $ihist
1087            }
1088        }
1089        if {[llength $validlist] == 0} {
1090            MyMessageBox -parent . -title "No Valid Histograms" \
1091                    -message "No histograms are ready to plot. Run POWPREF and try again" \
1092                    -icon warning -helplink "expguierr.html NoValidHist"
1093            return
1094        }
1095        # use $liveplot(hst) if valid, the 1st entry otherwise
1096        if {[lsearch $validlist $liveplot(hst)] != -1} {
1097            set hst $liveplot(hst)
1098        } else {
1099            set hst [lindex $validlist 0]
1100        }
1101    }
1102    if {$expgui(autoiconify)} {wm iconify .}
1103    exec $wishshell [file join $expgui(scriptdir) excledt] \
1104            $expnam $hst $liveplot(legend)
1105    if {$expgui(autoiconify)} {wm deiconify .}
1106    # check for changes in the .EXP file immediately
1107    whenidle
1108}
1109
1110# compute the composition for each phase and display in a dialog
1111proc composition {} {
1112    global expmap expgui
1113    set Z 1
1114    foreach phase $expmap(phaselist) type $expmap(phasetype) {
1115        if {$type > 2} continue
1116        catch {unset total}
1117        foreach atom $expmap(atomlist_$phase) {
1118            set type [atominfo $phase $atom type]
1119            set mult [atominfo $phase $atom mult]
1120            if [catch {set total($type)}] {
1121                set total($type) [expr \
1122                        $mult * [atominfo $phase $atom frac]]
1123            } else {
1124                set total($type) [expr $total($type) + \
1125                        $mult * [atominfo $phase $atom frac]]
1126            }
1127            if {$mult > $Z} {set Z $mult}
1128        }
1129        append text "\nPhase $phase\n"
1130        append text "  Unit cell contents\n"
1131        foreach type [lsort [array names total]] {
1132            append text "   $type[format %8.3f $total($type)]"
1133        }
1134        append text "\n\n"
1135       
1136        append text "  Asymmetric Unit contents (Z=$Z)\n"
1137        foreach type [lsort [array names total]] {
1138            append text "   $type[format %8.3f [expr $total($type)/$Z]]"
1139        }
1140        append text "\n"
1141    }
1142   
1143    catch {destroy .comp}
1144    toplevel .comp -class MonoSpc
1145    bind .comp <Key-F1> "MakeWWWHelp expgui.html Composition"
1146    wm title .comp Composition
1147    pack [label .comp.results -text $text \
1148            -justify left] -side top
1149    pack [frame .comp.box]  -side top -expand y -fill x
1150    pack [button .comp.box.1 -text Close -command "destroy .comp"] -side left
1151
1152    set lstnam [string toupper [file tail [file rootname $expgui(expfile)].LST]]
1153    pack [button .comp.box.2 -text "Save to $lstnam file" \
1154            -command "writelst [list $text] ; destroy .comp"] -side left
1155    pack [button .comp.box.help -text Help -bg yellow \
1156            -command "MakeWWWHelp expgui.html Composition"] \
1157            -side right
1158}
1159
1160# save coordinates in an MSI .xtl file
1161proc exp2xtl {} {
1162    global expmap expgui
1163    catch {destroy .export}
1164    toplevel .export
1165    wm title .export "Export coordinates"
1166    bind .export <Key-F1> "MakeWWWHelp expgui.html ExportMSI"
1167    pack [label .export.lbl -text "Export coordinates in MSI .xtl format"\
1168            ] -side top -anchor center
1169    pack [frame .export.ps] -side top -anchor w
1170    pack [label .export.ps.lbl -text "Select phase: "] -side left
1171    foreach num $expmap(phaselist) type $expmap(phasetype) {
1172        pack [button .export.ps.$num -text $num \
1173                    -command "SetExportPhase $num"] -side left
1174        if {$type == 4} {
1175            .export.ps.$num config -state disabled
1176        }
1177    }
1178    pack [frame .export.sg] -side top
1179    pack [label .export.sg.1 -text "Space Group: "] -side left
1180    pack [entry .export.sg.2 -textvariable expgui(export_sg) -width 8] -side left
1181    pack [checkbutton .export.sg.3 -variable expgui(export_orig) -text "Origin 2"] -side left
1182    pack [frame .export.but] -side top -fill x -expand yes
1183    if {[llength $expmap(phaselist)] > 0} {
1184        pack [button .export.but.1 -text Write -command writextl] -side left
1185        SetExportPhase [lindex $expmap(phaselist) 0]
1186    }
1187    pack [button .export.but.2 -text Quit -command "destroy .export"] -side left
1188    pack [button .export.but.help -text Help -bg yellow \
1189            -command "MakeWWWHelp expgui.html ExportMSI"] \
1190            -side right
1191    # force the window to stay on top
1192    putontop .export
1193    afterputontop
1194}
1195
1196proc SetExportPhase {phase} {
1197    global expmap expgui
1198    foreach n $expmap(phaselist) type $expmap(phasetype) {
1199        if {$n == $phase && $type != 4} {
1200            .export.ps.$n config -relief sunken
1201            set expgui(export_phase) $phase
1202            # remove spaces from space group
1203            set spacegroup [phaseinfo $phase spacegroup]
1204            if {[string toupper [string range $spacegroup end end]] == "R"} {
1205                set spacegroup [string range $spacegroup 0 \
1206                        [expr [string length $spacegroup]-2]] 
1207            }
1208            regsub -all " " $spacegroup "" expgui(export_sg)   
1209        } else { 
1210            .export.ps.$n config -relief raised
1211        }
1212    }
1213}
1214
1215
1216proc writextl {} {
1217    global expgui expmap
1218    if ![catch {
1219        set phase $expgui(export_phase)
1220        set origin $expgui(export_orig)
1221        set spsymbol $expgui(export_sg)
1222    } errmsg] {
1223        set errmsg {}
1224        if {$phase == ""} {
1225            set errmsg "Error: invalid phase number $phase"
1226        } elseif {$spsymbol == ""} {
1227            set errmsg "Error: invalid Space Group: $spsymbol"
1228        }
1229    }
1230    if {$errmsg != ""} {
1231        MyMessageBox -parent . -title "Export error" \
1232                -message "Export error: $errmsg" -icon warning
1233        return
1234    }
1235
1236    if [catch {
1237        set filnam [file rootname $expgui(expfile)]_${phase}.xtl
1238        set spacegroup [phaseinfo $phase spacegroup]
1239        set fp [open $filnam w]
1240        puts $fp "TITLE from $expgui(expfile)"
1241        puts $fp "TITLE history [string trim [lindex [exphistory last] 1]]"
1242        puts $fp "TITLE phase [phaseinfo $phase name]"
1243        puts $fp "CELL"
1244        puts $fp "  [phaseinfo $phase a] [phaseinfo $phase b] [phaseinfo $phase c] [phaseinfo $phase alpha] [phaseinfo $phase beta] [phaseinfo $phase gamma]"
1245       
1246        puts $fp "Symmetry Label $spsymbol"
1247        set rhomb 0
1248        if {[string toupper [string range $spacegroup end end]] == "R"} {
1249            set rhomb 1
1250        }
1251        if $origin {
1252            puts $fp "Symmetry Qualifier origin_2"
1253        }
1254        if $rhomb {
1255            puts $fp "Symmetry Qualifier rhombohedral"
1256        }
1257       
1258        puts $fp "ATOMS"
1259        puts $fp "NAME       X          Y          Z    UISO      OCCUP"
1260        foreach atom $expmap(atomlist_$phase) {
1261            set label [atominfo $phase $atom label]
1262            # remove () characters
1263            regsub -all "\[()\]" $label "" label
1264            # are there anisotropic atoms?
1265            if {[atominfo $phase $atom temptype] == "A"} {
1266                set uiso [expr \
1267                        ([atominfo $phase $atom U11] + \
1268                        [atominfo $phase $atom U22] + \
1269                        [atominfo $phase $atom U33]) / 3.]
1270            } else {
1271                set uiso [atominfo $phase $atom Uiso]
1272            }
1273            puts $fp "$label [atominfo $phase $atom x] \
1274                        [atominfo $phase $atom y] [atominfo $phase $atom z] \
1275                        $uiso  [atominfo $phase $atom frac]"
1276        }
1277    } errmsg] {
1278        catch {close $fp}
1279        MyMessageBox -parent . -title "Export error" \
1280                -message "Export error: $errmsg" -icon warning
1281    } else {
1282        catch {close $fp}
1283        MyMessageBox -parent . -title "Done" \
1284                -message "File [file tail $filnam] was written in directory [file dirname $filnam]"
1285    }
1286    if {[llength $expmap(phaselist)] == 1} {destroy .export}
1287}
1288
1289# Delete History Records
1290proc DeleteHistoryRecords {{msg ""}} {
1291    global expgui
1292    set frm .history
1293    catch {destroy $frm}
1294    toplevel $frm
1295    bind $frm <Key-F1> "MakeWWWHelp expgui.html DeleteHistoryRecords"
1296    if {[string trim $msg] == ""} {
1297        set msg "There are [CountHistory] history records"
1298    }
1299    pack [frame $frm.1 -bd 2 -relief groove] -padx 3 -pady 3 -side left
1300    pack [label $frm.1.0 -text $msg] -side top
1301    pack [frame $frm.1.1] -side top
1302    pack [label $frm.1.1.1 -text "Number of entries to keep"] -side left
1303    pack [entry $frm.1.1.2 -width 3 -textvariable expgui(historyKeep)\
1304            ] -side left
1305    set expgui(historyKeep) 10
1306    pack [checkbutton $frm.1.2 -text renumber -variable expgui(renumber)] -side top
1307    set expgui(renumber) 1
1308    pack [frame $frm.2] -padx 3 -pady 3 -side left -fill both -expand yes
1309    pack [button $frm.2.help -text Help -bg yellow \
1310            -command "MakeWWWHelp expgui.html DeleteHistoryRecords"] -side top
1311    pack [button $frm.2.4 -text Quit \
1312            -command {destroy .history}] -side bottom
1313    pack [button $frm.2.3 -text OK \
1314            -command { 
1315        if ![catch {expr $expgui(historyKeep)}] {
1316            DeleteHistory $expgui(historyKeep) $expgui(renumber)
1317            set expgui(changed) 1
1318            destroy .history
1319        }
1320    }] -side bottom
1321    bind $frm <Return> "$frm.2.3 invoke"
1322   
1323    # force the window to stay on top
1324    putontop $frm 
1325    focus $frm.2.3
1326    tkwait window $frm
1327    afterputontop
1328}
1329
1330proc archiveexp {} {
1331    global expgui tcl_platform
1332    # is there a file to archive?
1333    if {![file exists $expgui(expfile)]} return
1334    set expnam [file rootname $expgui(expfile)]
1335    # get the last archived version
1336    set lastf [lindex [lsort [glob $expnam.{O\[0-9A-F\]\[0-9A-F\]}]] end]
1337    if {$lastf == ""} {
1338        set num 01
1339    } else {
1340        regexp {.*\.O([0-9A-F][0-9A-F])$} $lastf a num
1341        scan $num %x num
1342        if {$num >= 255} {
1343            set num FF
1344        } else {
1345            set num [string toupper [format %.2x [incr num]]]
1346        }
1347    }
1348    catch {
1349        set file $expnam.O$num
1350        file rename -force $expgui(expfile) $file
1351        exec echo "\n----------------------------------------------" >> $expnam.LST
1352        exec echo "     Archiving [file tail $expnam.EXP] as [file tail $file]" >> $expnam.LST
1353        exec echo "----------------------------------------------\n" >> $expnam.LST
1354    } errmsg
1355    if {$errmsg != ""} {
1356        tk_dialog .warn Confirm "Error archiving the current .EXP file: $errmsg" warning 0 OK
1357    }
1358}
1359
1360# save and optionally archive the expfile
1361proc savearchiveexp {} {
1362    global expgui expmap
1363    if {$expgui(expfile) == ""} {
1364        SaveAsFile
1365        return
1366    }
1367    if !$expgui(changed) return
1368    if {$expgui(archive)} archiveexp
1369    # add a history record
1370    exphistory add " EXPGUI [lindex $expgui(Revision) 1] [lindex $expmap(Revision) 1] ($expgui(changed) changes) -- [clock format [clock seconds]]"
1371    # now save the file
1372    expwrite $expgui(expfile)
1373    set expgui(changed) 0
1374    set expgui(expModifiedLast) [file mtime $expgui(expfile)]
1375    set expgui(last_History) [string range [string trim [lindex [exphistory last] 1]] 0 50 ]
1376    wm title . $expgui(expfile)
1377    set expgui(titleunchanged) 1
1378    # set convergence criterion
1379    InitLSvars
1380}
1381
1382#------------------------------------------------------------------------------
1383# GSAS interface routines
1384#------------------------------------------------------------------------------
1385# run a GSAS program that does not require an experiment file
1386proc runGSASprog {proglist "concurrent 1"} {
1387    # if concurrent is 0, EXPGUI runs the GSAS program in background
1388    # -- this is not currently needed anywhere where the .EXP file is not.
1389    global expgui tcl_platform
1390    set cmd {}
1391    foreach prog $proglist {
1392        if {$tcl_platform(platform) == "windows"} {
1393            append cmd " \"$expgui(gsasexe)/${prog}.exe \" "
1394        } else {
1395            if {$cmd != ""} {append cmd "\;"}
1396            append cmd "[file join $expgui(gsasexe) $prog]"
1397        }
1398    }
1399    forknewterm $prog $cmd [expr !$concurrent] 1
1400}
1401
1402# run a GSAS program that requires an experiment file for input/output
1403proc runGSASwEXP {proglist "concurrent 0"} {
1404    # most programs that require the .EXP file change it and
1405    # cannot be run concurrently
1406    global expgui tcl_platform
1407    # Save the current exp file
1408    savearchiveexp
1409    # load the changed .EXP file automatically?
1410    if {$expgui(autoexpload)} {
1411        # disable the file changed monitor
1412        set expgui(expModifiedLast) 0
1413    }
1414    set cmd {}
1415    set expnam [file root [file tail $expgui(expfile)]]
1416    foreach prog $proglist {
1417        if {$tcl_platform(platform) == "windows"} {
1418            append cmd " \"$expgui(gsasexe)/${prog}.exe $expnam \" "
1419        } else {
1420            if {$cmd != ""} {append cmd "\;"}
1421            append cmd "[file join $expgui(gsasexe) $prog] $expnam"
1422        }
1423    }
1424    forknewterm "$prog -- $expnam" $cmd [expr !$concurrent] 1
1425    # load the changed .EXP file automatically?
1426    if {$expgui(autoexpload)} {
1427        # load the revised exp file
1428        loadexp $expgui(expfile)
1429    }
1430}
1431
1432# write text to the .LST file
1433proc writelst {text} {
1434    global expgui
1435    set lstnam [file rootname $expgui(expfile)].LST
1436    set fp [open $lstnam a]
1437    puts $fp "\n-----------------------------------------------------------------"
1438    puts $fp $text
1439    puts $fp "-----------------------------------------------------------------\n"
1440    close $fp
1441}
1442
1443
1444# optionally run disagl as a windowless process, w/results in a separate window
1445proc rundisagl {} {
1446    global expgui txtvw tcl_version tcl_platform
1447    if {$expgui(disaglSeparateBox)} {
1448        set root [file root $expgui(expfile)] 
1449        catch {file delete -force $root.tmp}
1450        catch {file rename -force $root.LST $root.OLS}
1451        # PSW reports this does not happen right away on windows
1452        set i 0
1453        while {$i < 10 && [file exists $root.LST]} {
1454            # debug code
1455            #catch {console show}
1456            #puts "try $i"
1457            # end debug code
1458            after 100
1459            incr i
1460        }
1461        if {[file exists $root.LST]} {
1462            # it was not possible to rename the file
1463            MyMessageBox -parent . -title "Rename Problem" \
1464                -message "Unable to rename $root.LST. Please close LSTVIEW and try again" \
1465                -icon warning -helplink "expguierr.html NoRename"
1466            return
1467        }
1468
1469        #run the program
1470        pleasewait "Running DISAGL"     
1471        # create an empty input file
1472        close [open disagl.inp w]
1473        catch {exec [file join $expgui(gsasexe) disagl] \
1474                [file tail $root] < disagl.inp > disagl.out}
1475        catch {file rename -force $root.LST $root.tmp}
1476        catch {file delete -force disagl.inp disagl.out}
1477        catch {file rename -force $root.OLS $root.LST}
1478        donewait
1479        # open a new window
1480        catch {toplevel .disagl}
1481        catch {eval grid forget [grid slaves .disagl]}
1482        text .disagl.txt -width 100 -wrap none \
1483                -yscrollcommand ".disagl.yscroll set" \
1484                -xscrollcommand ".disagl.xscroll set" 
1485        scrollbar .disagl.yscroll -command ".disagl.txt yview"
1486        scrollbar .disagl.xscroll -command ".disagl.txt xview" -orient horizontal
1487        grid .disagl.xscroll -column 0 -row 2 -sticky ew
1488        grid .disagl.txt -column 0 -row 1 -sticky nsew
1489        grid .disagl.yscroll -column 1 -row 1 -sticky ns
1490        grid [frame .disagl.f] -column 0 -columnspan 2 -row 3 -sticky ew
1491        grid columnconfig .disagl.f 2 -weight 1
1492        grid [button .disagl.f.close -text "Close & Delete" \
1493                -command "destroy .disagl; file delete $root.tmp"] \
1494                -column 3 -row 0 -sticky e
1495        grid [button .disagl.f.rename -text "Close & Save as .DIS" \
1496                -command "destroy .disagl; file rename -force $root.tmp $root.DIS"] \
1497                -column 4 -row 0 -sticky e
1498        # allow font changes on the fly
1499        if {$tcl_version >= 8.0} {
1500            .disagl.txt config -font $txtvw(font)
1501            set fontbut [tk_optionMenu .disagl.f.font txtvw(font) ""]
1502            grid .disagl.f.font -column 1 -row 0 -sticky w
1503            grid [label .disagl.f.t -text font:] -column 0 -row 0 -sticky w
1504            $fontbut delete 0 end
1505            foreach f {5 6 7 8 9 10 11 12 13 14 15 16} {
1506                $fontbut add command -label "Courier $f" -font "Courier $f"\
1507                        -command "set txtvw(font) \"Courier $f\"; \
1508                        .disagl.txt config -font \$txtvw(font)"
1509            }
1510        }
1511       
1512        grid columnconfigure .disagl 0 -weight 1
1513        grid rowconfigure .disagl 1 -weight 1
1514        wm title .disagl "DISAGL results $expgui(expfile)"
1515        wm iconname .disagl "DISAGL $root"
1516        set in [open $root.tmp r]
1517        .disagl.txt insert end [read $in]
1518        close $in
1519        bind all  {destroy .disagl}
1520        bind .disagl  ".disagl.txt yview scroll -1 page"
1521        bind .disagl  ".disagl.txt yview scroll 1 page"
1522        bind .disagl  ".disagl.txt xview scroll 1 unit"
1523        bind .disagl  ".disagl.txt xview scroll -1 unit"
1524        bind .disagl  ".disagl.txt yview scroll -1 unit"
1525        bind .disagl  ".disagl.txt yview scroll 1 unit"
1526        bind .disagl  ".disagl.txt yview 0"
1527        bind .disagl  ".disagl.txt yview end"
1528        # don't disable in Win as this prevents the highlighting of selected text
1529        if {$tcl_platform(platform) != "windows"} {
1530            .disagl.txt config -state disabled
1531        }
1532    } else {
1533        runGSASwEXP disagl
1534    }
1535}
1536
1537#------------------------------------------------------------------------------
1538# file conversions
1539#------------------------------------------------------------------------------
1540proc convfile {} {
1541    global expgui
1542    set frm .file
1543    catch {destroy $frm}
1544    toplevel $frm
1545    wm title $frm "Convert File"
1546    bind $frm <Key-F1> "MakeWWWHelp expgui.html ConvertWin"
1547    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1548    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 \
1549            -side left -fill y -expand yes
1550    pack [button $frmC.help -text Help -bg yellow \
1551            -command "MakeWWWHelp expgui.html ConvertWin"] -side top
1552    pack [button $frmC.q -text Quit -command "destroy $frm"] -side bottom
1553    pack [button $frmC.b -text Convert -command "ValidWinCnv $frm"] \
1554            -side bottom
1555    pack [label $frmA.0 -text "Select a file to convert"] -side top -anchor center
1556    winfilebox $frm
1557    bind $frm <Return> "ValidWinCnv $frm"
1558
1559    # force the window to stay on top
1560    putontop $frm
1561    focus $frmC.q 
1562    tkwait window $frm
1563    afterputontop
1564}
1565
1566# validate the files and make the conversion
1567proc ValidWinCnv {frm} {
1568    global expgui
1569    # change backslashes to something sensible
1570    regsub -all {\\} $expgui(FileMenuCnvName) / expgui(FileMenuCnvName)
1571    # allow entry of D: for D:/ and D:TEST for d:/TEST
1572    if {[string first : $expgui(FileMenuCnvName)] != -1 && \
1573            [string first :/ $expgui(FileMenuCnvName)] == -1} {
1574        regsub : $expgui(FileMenuCnvName) :/ expgui(FileMenuCnvName)
1575    }
1576    if {$expgui(FileMenuCnvName) == "<Parent>"} {
1577        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1578        ChooseWinCnv $frm
1579        return
1580    } elseif [file isdirectory \
1581            [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]] {
1582        if {$expgui(FileMenuCnvName) != "."} {
1583            set expgui(FileMenuDir) \
1584                [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1585        }
1586        ChooseWinCnv $frm
1587        return
1588    }
1589 
1590    set file [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1591    if ![file exists $file] {
1592        MyMessageBox -parent $frm -title "Convert Error" \
1593                -message "File $file does not exist" -icon error
1594        return
1595    }
1596
1597    set tmpname "[file join [file dirname $file] tempfile.xxx]"
1598    set oldname "[file rootname $file].org"
1599    if [file exists $oldname] {
1600        set ans [MyMessageBox -parent . -title "Overwrite?" \
1601                -message "File [file tail $oldname] exists in [file dirname $oldname]. OK to overwrite?" \
1602                -icon warning -type {Overwrite Cancel} -default Overwrite \
1603                -helplink "expguierr.html OverwriteCnv"]
1604        if {[string tolower $ans] == "cancel"} return
1605        catch {file delete $oldname}
1606    }
1607
1608    if [catch {
1609        set in [open $file r]
1610        set out [open $tmpname w]
1611        fconfigure $out -translation crlf
1612        set len [gets $in line]
1613        if {$len > 160} {
1614            # this is a UNIX file. Hope there are no control characters
1615            set i 0
1616            set j 79
1617            while {$j < $len} {
1618                puts $out [string range $line $i $j]
1619                incr i 80
1620                incr j 80
1621            }
1622        } else {
1623            while {$len >= 0} {
1624                append line "                                        "
1625                append line "                                        "
1626                set line [string range $line 0 79]
1627                puts $out $line
1628                set len [gets $in line]
1629            }
1630        }
1631        close $in
1632        close $out
1633        file rename -force $file $oldname
1634        file rename -force $tmpname $file
1635    } errmsg] {
1636        MyMessageBox -parent $frm -title "Conversion error" \
1637                -message "Error in conversion:\n$errmsg" -icon warning
1638    } else {
1639        set ans [MyMessageBox -parent $frm -title "More?" \
1640                -message "File [file tail $file] converted.\n(Original saved as [file tail $oldname]).\n\n Convert more files?" \
1641                -type yesno -default no]
1642        if {$ans == "no"} {destroy $frm}
1643    }
1644}
1645
1646# create a file box
1647proc winfilebox {frm} {
1648    global expgui
1649    set bx $frm.1
1650    pack [frame $bx.top] -side top
1651    pack [label $bx.top.a -text "Directory" ] -side left
1652    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1653    pack $bx.top.d -side left
1654    set expgui(FileMenuDir) [pwd]
1655    # the icon below is from tk8.0/tkfbox.tcl
1656    set upfolder [image create bitmap -data {
1657#define updir_width 28
1658#define updir_height 16
1659static char updir_bits[] = {
1660   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1661   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1662   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1663   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1664   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1665   0xf0, 0xff, 0xff, 0x01};}]
1666
1667    pack [button $bx.top.b -image $upfolder \
1668            -command "updir; ChooseWinCnv $frm" ]
1669    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1670    listbox $bx.a.files -relief raised -bd 2 \
1671            -yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
1672            -height 15 -width 0 -exportselection 0 
1673    listbox $bx.a.dates -relief raised -bd 2 \
1674            -yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
1675            -height 15 -width 0 -takefocus 0 -exportselection 0 
1676    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1677    ChooseWinCnv $frm
1678    bind $bx.a.files <ButtonRelease-1> "ReleaseWinCnv $frm"
1679    bind $bx.a.dates <ButtonRelease-1> "ReleaseWinCnv $frm"
1680    bind $bx.a.files <Double-1> "SelectWinCnv $frm"
1681    bind $bx.a.dates <Double-1> "SelectWinCnv $frm"
1682    pack $bx.a.scroll -side left -fill y
1683    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1684    pack [entry $bx.c -textvariable expgui(FileMenuCnvName)] -side top
1685}
1686
1687# set the box or file in the selection window
1688proc ReleaseWinCnv {frm} {
1689    global expgui
1690    set files $frm.1.a.files
1691    set dates $frm.1.a.dates
1692    set select [$files curselection]
1693    if {$select == ""} {
1694        set select [$dates curselection]
1695    }
1696    if {$select == ""} {
1697        set expgui(FileMenuCnvName) ""
1698    } else {
1699        set expgui(FileMenuCnvName) [string trim [$files get $select]]
1700    }
1701    if {$expgui(FileMenuCnvName) == "<Parent>"} {
1702        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
1703        ChooseWinCnv $frm
1704    } elseif [file isdirectory \
1705            [file join [set expgui(FileMenuDir)] $expgui(FileMenuCnvName)]] {
1706        if {$expgui(FileMenuCnvName) != "."} {
1707            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1708            ChooseWinCnv $frm
1709        }
1710    }
1711    return
1712}
1713
1714# select a file or directory -- called on double click
1715proc SelectWinCnv {frm} {
1716    global expgui
1717    set files $frm.1.a.files
1718    set dates $frm.1.a.dates
1719    set select [$files curselection]
1720    if {$select == ""} {
1721        set select [$dates curselection]
1722    }
1723    if {$select == ""} {
1724        set file .
1725    } else {
1726        set file [string trim [$files get $select]]
1727    }
1728    if {$file == "<Parent>"} {
1729        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1730        ChooseWinCnv $frm
1731    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
1732        if {$file != "."} {
1733            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
1734            ChooseWinCnv $frm
1735        }
1736    } else {
1737        set expgui(FileMenuCnvName) [file tail $file]
1738        ValidWinCnv $frm
1739    }
1740}
1741
1742# fill the files & dates & Directory selection box with current directory,
1743# also called when box is created to fill it
1744proc ChooseWinCnv {frm} {
1745    global expgui
1746    set files $frm.1.a.files
1747    set dates $frm.1.a.dates
1748    set expgui(FileMenuCnvName) {}
1749    $files delete 0 end
1750    $dates delete 0 end
1751    $files insert end {<Parent>}
1752    $dates insert end {(Directory)}
1753    set filelist [glob -nocomplain \
1754            [file join [set expgui(FileMenuDir)] *] ]
1755    foreach file [lsort -dictionary $filelist] {
1756        if {[file isdirectory $file]} {
1757            $files insert end [file tail $file]
1758            $dates insert end {(Directory)}
1759        }
1760    }
1761    foreach file [lsort -dictionary $filelist] {
1762        if {![file isdirectory $file]} {
1763            set modified [clock format [file mtime $file] -format "%T %D"]
1764            $files insert end [file tail $file]
1765            $dates insert end $modified
1766        }
1767    }
1768    $expgui(FileDirButtonMenu)  delete 0 end
1769    set list ""
1770    global tcl_version
1771    if {$tcl_version > 8.0} {
1772        catch {set list [string tolower [file volume]]}
1773    }
1774    set dir ""
1775    foreach subdir [file split [set expgui(FileMenuDir)]] {
1776        set dir [string tolower [file join $dir $subdir]]
1777        if {[lsearch $list $dir] == -1} {lappend list $dir}
1778    }
1779    foreach path $list {
1780        $expgui(FileDirButtonMenu) add command -label $path \
1781                -command "[list set expgui(FileMenuDir) $path]; \
1782                ChooseWinCnv $frm"
1783    }
1784    return
1785}
1786
1787#------------------------------------------------------------------------------
1788# set options for liveplot
1789proc liveplotopt {} {
1790    global liveplot expmap
1791    set frm .file
1792    catch {destroy $frm}
1793    toplevel $frm
1794    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1795    set last [lindex [lsort -integer $expmap(powderlist)] end]
1796    if {$last == ""} {set last 1}
1797    pack [scale  $frmA.1 -label "Histogram number" -from 1 -to $last \
1798            -length  150 -orient horizontal -variable liveplot(hst)] -side top
1799    pack [checkbutton $frmA.2 -text {include plot legend}\
1800            -variable liveplot(legend)] -side top
1801    pack [button $frm.2 -text OK \
1802            -command {if ![catch {expr $liveplot(hst)}] "destroy .file"} \
1803            ] -side top
1804    bind $frm <Return> {if ![catch {expr $liveplot(hst)}] "destroy .file"}
1805   
1806    # force the window to stay on top
1807    putontop $frm 
1808    focus $frm.2
1809    tkwait window $frm
1810    afterputontop
1811}
1812
1813#------------------------------------------------------------------------------
1814# get an experiment file name
1815#------------------------------------------------------------------------------
1816proc getExpFileName {mode} {
1817    global expgui tcl_platform
1818    set frm .file
1819    catch {destroy $frm}
1820    toplevel $frm
1821    wm title $frm "Experiment file"
1822    bind $frm <Key-F1> "MakeWWWHelp expguierr.html open"
1823    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1824    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left \
1825            -fill y -expand yes
1826    pack [button $frmC.help -text Help -bg yellow \
1827            -command "MakeWWWHelp expguierr.html open"] \
1828            -side top -anchor e
1829    pack [label $frmC.2 -text "Sort .EXP files by" ] -side top
1830    pack [radiobutton $frmC.1 -text "File Name" -value 1 \
1831            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1832    pack [radiobutton $frmC.0 -text "Mod. Date" -value 0 \
1833            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1834
1835    set expgui(includearchived) 0
1836    if {$mode == "old"} {
1837        pack [checkbutton $frmC.ar -text "Include Archived Files" \
1838                -variable expgui(includearchived) \
1839                -command "ChooseExpFil $frmA"] -side top -pady 10
1840    }
1841    pack [button $frmC.b -text Read \
1842            -command "valid_exp_file $frmA $mode"] -side bottom
1843    if {$mode == "new"} {
1844        $frmC.b config -text Save
1845    }
1846    pack [button $frmC.q -text Quit \
1847            -command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side bottom
1848    bind $frm <Return> "$frmC.b invoke"
1849
1850    if {$mode == "new"} {
1851        pack [label $frmA.0 -text "Enter an experiment file to create"] \
1852                -side top -anchor center
1853    } else {
1854        pack [label $frmA.0 -text "Select an experiment file to read"] \
1855                -side top -anchor center
1856    }
1857    expfilebox $frmA $mode
1858    # force the window to stay on top
1859    putontop $frm
1860    focus $frmC.b
1861    tkwait window $frm
1862    afterputontop
1863    if {$expgui(FileMenuEXPNAM) == ""} return
1864    return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1865}
1866
1867# validation routine
1868proc valid_exp_file {frm mode} {
1869    global expgui tcl_platform
1870    # windows fixes
1871    if {$tcl_platform(platform) == "windows"} {
1872        # change backslashes to something sensible
1873        regsub -all {\\} $expgui(FileMenuEXPNAM) / expgui(FileMenuEXPNAM)
1874        # allow entry of D: for D:/ and D:TEST for d:/TEST
1875        if {[string first : $expgui(FileMenuEXPNAM)] != -1 && \
1876                [string first :/ $expgui(FileMenuEXPNAM)] == -1} {
1877            regsub : $expgui(FileMenuEXPNAM) :/ expgui(FileMenuEXPNAM)
1878        }
1879    }
1880    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
1881        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1882        ChooseExpFil $frm
1883        return
1884    } elseif [file isdirectory \
1885            [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]] {
1886        if {$expgui(FileMenuEXPNAM) != "."} {
1887            set expgui(FileMenuDir) \
1888                [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1889        }
1890        ChooseExpFil $frm
1891        return
1892    }
1893    # append a .EXP if not present
1894    if {[file extension $expgui(FileMenuEXPNAM)] == ""} {
1895        append expgui(FileMenuEXPNAM) ".EXP"
1896    }
1897    # check for archive files
1898    if {[string match {*.O[0-9A-F][0-9A-F]} $expgui(FileMenuEXPNAM)] && \
1899            $mode == "old" && [file exists $expgui(FileMenuEXPNAM)]} {
1900        destroy .file
1901        return
1902    } elseif {[string toupper [file extension $expgui(FileMenuEXPNAM)]] != ".EXP"} {
1903        # check for files that end in something other than .EXP .exp or .Exp...
1904        MyMessageBox -parent . -title "File Open Error" \
1905                -message "File [file tail $expgui(FileMenuEXPNAM)] is not a valid name. Experiment files must end in \".EXP\"" \
1906                -icon error
1907        return
1908    }
1909    # check on the file status
1910    set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1911    if {$mode == "new" && [file exists $file]} {
1912        set ans [
1913        MyMessageBox -parent . -title "File Open Error" \
1914                -message "File [file tail $file] already exists in [file dirname $file]. OK to overwrite?" \
1915                -icon question -type {"Select other" "Overwrite"} -default "select other" \
1916                -helplink "expguierr.html OverwriteErr"
1917        ]
1918        if {[string tolower $ans] == "overwrite"} {destroy .file}
1919        return
1920    }
1921    # if file does not exist in case provided, set the name to all
1922    # upper case letters, since that is the best choice.
1923    # if it does exist, read from it as is. For UNIX we will force uppercase later.
1924    if {![file exists $file]} {
1925        set expgui(FileMenuEXPNAM) [string toupper $expgui(FileMenuEXPNAM)]
1926        set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1927    }
1928    if {$mode == "old" && ![file exists $file]} {
1929        set ans [
1930        MyMessageBox -parent . -title "File Open Error" \
1931                -message "File [file tail $file] does not exist in [file dirname $file]. OK to create?" \
1932                -icon question -type {"Select other" "Create"} -default "select other" \
1933                -helplink "expguierr.html OpenErr"
1934        ]
1935        if {[string tolower $ans] == "create"} {destroy .file}
1936        return
1937    }
1938    destroy .file
1939}
1940
1941proc updir {} {
1942    global expgui
1943    set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)]]
1944}
1945
1946# create a file box
1947proc expfilebox {bx mode} {
1948    global expgui
1949    pack [frame $bx.top] -side top
1950    pack [label $bx.top.a -text "Directory" ] -side left
1951    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1952    pack $bx.top.d -side left
1953    set expgui(FileMenuDir) [pwd]
1954    # the icon below is from tk8.0/tkfbox.tcl
1955    set upfolder [image create bitmap -data {
1956#define updir_width 28
1957#define updir_height 16
1958static char updir_bits[] = {
1959   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1960   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1961   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1962   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1963   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1964   0xf0, 0xff, 0xff, 0x01};}]
1965
1966    pack [button $bx.top.b -image $upfolder \
1967            -command "updir; ChooseExpFil $bx" ]
1968    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1969    listbox $bx.a.files -relief raised -bd 2 \
1970            -yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
1971            -height 15 -width 0 -exportselection 0 
1972    listbox $bx.a.dates -relief raised -bd 2 \
1973            -yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
1974            -height 15 -width 0 -takefocus 0 -exportselection 0 
1975    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1976    ChooseExpFil $bx
1977    bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
1978    bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
1979    bind $bx.a.files <Double-1> "SelectExpFil $bx $mode"
1980    bind $bx.a.dates <Double-1> "SelectExpFil $bx $mode"
1981    pack $bx.a.scroll -side left -fill y
1982    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1983    pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
1984}
1985proc sync2boxesX {master slave scroll args} {
1986    $slave xview moveto [lindex [$master xview] 0]
1987    eval $scroll set $args
1988}
1989proc move2boxesX {boxlist args} {
1990    foreach listbox $boxlist { 
1991        eval $listbox xview $args
1992    }
1993}
1994proc sync2boxesY {master slave scroll args} {
1995    $slave yview moveto [lindex [$master yview] 0]
1996    eval $scroll set $args
1997}
1998proc move2boxesY {boxlist args} {
1999    foreach listbox $boxlist { 
2000        eval $listbox yview $args
2001    }
2002}
2003
2004# creates a table that is scrollable in both x and y, use ResizeScrollTable
2005# to set sizes after gridding the boxes
2006proc MakeScrollTable {box} {
2007    grid [label $box.0] -col 0 -row 0
2008    grid [set tbox [canvas $box.top \
2009            -scrollregion {0 0 10 10} \
2010            -xscrollcommand "sync2boxesX $box.top $box.can $box.scroll" \
2011            -width 10 -height 10]] \
2012            -sticky sew -row 0 -column 1
2013    grid [set sbox [canvas $box.side \
2014            -scrollregion {0 0 10 10} \
2015            -yscrollcommand "sync2boxesY $box.side $box.can $box.yscroll" \
2016            -width 10 -height 10]] \
2017            -sticky nes -row 1 -column 0
2018    grid [set bbox [canvas $box.can \
2019            -scrollregion {0 0 10 10} \
2020            -yscrollcommand "sync2boxesY $box.can $box.side $box.yscroll" \
2021            -xscrollcommand "sync2boxesX $box.can $box.top $box.scroll" \
2022            -width 200 -height 200 -bg lightgrey]] \
2023            -sticky news -row 1 -column 1
2024    grid [set sxbox [scrollbar $box.scroll -orient horizontal \
2025            -command "move2boxesX \" $box.can $box.top \" "]] \
2026            -sticky ew -row 2 -column 1
2027    grid [set sybox [scrollbar $box.yscroll \
2028            -command "move2boxesY \" $box.can $box.side \" "]] \
2029            -sticky ns -row 1 -column 2
2030    frame $tbox.f -bd 0
2031    $tbox create window 0 0 -anchor nw  -window $tbox.f
2032    frame $bbox.f -bd 2
2033    $bbox create window 0 0 -anchor nw  -window $bbox.f
2034    frame $sbox.f -bd 2 -relief raised
2035    $sbox create window 0 0 -anchor nw  -window $sbox.f
2036    grid columnconfig $box 1 -weight 1
2037    grid rowconfig $box 1 -weight 1
2038    return [list  $tbox.f  $bbox.f $sbox.f $box.0]
2039}
2040
2041proc ResizeScrollTable {box} {
2042    update idletasks
2043    for {set i 0} {$i < [lindex [grid size $box.can.f] 0]} {incr i} {
2044        set x1 [lindex [grid bbox $box.can.f 0 $i] 2]
2045        set x2 [lindex [grid bbox $box.top.f 0 $i] 2]
2046        if {$x2 > $x1} {set x1 $x2}
2047        grid columnconfigure $box.top.f $i -minsize $x2
2048        grid columnconfigure $box.can.f $i -minsize $x2
2049    }
2050    for {set i 0} {$i < [lindex [grid size $box.can.f] 1]} {incr i} {
2051        set x1 [lindex [grid bbox $box.can.f 0 $i] 3]
2052        set x2 [lindex [grid bbox $box.side.f 0 $i] 3]
2053        if {$x2 > $x1} {set x1 $x2}
2054        grid rowconfigure $box.can.f $i -minsize $x1
2055        grid rowconfigure $box.side.f $i -minsize $x1
2056    }
2057    update idletasks
2058    set sizes [grid bbox $box.can.f]
2059    $box.can config -scrollregion $sizes
2060    $box.side config -scrollregion $sizes
2061    $box.top config -scrollregion $sizes
2062    $box.top config -height [lindex [grid bbox $box.top.f] 3]
2063    $box.side config -width [lindex [grid bbox $box.side.f] 2]
2064}
2065
2066
2067# support routine for SetHistUseFlags
2068proc InitHistUseFlags {} {
2069    global expmap expgui
2070    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2071        if {[string range $expmap(htype_$i) 0 0] == "P"} {
2072            set expgui(useflag_$i) [histinfo $i use]
2073        }
2074    }
2075}
2076
2077# show all Powder histograms; set use/do not use flags
2078proc SetHistUseFlags {} {
2079    set box .test
2080    catch {toplevel $box}
2081    eval destroy [winfo children $box]
2082    grid [label $box.0 -text "Set histogram \"Use/Do Not Use\" flags" -bg white] -row 0 -column 0 -columnspan 2
2083    grid [frame $box.a] -row 1 -column 0 -columnspan 2
2084    grid [button $box.b -text Save -command "destroy $box"] -row 2 -column 0 -sticky e
2085    grid [button $box.c -text Cancel -command "InitHistUseFlags;destroy $box"] -row 2 -column 1 -sticky w
2086    grid columnconfig $box 0 -weight 1
2087    grid columnconfig $box 1 -weight 1
2088    foreach a [MakeScrollTable $box.a] b {tbox bbox sbox cbox} {set $b $a}
2089    $cbox config -text "Use\nFlag"
2090    [winfo parent $bbox] config -height 250 -width 400
2091    global expmap expgui
2092    set px 5
2093    set row -1
2094    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2095        if {[string range $expmap(htype_$i) 2 2] == "T"} {
2096            set det [format %8.2f [histinfo $i tofangle]]
2097        } elseif {[string range $expmap(htype_$i) 2 2] == "C"} {
2098            set det [format %8.5f [histinfo $i lam1]]
2099        } elseif {[string range $expmap(htype_$i) 2 2] == "E"} {
2100            set det [format %8.2f [histinfo $i lam1]]
2101        } else {
2102            set det {}
2103        }
2104        incr row
2105        if {[string range $expmap(htype_$i) 0 0] == "P"} {
2106            grid [checkbutton $sbox.$i -text $i -variable expgui(useflag_$i)] -row $row -col 0 
2107            set expgui(useflag_$i) [histinfo $i use]
2108        }
2109        grid [label $bbox.0$i \
2110                -text [string range $expmap(htype_$i) 1 3] \
2111                ] -row $row -col 0 -padx $px
2112        grid [label $bbox.1$i -text [histinfo $i bank] \
2113                ] -row $row -col 1 -padx $px
2114        grid [label $bbox.2$i -text $det] -row $row -col 2 -padx $px
2115        grid [label $bbox.3$i -text [string range [histinfo $i title] 0 66] \
2116                ] -row $row -col 3 -padx $px -sticky ew
2117    }
2118    grid [label $tbox.0 -text type -bd 2 -relief raised] -row 0 -col 0 -padx $px
2119    grid [label $tbox.1 -text bank -bd 2 -relief raised] -row 0 -col 1 -padx $px
2120    grid [label $tbox.2 -text "ang/wave" -bd 2 -relief raised] -row 0 -col 2 -padx $px
2121    grid [label $tbox.3 -text "histogram title" -bd 2 -relief raised] -row 0 -col 3 -sticky w -padx $px
2122    ResizeScrollTable $box.a
2123    InitHistUseFlags
2124    putontop $box
2125    tkwait window $box
2126    afterputontop
2127    set prevchages $expgui(changed)
2128    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2129        if {[string range $expmap(htype_$i) 0 0] == "P"} {
2130            if {$expgui(useflag_$i) != [histinfo $i use]} {
2131                histinfo $i use set $expgui(useflag_$i)
2132                incr expgui(changed)
2133            }
2134        }
2135    }
2136    if {$prevchages != $expgui(changed)} {
2137        set msg "You have changed [expr $expgui(changed)-$prevchages] "
2138        append msg "histogram flag(s). You must run POWPREF "
2139        append msg "to include/remove these histograms. Do you want to "
2140        append msg "run POWPREF?"
2141        set ans [MyMessageBox -parent . -message $msg \
2142                -title "Process changes?"\
2143                -helplink "expguierr.html ProcessUse" \
2144                -default {Run POWPREF} \
2145                -type {{Run POWPREF} Skip}]
2146       
2147        if {$ans == "skip"} {
2148            # save and reload the experiment file
2149            savearchiveexp
2150            loadexp $expgui(expfile)
2151        } else {
2152            # run powpref and force a reload
2153            set saveautoload $expgui(autoexpload)
2154            set expgui(autoexpload) 1
2155            runGSASwEXP powpref
2156            set expgui(autoexpload) $saveautoload
2157        }
2158    }
2159}
2160
2161# set the box or file in the selection window
2162proc ReleaseExpFil {frm} {
2163    global expgui
2164    set files $frm.a.files
2165    set dates $frm.a.dates
2166    set select [$files curselection]
2167    if {$select == ""} {
2168        set select [$dates curselection]
2169    }
2170    if {$select == ""} {
2171        set expgui(FileMenuEXPNAM) ""
2172    } else {
2173        set expgui(FileMenuEXPNAM) [string trim [$files get $select]]
2174    }
2175    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
2176        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
2177        ChooseExpFil $frm
2178    } elseif [file isdirectory \
2179            [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]] {
2180        if {$expgui(FileMenuEXPNAM) != "."} {
2181            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2182            ChooseExpFil $frm
2183        }
2184    }
2185    return
2186}
2187
2188# select a file or directory -- called on double click
2189proc SelectExpFil {frm mode} {
2190    global expgui
2191    set files $frm.a.files
2192    set dates $frm.a.dates
2193    set select [$files curselection]
2194    if {$select == ""} {
2195        set select [$dates curselection]
2196    }
2197    if {$select == ""} {
2198        set file .
2199    } else {
2200        set file [string trim [$files get $select]]
2201    }
2202    if {$file == "<Parent>"} {
2203        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
2204        ChooseExpFil $frm
2205    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
2206        if {$file != "."} {
2207            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
2208            ChooseExpFil $frm
2209        }
2210    } else {
2211        set expgui(FileMenuEXPNAM) [file tail $file]
2212        valid_exp_file $frm $mode
2213    }
2214}
2215
2216# fill the files & dates & Directory selection box with current directory,
2217# also called when box is created to fill it
2218proc ChooseExpFil {frm} {
2219    global expgui
2220    set files $frm.a.files
2221    set dates $frm.a.dates
2222    set expgui(FileMenuEXPNAM) {}
2223    $files delete 0 end
2224    $dates delete 0 end
2225    $files insert end {<Parent>}
2226    $dates insert end {(Directory)}
2227    set filelist [glob -nocomplain \
2228            [file join [set expgui(FileMenuDir)] *] ]
2229    foreach file [lsort -dictionary $filelist] {
2230        if {[file isdirectory $file]} {
2231            $files insert end [file tail $file]
2232            $dates insert end {(Directory)}
2233        }
2234    }
2235    set pairlist {}
2236    foreach file [lsort -dictionary $filelist] {
2237        if {![file isdirectory $file]  && \
2238                [string toupper [file extension $file]] == ".EXP"} {
2239            set modified [file mtime $file]
2240            lappend pairlist [list $file $modified]
2241        } elseif {![file isdirectory $file] && $expgui(includearchived) && \
2242                [string match {*.O[0-9A-F][0-9A-F]} $file]} {
2243            set modified [file mtime $file]
2244            lappend pairlist [list $file $modified]
2245        }
2246    }
2247    if {$expgui(filesort) == 0} {
2248        foreach pair [lsort -index 1 -integer $pairlist] {
2249            set file [lindex $pair 0]
2250            set modified [clock format [lindex $pair 1] -format "%T %D"]
2251            $files insert end [file tail $file]
2252            $dates insert end $modified
2253        }
2254    } else {
2255        foreach pair [lsort -dictionary -index 0 $pairlist] {
2256            set file [lindex $pair 0]
2257            set modified [clock format [lindex $pair 1] -format "%T %D"]
2258            $files insert end [file tail $file]
2259            $dates insert end $modified
2260        }
2261    }
2262    $expgui(FileDirButtonMenu)  delete 0 end
2263    set list ""
2264    global tcl_platform tcl_version
2265    if {$tcl_platform(platform) == "windows" && $tcl_version > 8.0} {
2266        catch {set list [string tolower [file volume]]}
2267    }
2268    set dir ""
2269    foreach subdir [file split [set expgui(FileMenuDir)]] {
2270        set dir [file join $dir $subdir]
2271        if {$tcl_platform(platform) == "windows"} {
2272            set dir [string tolower $dir]
2273            if {[lsearch $list $dir] == -1} {lappend list $dir}
2274        } else {
2275            lappend list $dir
2276        }
2277    }
2278    foreach path $list {
2279        $expgui(FileDirButtonMenu) add command -label $path \
2280                -command "[list set expgui(FileMenuDir) $path]; \
2281                ChooseExpFil $frm"
2282    }
2283    # highlight the current experiment -- if present
2284    for {set i 0} {$i < [$files size]} {incr i} {
2285        set file [$files get $i]
2286        if {$expgui(expfile) == [file join $expgui(FileMenuDir) $file]} {
2287            $files selection set $i
2288        }
2289    }
2290    return
2291}
2292
2293
2294#------------------------------------------------------------------------------
2295# platform-specific definitions
2296if {$tcl_platform(platform) == "windows" && $tcl_platform(os) == "Windows 95"} {
2297    # windows-95, -98 and presumably -me do not allow Tcl/Tk to run the
2298    # DOS box synchronously, so we create a "lock" file that is deleted
2299    # at the end of the DOS run so we can tell when the run is done.
2300    # We create a window to force the deleting of the file so that if
2301    # the DOS process crashes, the user can continue anyway.
2302    #
2303    # procedure to check if the lock file is still there (Win-9x/me only)
2304    proc checklockfile {file window} {
2305        if [file exists $file] {
2306            after 500 checklockfile $file $window
2307        } else {
2308            catch {destroy $window}
2309        }
2310    }
2311    # this creates a DOS box to run a program in
2312    proc forknewterm {title command "wait 1" "scrollbar 1"} {
2313        global env expgui
2314        # Windows environment variables
2315        set env(GSAS) [file nativename $expgui(gsasdir)]
2316        # PGPLOT_FONT is needed by PGPLOT
2317        set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) pgl grfont.dat]]
2318        # this is the number of lines/page in the .LST (etc.) file
2319        set env(LENPAGE) 60
2320        set pwd [file nativename [pwd]]
2321       
2322        # check the .EXP path -- can DOS use it?
2323        if {[string first // [pwd]] != -1} {
2324            MyMessageBox -parent . -title "Invalid Path" \
2325                    -message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2326                    -icon error -type ok -default ok \
2327                    -helplink "expgui_Win_readme.html NetPath"
2328            return
2329        }
2330        # pause is hard coded in the .BAT file
2331        #
2332        # loop over multiple commands
2333        foreach cmd $command {
2334            # simulate the wait with a lock file
2335            if {$wait} {
2336                if {$expgui(autoiconify)} {wm iconify .}
2337                # create a blank lock file and a message window
2338                close [open expgui.lck w]
2339                toplevel .lock
2340                grid [button .lock.0 -text Help -bg yellow \
2341                        -command "MakeWWWHelp expguierr.html lock"] \
2342                        -column 1 -row 0
2343                grid [label .lock.1 \
2344                        -text "Please wait while the GSAS program finishes."] \
2345                        -column 0 -row 0
2346                grid [label .lock.2 -text \
2347                        "In case a problem occurs, close the DOS box"] \
2348                        -column 0 -columnspan 2 -row 1
2349                grid [label .lock.3 -text \
2350                        "and press the \"Continue\" button (below)"] \
2351                        -column 0 -columnspan 2 -row 2
2352                grid [button .lock.b -text "Continue" \
2353                        -command "destroy .lock; wm deiconify ."] \
2354                        -column 0 -columnspan 2 -row 3
2355                putontop .lock
2356                update
2357                checklockfile expgui.lck .lock
2358            }
2359            # replace the forward slashes with backward
2360            regsub -all / $cmd \\ cmd
2361            winexec -d [file nativename [pwd]] \
2362                    [file join $expgui(scriptdir) gsastcl.bat] $cmd
2363            if {$wait} {
2364                tkwait window .lock
2365                file delete -force expgui.lck
2366            }
2367        }
2368        if {$expgui(autoiconify) && $wait} {wm deiconify .}
2369        # check for changes in the .EXP file immediately
2370        whenidle
2371    }
2372} elseif {$tcl_platform(platform) == "windows"} {
2373    # now for Windows-NT, where we can run synchronously
2374    #
2375    # this creates a DOS box to run a program in
2376    proc forknewterm {title command  "wait 1" "scrollbar 1"} {
2377        global env expgui
2378        # Windows environment variables
2379        set env(GSAS) [file nativename $expgui(gsasdir)]
2380        # PGPLOT_FONT is needed by PGPLOT
2381        set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) pgl grfont.dat]]
2382        # this is the number of lines/page in the .LST (etc.) file
2383        set env(LENPAGE) 60
2384        set pwd [file nativename [pwd]]
2385        # check the path -- can DOS use it?
2386        if {[string first // [pwd]] != -1} {
2387            MyMessageBox -parent . -title "Invalid Path" \
2388                    -message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2389                    -icon error -type ok -default ok \
2390                    -helplink "expgui_Win_readme.html NetPath"
2391            return
2392        }
2393        # pause is hard coded in the .BAT file
2394
2395        if {$wait} {
2396            if {$expgui(autoiconify)} {wm iconify .}
2397            # create a blank lock file (keep liveplot from running)
2398            close [open expgui.lck w]
2399            # loop over commands
2400            foreach cmd $command {
2401                # replace the forward slashes with backward
2402                regsub -all / $cmd \\ cmd
2403                exec $env(COMSPEC) /c \
2404                        "start [file join $expgui(scriptdir) gsastcl.bat] $cmd"
2405            }
2406            file delete -force expgui.lck
2407            if {$expgui(autoiconify)} {wm deiconify .}
2408            # check for changes in the .EXP file immediately
2409            whenidle
2410        } else {
2411            # loop over commands
2412            foreach cmd $command {
2413                # replace the forward slashes with backward
2414                regsub -all / $cmd \\ cmd
2415                # run in background
2416                exec $env(COMSPEC) /c \
2417                        "start [file join $expgui(scriptdir) gsastcl.bat] $cmd" &
2418            }
2419        }
2420    }
2421} else {
2422    # this creates a xterm window to run a program in
2423    proc forknewterm {title command "wait 1" "scrollbar 1"} {
2424        global env expgui
2425        # UNIX environment variables
2426        set env(GSAS) [file nativename $expgui(gsasdir)]
2427        set env(gsas) [file nativename $expgui(gsasdir)]
2428        set env(GSASEXE) $expgui(gsasexe)
2429        set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
2430        set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
2431        # PGPLOT_DIR is needed by PGPLOT
2432        set env(PGPLOT_DIR) [file join $expgui(gsasdir) pgl]
2433        # this is the number of lines/page in the .LST (etc.) file
2434        set env(LENPAGE) 60
2435        set termopts {}
2436        if $env(GSASBACKSPACE) {
2437            append termopts \
2438                    {-xrm "xterm*VT100.Translations: #override\\n <KeyPress>BackSpace: string(\\177)"}
2439        }
2440        if $scrollbar {
2441            append termopts " -sb"
2442        } else {
2443            append termopts " +sb"
2444        }
2445        if {$wait} {
2446            set suffix {}
2447        } else {
2448            set suffix {&}
2449        }
2450        #
2451        #if $wait {
2452            append command "\; echo -n Press Enter to continue \; read x"
2453        #}
2454        if {$wait && $expgui(autoiconify)} {wm iconify .}
2455        catch {eval exec xterm $termopts -title [list $title] \
2456                -e /bin/sh -c [list $command] $suffix} errmsg
2457        if $expgui(debug) {puts "xterm result = $errmsg"}
2458        if {$wait && $expgui(autoiconify)} {wm deiconify .}
2459    }
2460}
Note: See TracBrowser for help on using the repository browser.