Changeset 231

Timestamp:

Dec 4, 2009 5:02:35 PM (14 years ago)

Author:

toby

Message:

# on 2000/07/06 21:29:24, toby did:
Add GetProfileTerms?, GetLaue?, ChangeProfileType? etc.

File:

• trunk/gsascmds.tcl (modified) (1 diff, 3 props)

trunk/gsascmds.tcl

@@ -1697 +1697 @@
     catch {destroy .msg}
 }
+
+
+# profile terms
+array set expgui {
+    prof-T-1 {alp-0 alp-1 bet-0 bet-1 sig-0 sig-1 sig-2 rstr rsta \
+            rsca s1ec s2ec }
+    prof-T-2 {alp-0 alp-1 beta switch sig-0 sig-1 sig-2 gam-0 gam-1 \
+            gam-2 ptec stec difc difa zero }
+    prof-T-3 {alp bet-0 bet-1 sig-0 sig-1 sig-2 gam-0 gam-1 \
+            gam-2 gsf g1ec g2ec rstr rsta rsca L11 L22 L33 L12 L13 L23 }
+    prof-T-4 {alp bet-0 bet-1 sig-1 sig-2 gam-2 g2ec gsf \
+            rstr rsta rsca eta}
+    prof-C-1 {GU GV GW asym F1 F2 }
+    prof-C-2 {GU GV GW LX LY trns asym shft GP stec ptec sfec \
+            L11 L22 L33 L12 L13 L23 }
+    prof-C-3 {GU GV GW GP LX LY S/L H/L trns shft stec ptec sfec \
+            L11 L22 L33 L12 L13 L23 }
+    prof-C-4 {GU GV GW GP LX ptec trns shft sfec S/L H/L eta} 
+    prof-E-1 {A B C ds cds}
+}
+
+# number of profile terms depends on the histogram type
+# the LAUE symmetry and the profile number
+proc GetProfileTerms {phase hist ptype} {
+    global expmap expgui
+    if {$hist == "C" || $hist == "T" || $hist == "E"} {
+        set htype $hist
+    } else {
+        set htype [string range $expmap(htype_$hist) 2 2]
+    }
+    # get the cached copy of the profile term labels, when possible
+    catch {
+        set lbls $expmap(ProfileTerms${phase}_${ptype}_${htype})
+        return
+    }
+    set lbls {}
+    catch {set lbls $expgui(prof-$htype-$ptype)}
+    if {$lbls == ""} {return}
+    # add terms based on the Laue symmetry
+    if {($htype == "C" || $htype == "T") && $ptype == 4} {
+        set laueaxis [GetLaue [phaseinfo $phase spacegroup]]
+        eval lappend lbls [Profile4Terms $laueaxis]
+    }
+    set expmap(ProfileTerms${phase}_${ptype}_${htype}) $lbls
+    return $lbls
+}
+
+proc Profile4Terms {laueaxis} {
+    switch -exact $laueaxis {
+        1bar {return \
+                "S400 S040 S004 S220 S202 S022 S310 S103 S031 \
+                S130 S301 S013 S211 S121 S112"}
+        2/ma {return "S400 S040 S004 S220 S202 S022 S013 S031 S211"}
+        2/mb {return "S400 S040 S004 S220 S202 S022 S301 S103 S121"}
+        2/mc {return "S400 S040 S004 S220 S202 S022 S130 S310 S112"}
+        mmm  {return "S400 S040 S004 S220 S202 S022"}
+        4/m  {return "S400 S004 S220 S202"}
+        4/mmm {return "S400 S004 S220 S202"}
+        3bar     {return "S400 S220 S310 S211"}
+        "3bar m" {return "S400 S220 S310 S211"}
+        3bar    {return "S400 S004 S202 S211"}
+        3barm1 {return "S400 S004 S202"}
+        3bar1m  {return "S400 S004 S202 S211"}
+        6/m    {return "S400 S004 S202"}
+        6/mmm  {return "S400 S004 S202"}
+        "m 3"  {return "S400 S220"}
+        m3m    {return "S400 S220"}
+        default {return ""}
+    }
+}
+
+proc GetLaue {spg} {
+    global tcl_platform expgui
+    # check the space group
+    set fp [open spg.in w]
+    puts $fp "N"
+    puts $fp "N"
+    puts $fp $spg
+    puts $fp "Q"
+    close $fp
+    catch {
+        if {$tcl_platform(platform) == "windows"} {
+            exec [file join $expgui(gsasexe) spcgroup.exe] < spg.in >& spg.out
+        } else {
+            exec [file join $expgui(gsasexe) spcgroup] < spg.in >& spg.out
+        }
+    }
+    set fp [open spg.out r]
+    set laue {}
+    set uniqueaxis {}
+    while {[gets $fp line] >= 0} {
+        regexp {Laue symmetry (.*)} $line junk laue
+        regexp {The unique axis is (.*)} $line junk uniqueaxis
+    }
+    close $fp
+    catch {file delete -force spg.in spg.out}
+    set laue [string trim $laue]
+    return "${laue}$uniqueaxis"
+}
+
+
+# set up to change the profile type for a series of histogram/phase entries
+# (histlist & phaselist should be lists of the same length)
+#
+proc ChangeProfileType {histlist phaselist} {
+    global expgui expmap 
+    set w .profile
+    catch {destroy $w}
+    toplevel $w -bg beige
+    wm title $w "Change Profile Function"
+    
+    # all histogram/phases better be the same type, so we can just use the 1st
+    set hist [lindex $histlist 0]
+    set phase [lindex $phaselist 0]
+    set ptype [string trim [hapinfo $hist $phase proftype]]
+
+    # get list of allowed profile terms for the current histogram type
+    set i 1
+    while {[set lbls [GetProfileTerms $phase $hist $i]] != ""} {
+        lappend lbllist $lbls
+        incr i
+    }
+    # labels for the current type
+    set i $ptype
+    set oldlbls [lindex $lbllist [incr i -1]]
+    
+    if {[llength $histlist] == 1} {
+        pack [label $w.a -bg beige \
+                -text "Change profile function for Histogram #$hist Phase #$phase" \
+                ] -side top
+    } else {
+        # make a list of histograms by phase
+        foreach h $histlist p $phaselist {
+            lappend phlist($p) $h
+        }
+        set num 0
+        pack [frame $w.a -bg beige] -side top 
+        pack [label $w.a.$num -bg beige \
+                -text "Change profile function for:" \
+                ] -side top -anchor w
+        foreach i [lsort [array names phlist]] {
+            incr num
+            pack [label $w.a.$num -bg beige -text \
+                    "\tPhase #$i, Histograms [CompressList $phlist($i)]" \
+                    ] -side top -anchor w
+        }
+    }
+    pack [label $w.e1 \
+            -text "Current function is type $ptype." \
+            -bg beige] -side top -anchor w
+    pack [frame $w.e -bg beige] -side top -expand yes -fill both
+    pack [label $w.e.1 \
+            -text "Set function to type" \
+            -bg beige] -side left 
+    set menu [tk_optionMenu $w.e.2 expgui(newpeaktype) junk]
+    pack $w.e.2 -side left -anchor w
+
+    pack [radiobutton $w.e.4 -bg beige -variable expgui(DefaultPeakType) \
+            -command "set expgui(newpeaktype) $ptype; \
+            FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
+            -value 1 -text "Current value overrides"] -side right
+    pack [radiobutton $w.e.3 -bg beige -variable expgui(DefaultPeakType) \
+            -command \
+            "set expgui(newpeaktype) $ptype; \
+            FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
+            -value 0 -text "Default value overrides"] -side right
+
+    $w.e.2 config -bg beige
+    pack [frame $w.c -bg beige] -side top -expand yes -fill both
+    pack [frame $w.d -bg beige] -side top -expand yes -fill both
+    pack [button $w.d.2 -text Set -bg beige \
+            -command "SaveChangeProfileType $w.c $histlist $phaselist; destroy $w"\
+            ] -side left
+    pack [button $w.d.3 -text Quit -bg beige \
+            -command "destroy $w"] -side left
+    bind $w <Return> "destroy $w"
+
+    $menu delete 0 end
+    set i 0
+    foreach lbls $lbllist {
+        incr i
+        $menu add command -label $i -command \
+                "set expgui(newpeaktype) $i; \
+                FillChangeProfileType $w.c $hist $phase $i [list $lbls] [list $oldlbls]"
+    }
+    set expgui(newpeaktype) $ptype
+    FillChangeProfileType $w.c $hist $phase $ptype $oldlbls $oldlbls
+
+    # force the window to stay on top
+    putontop $w
+    focus $w.e.2
+    tkwait window $w
+    afterputontop
+    sethistlist
+}
+
+# save the changes to the profile
+proc SaveChangeProfileType {w histlist phaselist} {
+    global expgui
+    foreach phase $phaselist hist $histlist {
+        hapinfo $hist $phase proftype set $expgui(newpeaktype)
+        hapinfo $hist $phase profterms set $expgui(newProfileTerms)
+        for {set i 1} {$i <=  $expgui(newProfileTerms)} {incr i} {
+            hapinfo $hist $phase pterm$i set [$w.ent${i} get]
+            hapinfo $hist $phase pref$i set $expgui(ProfRef$i)
+        }
+        set i [expr 1+$expgui(newProfileTerms)]
+        hapinfo $hist $phase pcut set [$w.ent$i get]
+        incr expgui(changed) [expr 3 + $expgui(newProfileTerms)]
+    }
+}
+
+# file the contents of the "Change Profile Type" Menu
+proc FillChangeProfileType {w hist phase newtype lbls oldlbls} {
+    global expgui expmap 
+    set ptype [string trim [hapinfo $hist $phase proftype]]
+    catch {unset oldval}
+    # loop through the old terms and set up an array of starting values
+    set num 0
+    foreach term $oldlbls {
+        incr num
+        set oldval($term) [hapinfo $hist $phase pterm$num]
+    }
+    set oldval(Peak\nCutoff) [hapinfo $hist $phase pcut]
+
+    # is the new type the same as the current?
+    if {$ptype == $newtype} {
+        set nterms [hapinfo $hist $phase profterms]
+    } else {
+        set nterms [llength $lbls]
+    }
+    set expgui(newProfileTerms) $nterms
+    set expgui(CurrentProfileTerms) $nterms
+    # which default profile set matches the new type
+    set setnum {}
+    foreach j {" " 1 2 3 4 5 6 7 8 9} {
+        set i [profdefinfo $hist $j proftype]
+        if {$i == ""} continue
+        if {$i == $newtype} {
+            set setnum $j
+            break
+        }
+    }
+
+    eval destroy [winfo children $w]
+
+    set colstr 0
+    set row 2
+    set maxrow [expr $row + $nterms/2]
+    for { set num 1 } { $num <= $nterms + 1} { incr num } {
+        # get the default value (originally from the in .INS file)
+        set val {}
+        if {$setnum != ""} {
+            set val 0.0
+            catch {
+                set val [profdefinfo $hist $setnum pterm$num]
+                # pretty up the number
+                if {$val == 0.0} {
+                    set val 0.0
+                } elseif {abs($val) < 1e-2 || abs($val) > 1e6} {
+                    set val [format %.3e $val]
+                } elseif {abs($val) > 1e-2 && abs($val) < 10} {
+                    set val [format %.5f $val]
+                } elseif {abs($val) < 9999} {
+                    set val [format %.2f $val]
+                } elseif {abs($val) < 1e6} {
+                    set val [format %.0f $val]
+                }
+            }
+        }
+        # heading
+        if {$row == 2} {
+            set col $colstr
+            grid [label $w.h0${num} -text "lbl" -bg beige] \
+                -row $row -column $col
+            grid [label $w.h2${num} -text "ref" -bg beige] \
+                -row $row -column [incr col]
+            grid [label $w.h3${num} -text "next value" -bg beige] \
+                -row $row -column [incr col]
+            grid [label $w.h4${num} -text "default" -bg beige] \
+                -row $row -column [incr col]
+            grid [label $w.h5${num} -text "current" -bg beige] \
+                -row $row -column [incr col]
+        }
+        set col $colstr
+        incr row
+        set term {}
+        catch {set term [lindex $lbls [expr $num-1]]}
+        if {$term == ""} {set term $num}
+        if {$num == $nterms + 1} {
+            set term "Peak\nCutoff"
+            set val {}
+            if {$setnum != ""} {
+                set val 0.0
+                catch {set val [profdefinfo $hist $setnum pcut]}
+            }
+        }
+
+        grid [label $w.l${num} -text "$term" -bg beige] \
+                -row $row -column $col
+        grid [checkbutton $w.chk${num} -variable expgui(ProfRef$num) \
+                -bg beige -activebackground beige] -row $row -column [incr col]
+        grid [entry $w.ent${num} \
+                -width 12] -row $row -column [incr col]
+        if {$val != ""} {
+            grid [button $w.def${num} -text $val -command \
+                    "$w.ent${num} delete 0 end; $w.ent${num} insert end $val" \
+                    ] -row $row -column [incr col] -sticky ew
+        } else {
+            grid [label $w.def${num} -text (none) \
+                    ] -row $row -column [incr col]
+        }
+        set curval {}
+        catch {
+            set curval [expr $oldval($term)]
+            # pretty up the number
+            if {$curval == 0.0} {
+                set curval 0.0
+            } elseif {abs($curval) < 1e-2 || abs($curval) > 1e6} {
+                set curval [format %.3e $curval]
+            } elseif {abs($curval) > 1e-2 && abs($curval) < 10} {
+                set curval [format %.5f $curval]
+            } elseif {abs($curval) < 9999} {
+                set curval [format %.2f $curval]
+            } elseif {abs($curval) < 1e6} {
+                set curval [format %.0f $curval]
+            }
+            grid [button $w.cur${num} -text $curval -command  \
+                    "$w.ent${num} delete 0 end; $w.ent${num} insert end $curval" \
+                    ] -row $row -column [incr col] -sticky ew
+        }
+        # set default values for flag and value
+        set ref 0
+        if {$setnum != ""} {
+            catch {
+                if {[profdefinfo $hist $setnum pref$num] == "Y"} {set ref 1}
+            }
+        }
+        set expgui(ProfRef$num) $ref
+        
+        $w.ent${num} delete 0 end
+        if {!$expgui(DefaultPeakType) && $val != ""} {
+            $w.ent${num} insert end $val
+        } elseif {$curval != ""} {
+            $w.ent${num} insert end $curval
+        } elseif {$val != ""} {
+            $w.ent${num} insert end $val
+        } else {
+            $w.ent${num} insert end 0.0
+        }
+        if {$row > $maxrow} {
+            set row 2
+            incr colstr 5
+        }
+    }
+}