Changeset 231 for trunk/gsascmds.tcl


Ignore:
Timestamp:
Dec 4, 2009 5:02:35 PM (11 years ago)
Author:
toby
Message:

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

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/gsascmds.tcl

    • Property rcs:date changed from 2000/07/03 21:50:35 to 2000/07/06 21:29:24
    • Property rcs:lines changed from +16 -39 to +357 -1
    • Property rcs:rev changed from 1.20 to 1.21
    r227 r231  
    16971697    catch {destroy .msg}
    16981698}
     1699
     1700
     1701# profile terms
     1702array set expgui {
     1703    prof-T-1 {alp-0 alp-1 bet-0 bet-1 sig-0 sig-1 sig-2 rstr rsta \
     1704            rsca s1ec s2ec }
     1705    prof-T-2 {alp-0 alp-1 beta switch sig-0 sig-1 sig-2 gam-0 gam-1 \
     1706            gam-2 ptec stec difc difa zero }
     1707    prof-T-3 {alp bet-0 bet-1 sig-0 sig-1 sig-2 gam-0 gam-1 \
     1708            gam-2 gsf g1ec g2ec rstr rsta rsca L11 L22 L33 L12 L13 L23 }
     1709    prof-T-4 {alp bet-0 bet-1 sig-1 sig-2 gam-2 g2ec gsf \
     1710            rstr rsta rsca eta}
     1711    prof-C-1 {GU GV GW asym F1 F2 }
     1712    prof-C-2 {GU GV GW LX LY trns asym shft GP stec ptec sfec \
     1713            L11 L22 L33 L12 L13 L23 }
     1714    prof-C-3 {GU GV GW GP LX LY S/L H/L trns shft stec ptec sfec \
     1715            L11 L22 L33 L12 L13 L23 }
     1716    prof-C-4 {GU GV GW GP LX ptec trns shft sfec S/L H/L eta}
     1717    prof-E-1 {A B C ds cds}
     1718}
     1719
     1720# number of profile terms depends on the histogram type
     1721# the LAUE symmetry and the profile number
     1722proc GetProfileTerms {phase hist ptype} {
     1723    global expmap expgui
     1724    if {$hist == "C" || $hist == "T" || $hist == "E"} {
     1725        set htype $hist
     1726    } else {
     1727        set htype [string range $expmap(htype_$hist) 2 2]
     1728    }
     1729    # get the cached copy of the profile term labels, when possible
     1730    catch {
     1731        set lbls $expmap(ProfileTerms${phase}_${ptype}_${htype})
     1732        return
     1733    }
     1734    set lbls {}
     1735    catch {set lbls $expgui(prof-$htype-$ptype)}
     1736    if {$lbls == ""} {return}
     1737    # add terms based on the Laue symmetry
     1738    if {($htype == "C" || $htype == "T") && $ptype == 4} {
     1739        set laueaxis [GetLaue [phaseinfo $phase spacegroup]]
     1740        eval lappend lbls [Profile4Terms $laueaxis]
     1741    }
     1742    set expmap(ProfileTerms${phase}_${ptype}_${htype}) $lbls
     1743    return $lbls
     1744}
     1745
     1746proc Profile4Terms {laueaxis} {
     1747    switch -exact $laueaxis {
     1748        1bar {return \
     1749                "S400 S040 S004 S220 S202 S022 S310 S103 S031 \
     1750                S130 S301 S013 S211 S121 S112"}
     1751        2/ma {return "S400 S040 S004 S220 S202 S022 S013 S031 S211"}
     1752        2/mb {return "S400 S040 S004 S220 S202 S022 S301 S103 S121"}
     1753        2/mc {return "S400 S040 S004 S220 S202 S022 S130 S310 S112"}
     1754        mmm  {return "S400 S040 S004 S220 S202 S022"}
     1755        4/m  {return "S400 S004 S220 S202"}
     1756        4/mmm {return "S400 S004 S220 S202"}
     1757        3bar     {return "S400 S220 S310 S211"}
     1758        "3bar m" {return "S400 S220 S310 S211"}
     1759        3bar    {return "S400 S004 S202 S211"}
     1760        3barm1 {return "S400 S004 S202"}
     1761        3bar1m  {return "S400 S004 S202 S211"}
     1762        6/m    {return "S400 S004 S202"}
     1763        6/mmm  {return "S400 S004 S202"}
     1764        "m 3"  {return "S400 S220"}
     1765        m3m    {return "S400 S220"}
     1766        default {return ""}
     1767    }
     1768}
     1769
     1770proc GetLaue {spg} {
     1771    global tcl_platform expgui
     1772    # check the space group
     1773    set fp [open spg.in w]
     1774    puts $fp "N"
     1775    puts $fp "N"
     1776    puts $fp $spg
     1777    puts $fp "Q"
     1778    close $fp
     1779    catch {
     1780        if {$tcl_platform(platform) == "windows"} {
     1781            exec [file join $expgui(gsasexe) spcgroup.exe] < spg.in >& spg.out
     1782        } else {
     1783            exec [file join $expgui(gsasexe) spcgroup] < spg.in >& spg.out
     1784        }
     1785    }
     1786    set fp [open spg.out r]
     1787    set laue {}
     1788    set uniqueaxis {}
     1789    while {[gets $fp line] >= 0} {
     1790        regexp {Laue symmetry (.*)} $line junk laue
     1791        regexp {The unique axis is (.*)} $line junk uniqueaxis
     1792    }
     1793    close $fp
     1794    catch {file delete -force spg.in spg.out}
     1795    set laue [string trim $laue]
     1796    return "${laue}$uniqueaxis"
     1797}
     1798
     1799
     1800# set up to change the profile type for a series of histogram/phase entries
     1801# (histlist & phaselist should be lists of the same length)
     1802#
     1803proc ChangeProfileType {histlist phaselist} {
     1804    global expgui expmap
     1805    set w .profile
     1806    catch {destroy $w}
     1807    toplevel $w -bg beige
     1808    wm title $w "Change Profile Function"
     1809   
     1810    # all histogram/phases better be the same type, so we can just use the 1st
     1811    set hist [lindex $histlist 0]
     1812    set phase [lindex $phaselist 0]
     1813    set ptype [string trim [hapinfo $hist $phase proftype]]
     1814
     1815    # get list of allowed profile terms for the current histogram type
     1816    set i 1
     1817    while {[set lbls [GetProfileTerms $phase $hist $i]] != ""} {
     1818        lappend lbllist $lbls
     1819        incr i
     1820    }
     1821    # labels for the current type
     1822    set i $ptype
     1823    set oldlbls [lindex $lbllist [incr i -1]]
     1824   
     1825    if {[llength $histlist] == 1} {
     1826        pack [label $w.a -bg beige \
     1827                -text "Change profile function for Histogram #$hist Phase #$phase" \
     1828                ] -side top
     1829    } else {
     1830        # make a list of histograms by phase
     1831        foreach h $histlist p $phaselist {
     1832            lappend phlist($p) $h
     1833        }
     1834        set num 0
     1835        pack [frame $w.a -bg beige] -side top
     1836        pack [label $w.a.$num -bg beige \
     1837                -text "Change profile function for:" \
     1838                ] -side top -anchor w
     1839        foreach i [lsort [array names phlist]] {
     1840            incr num
     1841            pack [label $w.a.$num -bg beige -text \
     1842                    "\tPhase #$i, Histograms [CompressList $phlist($i)]" \
     1843                    ] -side top -anchor w
     1844        }
     1845    }
     1846    pack [label $w.e1 \
     1847            -text "Current function is type $ptype." \
     1848            -bg beige] -side top -anchor w
     1849    pack [frame $w.e -bg beige] -side top -expand yes -fill both
     1850    pack [label $w.e.1 \
     1851            -text "Set function to type" \
     1852            -bg beige] -side left
     1853    set menu [tk_optionMenu $w.e.2 expgui(newpeaktype) junk]
     1854    pack $w.e.2 -side left -anchor w
     1855
     1856    pack [radiobutton $w.e.4 -bg beige -variable expgui(DefaultPeakType) \
     1857            -command "set expgui(newpeaktype) $ptype; \
     1858            FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
     1859            -value 1 -text "Current value overrides"] -side right
     1860    pack [radiobutton $w.e.3 -bg beige -variable expgui(DefaultPeakType) \
     1861            -command \
     1862            "set expgui(newpeaktype) $ptype; \
     1863            FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
     1864            -value 0 -text "Default value overrides"] -side right
     1865
     1866    $w.e.2 config -bg beige
     1867    pack [frame $w.c -bg beige] -side top -expand yes -fill both
     1868    pack [frame $w.d -bg beige] -side top -expand yes -fill both
     1869    pack [button $w.d.2 -text Set -bg beige \
     1870            -command "SaveChangeProfileType $w.c $histlist $phaselist; destroy $w"\
     1871            ] -side left
     1872    pack [button $w.d.3 -text Quit -bg beige \
     1873            -command "destroy $w"] -side left
     1874    bind $w <Return> "destroy $w"
     1875
     1876    $menu delete 0 end
     1877    set i 0
     1878    foreach lbls $lbllist {
     1879        incr i
     1880        $menu add command -label $i -command \
     1881                "set expgui(newpeaktype) $i; \
     1882                FillChangeProfileType $w.c $hist $phase $i [list $lbls] [list $oldlbls]"
     1883    }
     1884    set expgui(newpeaktype) $ptype
     1885    FillChangeProfileType $w.c $hist $phase $ptype $oldlbls $oldlbls
     1886
     1887    # force the window to stay on top
     1888    putontop $w
     1889    focus $w.e.2
     1890    tkwait window $w
     1891    afterputontop
     1892    sethistlist
     1893}
     1894
     1895# save the changes to the profile
     1896proc SaveChangeProfileType {w histlist phaselist} {
     1897    global expgui
     1898    foreach phase $phaselist hist $histlist {
     1899        hapinfo $hist $phase proftype set $expgui(newpeaktype)
     1900        hapinfo $hist $phase profterms set $expgui(newProfileTerms)
     1901        for {set i 1} {$i <=  $expgui(newProfileTerms)} {incr i} {
     1902            hapinfo $hist $phase pterm$i set [$w.ent${i} get]
     1903            hapinfo $hist $phase pref$i set $expgui(ProfRef$i)
     1904        }
     1905        set i [expr 1+$expgui(newProfileTerms)]
     1906        hapinfo $hist $phase pcut set [$w.ent$i get]
     1907        incr expgui(changed) [expr 3 + $expgui(newProfileTerms)]
     1908    }
     1909}
     1910
     1911# file the contents of the "Change Profile Type" Menu
     1912proc FillChangeProfileType {w hist phase newtype lbls oldlbls} {
     1913    global expgui expmap
     1914    set ptype [string trim [hapinfo $hist $phase proftype]]
     1915    catch {unset oldval}
     1916    # loop through the old terms and set up an array of starting values
     1917    set num 0
     1918    foreach term $oldlbls {
     1919        incr num
     1920        set oldval($term) [hapinfo $hist $phase pterm$num]
     1921    }
     1922    set oldval(Peak\nCutoff) [hapinfo $hist $phase pcut]
     1923
     1924    # is the new type the same as the current?
     1925    if {$ptype == $newtype} {
     1926        set nterms [hapinfo $hist $phase profterms]
     1927    } else {
     1928        set nterms [llength $lbls]
     1929    }
     1930    set expgui(newProfileTerms) $nterms
     1931    set expgui(CurrentProfileTerms) $nterms
     1932    # which default profile set matches the new type
     1933    set setnum {}
     1934    foreach j {" " 1 2 3 4 5 6 7 8 9} {
     1935        set i [profdefinfo $hist $j proftype]
     1936        if {$i == ""} continue
     1937        if {$i == $newtype} {
     1938            set setnum $j
     1939            break
     1940        }
     1941    }
     1942
     1943    eval destroy [winfo children $w]
     1944
     1945    set colstr 0
     1946    set row 2
     1947    set maxrow [expr $row + $nterms/2]
     1948    for { set num 1 } { $num <= $nterms + 1} { incr num } {
     1949        # get the default value (originally from the in .INS file)
     1950        set val {}
     1951        if {$setnum != ""} {
     1952            set val 0.0
     1953            catch {
     1954                set val [profdefinfo $hist $setnum pterm$num]
     1955                # pretty up the number
     1956                if {$val == 0.0} {
     1957                    set val 0.0
     1958                } elseif {abs($val) < 1e-2 || abs($val) > 1e6} {
     1959                    set val [format %.3e $val]
     1960                } elseif {abs($val) > 1e-2 && abs($val) < 10} {
     1961                    set val [format %.5f $val]
     1962                } elseif {abs($val) < 9999} {
     1963                    set val [format %.2f $val]
     1964                } elseif {abs($val) < 1e6} {
     1965                    set val [format %.0f $val]
     1966                }
     1967            }
     1968        }
     1969        # heading
     1970        if {$row == 2} {
     1971            set col $colstr
     1972            grid [label $w.h0${num} -text "lbl" -bg beige] \
     1973                -row $row -column $col
     1974            grid [label $w.h2${num} -text "ref" -bg beige] \
     1975                -row $row -column [incr col]
     1976            grid [label $w.h3${num} -text "next value" -bg beige] \
     1977                -row $row -column [incr col]
     1978            grid [label $w.h4${num} -text "default" -bg beige] \
     1979                -row $row -column [incr col]
     1980            grid [label $w.h5${num} -text "current" -bg beige] \
     1981                -row $row -column [incr col]
     1982        }
     1983        set col $colstr
     1984        incr row
     1985        set term {}
     1986        catch {set term [lindex $lbls [expr $num-1]]}
     1987        if {$term == ""} {set term $num}
     1988        if {$num == $nterms + 1} {
     1989            set term "Peak\nCutoff"
     1990            set val {}
     1991            if {$setnum != ""} {
     1992                set val 0.0
     1993                catch {set val [profdefinfo $hist $setnum pcut]}
     1994            }
     1995        }
     1996
     1997        grid [label $w.l${num} -text "$term" -bg beige] \
     1998                -row $row -column $col
     1999        grid [checkbutton $w.chk${num} -variable expgui(ProfRef$num) \
     2000                -bg beige -activebackground beige] -row $row -column [incr col]
     2001        grid [entry $w.ent${num} \
     2002                -width 12] -row $row -column [incr col]
     2003        if {$val != ""} {
     2004            grid [button $w.def${num} -text $val -command \
     2005                    "$w.ent${num} delete 0 end; $w.ent${num} insert end $val" \
     2006                    ] -row $row -column [incr col] -sticky ew
     2007        } else {
     2008            grid [label $w.def${num} -text (none) \
     2009                    ] -row $row -column [incr col]
     2010        }
     2011        set curval {}
     2012        catch {
     2013            set curval [expr $oldval($term)]
     2014            # pretty up the number
     2015            if {$curval == 0.0} {
     2016                set curval 0.0
     2017            } elseif {abs($curval) < 1e-2 || abs($curval) > 1e6} {
     2018                set curval [format %.3e $curval]
     2019            } elseif {abs($curval) > 1e-2 && abs($curval) < 10} {
     2020                set curval [format %.5f $curval]
     2021            } elseif {abs($curval) < 9999} {
     2022                set curval [format %.2f $curval]
     2023            } elseif {abs($curval) < 1e6} {
     2024                set curval [format %.0f $curval]
     2025            }
     2026            grid [button $w.cur${num} -text $curval -command  \
     2027                    "$w.ent${num} delete 0 end; $w.ent${num} insert end $curval" \
     2028                    ] -row $row -column [incr col] -sticky ew
     2029        }
     2030        # set default values for flag and value
     2031        set ref 0
     2032        if {$setnum != ""} {
     2033            catch {
     2034                if {[profdefinfo $hist $setnum pref$num] == "Y"} {set ref 1}
     2035            }
     2036        }
     2037        set expgui(ProfRef$num) $ref
     2038       
     2039        $w.ent${num} delete 0 end
     2040        if {!$expgui(DefaultPeakType) && $val != ""} {
     2041            $w.ent${num} insert end $val
     2042        } elseif {$curval != ""} {
     2043            $w.ent${num} insert end $curval
     2044        } elseif {$val != ""} {
     2045            $w.ent${num} insert end $val
     2046        } else {
     2047            $w.ent${num} insert end 0.0
     2048        }
     2049        if {$row > $maxrow} {
     2050            set row 2
     2051            incr colstr 5
     2052        }
     2053    }
     2054}
Note: See TracChangeset for help on using the changeset viewer.