Changeset 1152 for branches/sandbox


Ignore:
Timestamp:
Jul 6, 2011 5:23:09 PM (12 years ago)
Author:
toby
Message:

a bit of cleanup

Location:
branches/sandbox
Files:
4 edited

Legend:

Unmodified
Added
Removed

  • branches/sandbox/expgui

    r1150 r1152  
    18111811        set expgui(backtermlbl) ""
    18121812        set expgui(backtypelbl) ""
     1813        set expgui(abstypelbl) ""
    18131814        foreach var {bref bdamp absref absdamp} {
    18141815            set entrycmd($var) ""
    … …  
    18271828        set expgui(backtermlbl) ""
    18281829        set expgui(backtypelbl) ""
     1830        set expgui(abstypelbl) ""
    18291831        foreach var {bref bdamp absref absdamp} {
    18301832            set entrycmd($var) "histinfo [list $histlist] $var"
    … …  
    18561858            set entrycmd($var) "histinfo $hist $var"
    18571859            set entryvar($var) [eval $entrycmd($var)]
     1860        }
     1861        set abstype [histinfo $hist abstype]
     1862        if {$abstype > 1} {
     1863            set expgui(abstypelbl) "  Model #$abstype, values: [histinfo $hist abscor1], [histinfo $hist abscor2]"
     1864        } else {
     1865            set expgui(abstypelbl) "  Model #$abstype, value: [histinfo $hist abscor1]"
    18581866        }
    18591867    }
    … …  
    32623270    RecordMacroEntry "incr expgui(changed)" 0
    32633271    destroy $top
     3272    DisplayHistogram
    32643273}
    32653274
    … …  
    39063915            -row 2 -column 4 -sticky news -padx 4 -pady 3 -sticky e
    39073916    # Absorption information.
     3917    set expgui(abstypelbl) ""
     3918    grid [label $expgui(absBox).lbl1 \
     3919              -textvariable expgui(abstypelbl)] \
     3920            -row 1 -column 1 -columnspan 5 -sticky nws
    39083921    grid [label $expgui(absBox).rf1 -text "  Refine Abs./Refl." ] \
    3909             -row 2 -column 1 -sticky news -padx 4 -pady 3
     3922            -row 2 -column 1 -sticky news -padx 2 -pady 3
    39103923    grid [checkbutton $expgui(absBox).rf2 -text "" \
    39113924            -variable  entryvar(absref) ] \
    … …  
    39153928    tk_optionMenu $expgui(absBox).d2  entryvar(absdamp) 0 1 2 3 4 5 6 7 8 9
    39163929    grid $expgui(absBox).d2 \
    3917             -row 2 -column 4 -sticky news -padx 4 -pady 3 -sticky e
     3930        -row 2 -column 4 -sticky news -padx 4 -pady 3 -sticky e
    39183931    grid [button $expgui(absBox).edit -textvariable expgui(abslbl) \
    3919             -command editabsorption] \
    3920             -row 2 -column 5 -sticky w -padx 2 -pady 3
     3932              -command editabsorption] \
     3933        -row 2 -column 5 -sticky nsw -padx 2 -pady 3
    39213934
    39223935    #^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^END OF HISTOGRAM PANE CODE ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^

  • branches/sandbox/rb.tcl

    r1139 r1152  
    1 # test code (package already loaded in expgui)
    2 lappend auto_path [file dirname [info script]]
    3 package require La
    4 
    5 #============================================================================
    6 # rigid body EXP editing routines (to move into readexp.tcl)
    7 # RigidBodyList -- returns a list of the defined rigid body types
    8 # SetRigidBodyVar -- set variables and damping for rigid body type multipliers
    9 # ReadRigidBody  -- # of times a body is mapped, scaling factors, var #s & coordinates
    10 # RigidBodyMappingList - return a list instances where a RB is mapped in phase
    11 # RigidBodyEnableTLS -- Enable or Disable TLS use for a rigid body mapping
    12 # RigidBodySetTLS  -- change the TLS values for a rigid body mapping
    13 # RigidBodySetDamp -- change the damping values for a rigid body mapping
    14 # RigidBodyVary    -- set refinement variable numbers for a rigid body mapping
    15 # RigidBodyTLSVary -- set TLS refinement variable nums for a rigid body mapping
    16 # AddRigidBody -- defines a new rigid body type
    17 # DeleteRigidBody -- remove a rigid body definition
    18 # ReplaceRigidBody -- replaces a previous rigid body type
    19 # ReadRigidBodyMapping  -- get parameters for a rigid body mapping
    20 # MapRigidBody -- map a rigid body type into a phase
    21 # EditRigidBodyMapping -- change the parameters in a rigid body mapping
    22 # UnMapRigidBody --remove a rigid body constraint by removing a RB "instance"
    23 #----- note that these older routines should not be used ------
    24 # RigidBodyCount -- returns the number of defined rigid bodies (body types)
    25 #    use RigidBodyList instead
    26 # RigidBodyMappingCount -- # of times a rigid body is mapped in phase
    27 #    use RigidBodyMappingList instead
    28 #============================================================================
    29 # returns the number of defined rigid bodies
    30 proc RigidBodyCount {} {
    31     set n [string trim [readexp "RGBD  NRBDS"]]
    32     if {$n == ""} {
    33         set n 0
    34     }
    35     return $n
    36 }
    37 
    38 # returns a list of the defined rigid body types
    39 proc RigidBodyList {} {
    40     set n [string trim [readexp "RGBD  NRBDS"]]
    41     if {$n == ""} {
    42         set n 0
    43     }
    44     set rblist {}
    45     foreach rbnum {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
    46         set value $rbnum
    47         validint value 2
    48         set key "RGBD${value}"
    49         if {[existsexp "$key NATR "]} {
    50             lappend rblist $rbnum
    51         }
    52         if {[llength $rblist] == $n} break
    53     }
    54     return $rblist
    55 }
    56 
    57 # ReadRigidBody provides all information associated with a rigid body type
    58 #  rbnum is the rigid body type number
    59 # it returns two items:
    60 #   the number of times the rigid body is mapped
    61 #   a list containing an element for each scaling factor in rigid body #rbnum.
    62 # in each element there are four items:
    63 #    a multiplier value for the rigid body coordinates
    64 #    a damping value (0-9) for the refinement of the multiplier
    65 #    a variable number if the multiplier will be refined
    66 #    a list of cartesian coordinates coordinates
    67 # each cartesian coordinate contains 4 items: x,y,z and a label
    68 #  note that the label is present only when the RB is created in EXPGUI and is
    69 #  not used in GSAS.
    70 proc ReadRigidBody {rbnum} {
    71     if {[lsearch [RigidBodyList] $rbnum] == -1} {
    72         return ""
    73     }
    74     set value $rbnum
    75     validint value 2
    76     set key "RGBD${value}"
    77     set n [string trim [string range [readexp "$key NATR"] 0 4]]
    78     set used [string trim [string range [readexp "$key NBDS"] 0 4]]
    79     set nmult [string trim [string range [readexp "$key NSMP"] 0 4]]
    80     set out {}
    81     for {set i 1} {$i <= $nmult} {incr i} {
    82         set line [readexp "${key}${i}PARM"]
    83         set mult [string trim [string range $line 0 9]]
    84         set var [string trim [string range $line 10 14]]
    85         set damp [string trim [string range $line 15 19]]
    86         set coordlist {}
    87         for {set j 1} {$j <= $n} {incr j} {
    88             set value $j
    89             validint value 3
    90             set line [readexp "${key}${i}SC$value"]
    91             set x [string trim [string range $line 0 9]]
    92             set y [string trim [string range $line 10 19]]
    93             set z [string trim [string range $line 20 29]]
    94             set lbl [string trim [string range $line 30 39]]
    95             lappend coordlist [list $x $y $z $lbl]
    96         }
    97         lappend out [list $mult $damp $var $coordlist]
    98     }
    99     return [list $used $out]
    100 }
    101 
    102 # SetRigidBodyVar
    103 #   rbnum is the rigid body type number
    104 #   varnumlist is a list of variable numbers
    105 #      note that if this list is shorter than the number of actual multipliers
    106 #      for the body, the unspecified variable will not be changed
    107 #   damplist   is a list of damping values (0-9)
    108 #      note that if the damplist is shorter than the number of actual multipliers
    109 #      the unspecified values are not changed
    110 #  SetRigidBodVar 2 {1 2 3} {}
    111 #       will vary the (first 3) translations in body #3 and will not change the
    112 #       damping values
    113 #  SetRigidBodVar 3 {} {0 0 0}
    114 #       will not change variable settings but will change the (first 3) damping values
    115 #  SetRigidBodVar 4 {11 11} {8 8}
    116 #      changes both variable numbers and damping at the same time
    117 # Nothing is returned
    118 proc SetRigidBodyVar {rbnum varnumlist damplist} {
    119     if {[lsearch [RigidBodyList] $rbnum] == -1} {
    120         return ""
    121     }
    122     set value $rbnum
    123     validint value 2
    124     set key "RGBD${value}"
    125     set nmult [string trim [string range [readexp "$key NSMP"] 0 4]]
    126     for {set i 1} {$i <= $nmult} {incr i} {
    127         set j $i
    128         incr j -1
    129         set var [lindex $varnumlist $j]
    130         if {$var != ""} {
    131             validint var 5
    132             setexp "${key}${i}PARM" $var 11 15
    133         }
    134         set damp [lindex $damplist $j]
    135         if {$damp != ""} {
    136             if {$damp > 9} {set damp 9}
    137             if {$damp < 0} {set damp 0}
    138             validint damp 5
    139         }
    140         setexp "${key}${i}PARM" $damp 16 20
    141     }
    142 }
    143 
    144 
    145 # return the number of times rigid body $bodytyp is mapped in phase $phase
    146 proc RigidBodyMappingCount {phase bodytyp} {
    147     set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1]"
    148     if {! [existsexp "$key  NBDS"]} {return 0}
    149     set n [string trim [readexp "$key  NBDS"]]
    150     if {$n == ""} {
    151         set n 0
    152     }
    153     return $n
    154 }
    155 # return a list of the instances where rigid body $bodytyp is mapped in phase $phase
    156 proc RigidBodyMappingList {phase bodytyp} {
    157     set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1]"
    158     if {! [existsexp "$key  NBDS"]} {return {}}
    159     set n [string trim [readexp "$key  NBDS"]]
    160     if {$n == ""} {
    161         set n 0
    162     }
    163     set rblist {}
    164     foreach rbnum {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
    165         set value $rbnum
    166         validint value 2
    167         set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $rbnum 1]"
    168         if {[existsexp "$key  NDA"]} {
    169             lappend rblist $rbnum
    170         }
    171         if {[llength $rblist] == $n} break
    172     }
    173     return $rblist
    174 }
    175 
    176 
    177 
    178 # reads rigid body mapping parameters for phase ($phase), body type # ($bodytyp) and instance # ($num)
    179 # returns a list of items (most lists) as follows:
    180 #   1) sequence # of first atom in body
    181 #   2) origin of body in fractional coordinates (3 elements)
    182 #   3) Euler angles as 6 pairs of numbers (see below)
    183 #   4) variable numbers for the 9 position variables (origin followed by rotations)
    184 #   5) damping vals for the 9 position variables (origin followed by rotations)
    185 #   6) the TLS values, in order below (empty list if TLS is not in use)
    186 #   7) the variable numbers for each TLS values, in order below (or empty)
    187 #   8) three damping values for the T, L and S terms.
    188 # returns an empty list if no such body exists.
    189 #
    190 # Euler angles are a list of axes and angles to rotate:
    191 #   { {axis1 angle1} {axis2 angle2} ...}
    192 # where axis1,... can be 1, 2 or 3 corresponding to the cartesian X, Y or Z axes
    193 #
    194 # The 20 TLS terms are ordered:
    195 #    T11, T22, T33, T12, T13, T23
    196 #    L11, L22, L33, L12, L13, L23
    197 #    S12, S13, S21, S23, S31, S32, SAA, SBB
    198 #
    199 proc ReadRigidBodyMapping {phase bodytyp num} {
    200     if {[lsearch [RigidBodyMappingList $phase $bodytyp] $num] == -1} {
    201         return ""
    202     }
    203     set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $num 1]"
    204     set first [string trim [string range [readexp "$key  NDA"] 0 4]]
    205     set line [readexp "$key BDFL"]
    206     set varlist {}
    207     set damplist {}
    208     foreach i {0 1 2 3 4 5 6 7 8} {
    209         lappend varlist [string trim [string range $line [expr {5*$i}] [expr {4 + 5*$i}] ]]
    210         lappend damplist [string trim [string range $line [expr {45 + $i}] [expr {45 + $i}] ]]
    211     }
    212     set TLSdamplist {}
    213     foreach i {54 55 56} {
    214         lappend TLSdamplist [string trim [string range $line $i $i ]]
    215     }
    216     set line [readexp "${key} BDLC"]
    217     set x [string trim [string range $line 0 9]]
    218     set y [string trim [string range $line 10 19]]
    219     set z [string trim [string range $line 20 29]]
    220     set origin [list $x $y $z]
    221     set line [readexp "${key} BDOR"]
    222     set rotations {}
    223     foreach i {0 10 20 30 40 50} {
    224         set angle [string trim [string range $line $i [expr {$i+7}]]]
    225         set axis [string trim [string range $line [expr {$i+8}] [expr {$i+9}]]]
    226         lappend rotations [list $angle $axis]
    227     }
    228     set TLS [string trim [string range [readexp "${key} LSTF"] 0 4]]
    229     set tlsvars {}
    230     set tlsvals {}
    231     if {$TLS != 0} {
    232         set line [readexp "${key}TLSF1"]
    233         for {set j 0} {$j < 20} {incr j} {
    234             set var [string trim [string range $line [expr {3*$j}] [expr {3*$j+2}]]]
    235             if {$var == ""} {set var 0}
    236             lappend tlsvars $var
    237         }
    238         for {set j 0} {$j < 20} {incr j} {
    239             set i 0
    240             if {$j == 0} {
    241                 set i 1
    242             } elseif {$j == 8} {
    243                 set i 2
    244             } elseif {$j == 16} {
    245                 set i 3
    246             }
    247             if {$i != 0} {
    248                 set line [readexp "${key}TLSP$i"]
    249                 set i 0
    250                 set j1 0
    251                 set j2 7
    252             } else {
    253                 incr j1 8
    254                 incr j2 8
    255             }
    256             set val [string trim [string range $line $j1 $j2]]
    257             if {$val == ""} {set val 0}
    258             lappend tlsvals $val
    259         }
    260     }
    261     return [list $first $origin $rotations $varlist $damplist $tlsvals $tlsvars $TLSdamplist]
    262 }
    263 
    264 # Control TLS representation for phase, body # and instance number of a Rigid body mapping
    265 #   for mapping with phase ($phase), body type # ($bodytyp) and instance # ($num)
    266 # Enable TLS use if TLS is non-zero (true). Disable if zero
    267 proc RigidBodyEnableTLS {phase bodytyp num TLS} {
    268     if {[lsearch [RigidBodyMappingList $phase $bodytyp] $num] == -1} {
    269         return ""
    270     }
    271     set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $num 1]"
    272     if {$TLS} {
    273         setexp "${key} LSTF" [format "%5d" 1] 1 5
    274         if {![existsexp "${key}TLSF1"]} {makeexprec "${key}TLSF1"}
    275         if {![existsexp "${key}TLSP1"]} {
    276             makeexprec "${key}TLSP1"
    277             set str {}
    278             foreach v {.01 .01 .01 0 0 0 0 0} d {4 4 4 4 4 4 2 2} {
    279                 validreal v 8 $d
    280                 append str $v
    281             }
    282             setexp "${key}TLSP1" $str 1 64
    283         }
    284         if {![existsexp "${key}TLSP2"]} {
    285             makeexprec "${key}TLSP2"
    286             set str {}
    287             set v 0
    288             foreach d {2 2 2 2 4 4 4 4} {
    289                 validreal v 8 $d
    290                 append str $v
    291             }
    292             setexp "${key}TLSP2" $str 1 64
    293         }
    294         if {![existsexp "${key}TLSP3"]} {
    295             makeexprec "${key}TLSP3"
    296             set str {}
    297             set v 0
    298             foreach d {4 4 4 4} {
    299                 validreal v 8 $d
    300                 append str $v
    301             }
    302             setexp "${key}TLSP3" $str 1 64
    303         }
    304     } else {
    305         setexp "${key} LSTF" [format "%5d" 0] 1 5
    306     }
    307     return 1
    308 }
    309 
    310 # Control the TLS values for Rigid body mapping for mapping with
    311 #    phase ($phase), body type # ($bodytyp) and instance # ($num)
    312 # set the 20 TLS values to the values in TLSvals
    313 # There must be exactly 20 TLS terms, which are ordered:
    314 #    T11, T22, T33, T12, T13, T23
    315 #    L11, L22, L33, L12, L13, L23
    316 #    S12, S13, S21, S23, S31, S32, SAA, SBB
    317 proc RigidBodySetTLS {phase bodytyp num TLSvals} {
    318     if {[lsearch [RigidBodyMappingList $phase $bodytyp] $num] == -1} {
    319         return ""
    320     }
    321     if {[llength $TLSvals] != 20} {return ""}
    322     set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $num 1]"
    323     set TLS [string trim [string range [readexp "${key} LSTF"] 0 4]]
    324     if {$TLS == 0} {return ""}
    325     if {![existsexp "${key}TLSF1"]} {makeexprec "${key}TLSF1"}
    326     foreach n {1 2 3} {
    327         if {![existsexp "${key}TLSP$n"]} {makeexprec "${key}TLSP$n"}
    328     }
    329     set str {}
    330     set n 1
    331     set i 0
    332     foreach v $TLSvals d {4 4 4 4 4 4 2 2 2 2 2 2 4 4 4 4 4 4 4 4} {
    333         incr i
    334         validreal v 8 $d
    335         append str $v
    336         if {$i == 8} {
    337             set i 0
    338             setexp "${key}TLSP$n" $str 1 64
    339             incr n
    340             set str {}
    341         }
    342     }
    343     setexp "${key}TLSP$n" $str 1 64
    344     return 1
    345 }
    346 
    347 # set damping values for a Rigid body mapping
    348 #   for mapping with phase ($phase), body type # ($bodytyp) and instance # ($num)
    349 # there must be 9 damping values in RBdamp for the 9 position variables (origin followed by rotations)
    350 # Use of TLSdamp is optional, but to be used, TLS representation must be enabled and there must be
    351 # three damping terms (for all T terms; for all L terms and for all S terms)
    352 proc RigidBodySetDamp {phase bodytyp num RBdamp "TLSdamp {}"} {
    353     if {[lsearch [RigidBodyMappingList $phase $bodytyp] $num] == -1} {
    354         return ""
    355     }
    356     set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $num 1]"
    357     if {[llength $RBdamp] != 9} {return ""}
    358     set str {}
    359     foreach v $RBdamp {
    360         if {[validint v 1] != 1} {set v " "}
    361         append str $v
    362     }
    363     setexp "$key BDFL" $str 46 9
    364     set TLS [string trim [string range [readexp "${key} LSTF"] 0 4]]
    365     if {$TLS != 0 &&  [llength $TLSdamp] == 3} {
    366         set str {}
    367         foreach v $TLSdamp {
    368         if {[validint v 1] != 1} {set v " "}
    369             append str $v
    370         }
    371         setexp "$key BDFL" $str 55 3
    372     }
    373     return 1
    374 }
    375 
    376 # set refinement variable numbers for a Rigid body mapping
    377 #   for mapping with phase ($phase), body type # ($bodytyp) and instance # ($num)
    378 # there must be 9 variable values in RBvar for the 9 position variables (origin followed by rotations)
    379 # note that the variable values should be unique integers
    380 proc RigidBodyVary {phase bodytyp num RBvar} {
    381     if {[lsearch [RigidBodyMappingList $phase $bodytyp] $num] == -1} {
    382         return ""
    383     }
    384     set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $num 1]"
    385     if {[llength $RBvar] != 9} {return ""}
    386     set str {}
    387     foreach v $RBvar {
    388         if {[validint v 5] != 1} {set v " "}
    389         append str $v
    390     }
    391     setexp "$key BDFL" $str 1 45   
    392 }
    393 
    394 # set TLS refinement variable numbers for a Rigid body mapping
    395 #   for mapping with phase ($phase), body type # ($bodytyp) and instance # ($num)
    396 # there must be 20 variable values in TLSvar for the 20 parameters:
    397 #    T11, T22, T33, T12, T13, T23
    398 #    L11, L22, L33, L12, L13, L23
    399 #    S12, S13, S21, S23, S31, S32, SAA, SBB
    400 # note that the variable values should be unique integers
    401 proc RigidBodyTLSVary {phase bodytyp num TLSvar} {
    402     if {[lsearch [RigidBodyMappingList $phase $bodytyp] $num] == -1} {
    403         return ""
    404     }
    405     set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $num 1]"
    406     if {[llength $TLSvar] != 20} {return ""}
    407     set TLS [string trim [string range [readexp "${key} LSTF"] 0 4]]
    408     if {$TLS == 0} {return ""}
    409     set str {}
    410     foreach v $TLSvar {
    411         if {[validint v 3] != 1} {set v " "}
    412         append str $v
    413     }
    414     setexp "${key}TLSF1" $str 1 60
    415 
    416 # AddRigidBody: add a new rigid body definition into the .EXP file
    417 # arguments are:
    418 #   multlist: defines a list of multipliers for each set of coordinates. In the
    419 #             simplest case this will be {1}
    420 #   coordlist: a nested list of coordinates such as { { {0 0 0} {.1 .1 .1} {.2 .2 .2} } }
    421 # note that when the length of multlist > 1 then coordlist must have the same length.
    422 # for input where
    423 #     multlist = {s1 s2} and
    424 #     coordlist = { { {0 0 0} {1 1 0} {.0 .0 .0} ...}
    425 #                     {0 0 0} {1 1 0} {2 1 2} ...}
    426 #                 }
    427 # the cartesian coordinates are defined from the input as
    428 #    atom 1 = s1 * (0,0,0) + s2*(0,0,0) [ = (0,0,0)]
    429 #    atom 2 = s1 * (1,1,0) + s2*(1,1,0) [ = (s1+s2) * (1,1,0)]
    430 #    atom 3 = s1 * (0,0,0) + s2*(2,1,2) [ = s2 * (2,1,2)]
    431 #    ...
    432 # Returns the number of the rigid body that has been created
    433 proc AddRigidBody {multlist coordlist} {
    434     # find the first unused body #
    435     foreach rbnum {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16} {
    436         set value $rbnum
    437         validint value 2
    438         set key "RGBD${value}"
    439         if {! [existsexp "$key NATR "]} {break}
    440     }
    441     # did we go too far?
    442     if {$rbnum == 16} {return ""}
    443     # increment the RB counter
    444     set n [string trim [readexp "RGBD  NRBDS"]]
    445     if {$n == ""} {
    446         makeexprec "RGBD  NRBDS"
    447         set n 0
    448     }
    449     incr n
    450     validint n 5
    451     setexp "RGBD  NRBDS" $n 1 5
    452     SetRigidBody $rbnum $multlist $coordlist
    453     return $rbnum
    454 }
    455 
    456 # DeleteRigidBody: remove a rigid body definition from the .EXP file
    457 # The body may not be mapped. I am not sure if GSAS allows more than 9 bodies,
    458 # but if it does, the simplifed approach used here will fail, so this
    459 # is not allowed.
    460 # Input:
    461 #   Rigid body number
    462 # Returns:
    463 #   1 on success
    464 #   -1 if the body number is 11 or greater
    465 #   -2 if the body is mapped
    466 #   -3 if the body is not defined
    467 proc DeleteRigidBody {rbnum} {
    468     # can't delete bodies with numbers higher than 10, since the key prefix
    469     # (RGBD11... will overlap with rigid body instance records, which would be
    470     # deleted below
    471     if {$rbnum > 10} {
    472         return -1
    473     }
    474     set value $rbnum
    475     validint value 2
    476     set key "RGBD${value}"
    477     if {![existsexp "$key NATR "]} {
    478         return -2
    479     }
    480     # make sure the body is not mapped
    481     if {[string trim [string range [readexp "$key NBDS"] 0 4]] != 0} {
    482         return -3
    483     }
    484     # delete the records starting with "RGBD x" or "RGBD10"
    485     foreach key [array names ::exparray "${key}*"] {
    486         #puts $key
    487         delexp $key
    488     }
    489     # decrement the RB counter
    490     set n [string trim [readexp "RGBD  NRBDS"]]
    491     if {$n == ""} {
    492         set n 0
    493     }
    494     incr n -1
    495     validint n 5
    496     if {$n > 0} {
    497         setexp "RGBD  NRBDS" $n 1 5
    498     } else {
    499         delexp "RGBD  NRBDS"
    500     }
    501     return 1
    502 }
    503 
    504 # ReplaceRigidBody: replace all the information for rigid body #rbnum
    505 # Works the sames as AddRigidBody (see above) except that the rigid body is replaced rather
    506 # than added.
    507 # Note that count of the # of times the body is used is preserved
    508 proc ReplaceRigidBody {rbnum multlist coordlist {varlist ""} {damplist ""}} {
    509     set value $rbnum
    510     validint value 2
    511     set key "RGBD${value}"
    512     set line [readexp "$key NBDS"]
    513     foreach key [array names ::exparray "${key}*"] {
    514         #puts $key
    515         delexp $key
    516     }
    517     SetRigidBody $rbnum $multlist $coordlist $varlist $damplist
    518     setexp "$key NBDS" $line 1 68
    519 }
    520 
    521 # Edit the parameters for rigid body #rbnum
    522 # (normally called from ReplaceRigidBody or AddRigidBody)
    523 proc SetRigidBody {rbnum multlist coordlist {varlist ""} {damplist ""}} {
    524     set value $rbnum
    525     validint value 2
    526     set key "RGBD${value}"
    527     # number of atoms
    528     set value [llength [lindex $coordlist 0]]
    529     validint value 5
    530     makeexprec "$key NATR"
    531     setexp "$key NATR" $value 1 5
    532     # number of times used
    533     set value 0
    534     validint value 5
    535     makeexprec "$key NBDS"
    536     setexp "$key NBDS" $value 1 5
    537     # number of coordinate matrices
    538     set value [llength $multlist]
    539     validint value 5
    540     makeexprec "$key NSMP"
    541     setexp "$key NSMP" $value 1 5
    542     set i 0
    543     foreach mult $multlist coords $coordlist {
    544         set var [lindex $varlist $i]
    545         if {$var == ""} {set var 0}
    546         set damp [lindex $damplist $i]
    547         if {$damp == ""} {set damp 0}
    548         incr i
    549         makeexprec "${key}${i}PARM"
    550         setexp "${key}${i}PARM" [format "%10.5f%5d%5d" $mult $var $damp] 1 20
    551         set j 0
    552         foreach item $coords {
    553             #puts $item
    554             incr j
    555             set value $j
    556             validint value 3
    557             makeexprec "${key}${i}SC$value"
    558             if {[llength $item] == 4} {
    559                 setexp "${key}${i}SC$value" [eval format "%10.6f%10.6f%10.6f%10s" $item] 1 40
    560             } elseif {[llength $item] == 3} {
    561                 setexp "${key}${i}SC$value" [eval format "%10.6f%10.6f%10.6f" $item] 1 30
    562             } else {
    563                 return -code 3 "Invalid number of coordinates"
    564             }
    565         }
    566     }
    567 }
    568 
    569 # convert a decimal to the GSAS hex encoding with a field $digits long.
    570 proc ToHex {num digits} {
    571     return [string toupper [format "%${digits}x" $num]]
    572 }
    573 
    574 # convert a GSAS hex encoding to a decimal integer
    575 proc FromHex {hex} {
    576     return [scan $hex "%x"]
    577 }
    578 
    579 # MapRigidBody: define an "instance" of a rigid body: meaning that the coordinates
    580 # (and optionally U values) for a set of atoms will be generated from the rigid body
    581 # arguments:
    582 #   phase: phase number (1-9)
    583 #   bodytyp: number of rigid body (1-15) as returned from AddRigidBody
    584 #   firstatom: sequence number of the first atom in phase (note that atoms may
    585 #              not be numbered sequentially)
    586 #   position: list of three fractional coordinates for the origin of the rigid body coordinates
    587 #   angles: list of 3 angles to rotate the rigid body coordinates around x, y, z of the
    588 #           cartesian system before the body is translated to position.
    589 # returns the instance # (number of times body $bodytyp has been used in phase $phase)
    590 proc MapRigidBody {phase bodytyp firstatom position angles} {
    591     # find the first unused body # for this phase & type
    592     foreach rbnum {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16} {
    593         set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $rbnum 1]"
    594         if {! [existsexp "$key  NDA"]} {break}
    595     }
    596     # did we go too far?
    597     if {$rbnum == 16} {return ""}
    598     # increment number of mapped bodies of this type overall
    599     set value $bodytyp
    600     validint value 2
    601     set key "RGBD${value}"
    602     set used [string trim [string range [readexp "$key NBDS"] 0 4]]
    603     incr used
    604     set value $used
    605     validint value 5
    606     setexp "$key NBDS" $value 1 5
    607     # increment number of mapped bodies of this type in this phase
    608     set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1]"
    609     if {[existsexp "$key  NBDS"]} {
    610         set used [string trim [string range [readexp "$key  NBDS"] 0 4]]
    611     } else {
    612         makeexprec "$key  NBDS"
    613         set used 0
    614     }
    615     incr used
    616     set value $used
    617     validint value 5
    618     setexp "$key  NBDS" $value 1 5
    619     # now write the mapping parameters
    620     set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $rbnum 1]"
    621     set value $firstatom
    622     validint value 5
    623     makeexprec "$key  NDA"
    624     setexp "$key  NDA" $value 1 5
    625     set l1 {}
    626     set l2 {}
    627     for {set i 0} {$i < 9} {incr i} {
    628         append l1 [format %5d 0]
    629         append l2 [format %1d 0]
    630     }
    631     makeexprec "$key BDFL"
    632     setexp "$key BDFL" $l1$l2 1 54
    633     makeexprec "${key} BDLC"
    634     setexp "${key} BDLC" [eval format "%10.6f%10.6f%10.6f" $position] 1 30
    635     makeexprec "${key} BDOR"
    636     set l1 {}
    637     foreach val "$angles 0 0 0" dir "1 2 3 1 1 1" {
    638         append l1 [format "%8.2f%2d" $val $dir]
    639     }
    640     setexp "${key} BDOR" $l1 1 60
    641     makeexprec "${key} LSTF"
    642     setexp "${key} LSTF" [format "%5d" 0] 1 5
    643     return $rbnum
    644 }
    645 
    646 # EditRigidBodyMapping: edit parameters that define an "instance" of a rigid body (see MapRigidBody)
    647 # arguments:
    648 #   phase: phase number (1-9)
    649 #   bodytyp: number of rigid body (1-15) as returned from AddRigidBody
    650 #   bodynum: instance number, as returned by MapRigidBody
    651 #   position: list of three fractional coordinates for the origin of the rigid body coordinates
    652 #   angles: list of 3 angles to rotate the rigid body coordinates around x, y, z of the
    653 #           cartesian system before the body is translated to position.
    654 #
    655 proc EditRigidBodyMapping {phase bodytyp bodynum position angles} {
    656     # number of bodies of this type in this phase
    657     set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $bodynum 1]"
    658     setexp "${key} BDLC" [eval format "%10.6f%10.6f%10.6f" $position] 1 30
    659     set l1 {}
    660     foreach val "$angles 0 0 0" dir "1 2 3 1 1 1" {
    661         append l1 [format "%8.2f%2d" $val $dir]
    662     }
    663     setexp "${key} BDOR" $l1 1 60
    664 }
    665 
    666 # UnMapRigidBody: remove a rigid body constraint by removing a RB "instance"
    667 # (undoes MapRigidBody)
    668 # arguments:
    669 #   phase: phase number (1-9)
    670 #   bodytyp: number of rigid body (1-15) as returned from AddRigidBody
    671 #   bodynum: instance number, as returned by MapRigidBody
    672 proc UnMapRigidBody {phase bodytyp mapnum} {
    673     if {[lsearch [RigidBodyMappingList $phase $bodytyp] $mapnum] == -1} {
    674         return ""
    675     }
    676     # decrement number of mapped bodies of this type overall
    677     set value $bodytyp
    678     validint value 2
    679     set key "RGBD${value}"
    680     set used [string trim [string range [readexp "$key NBDS"] 0 4]]
    681     incr used -1
    682     set value $used
    683     validint value 5
    684     setexp "$key NBDS" $value 1 5
    685     # decrement number of mapped bodies of this type in this phase
    686     set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1]"
    687     if {[existsexp "$key  NBDS"]} {
    688         set used [string trim [string range [readexp "$key  NBDS"] 0 4]]
    689     } else {
    690         set used 0
    691     }
    692     incr used -1
    693     set value $used
    694     validint value 5
    695     if {$used > 0} {
    696         setexp "$key  NBDS" $value 1 5
    697     } else {
    698         delexp "$key  NBDS"
    699     }
    700     # now delete the mapping parameter records
    701     set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $mapnum 1]"
    702     foreach key [array names ::exparray "${key}*"] {
    703         delexp $key
    704     }
    705     return $used
    706 }
    707 
    7081#============================================================================
    7092# Rigid body utility routines

  • branches/sandbox/readexp.tcl

    r1115 r1152  
    19131913            }
    19141914            abscor2-set {
    1915                 # can't use validreal as the decimal must be in col 20
    1916                 if {[catch {
    1917                     if {abs($value) < 99.99 && abs($value) > 1.e-4} {
    1918                         set tmp [format "%15.10f" $value]
    1919                         # make a final check of decimal
    1920                         if {[string range $tmp 4 4] != "."} {
    1921                             set tmp [format "%15.6E" $value]
    1922                         }
    1923                     } else {
    1924                         set tmp [format "%15.6E" $value]
     1915                # this must have a decimal as the 5th character, so that we end up with a
     1916                # decimal point in column 20.
     1917                set tmp $value
     1918                if ![validreal tmp 12 7] {return 0}
     1919                set pos [string first "." $tmp]
     1920                while {$pos < 4} {
     1921                    set tmp " $tmp"
     1922                    set pos [string first "." $tmp]
     1923                }
     1924                if {$pos == 4} {
     1925                    setexp "${key}ABSCOR" $tmp 16 15
     1926                    return
     1927                }
     1928                catch {
     1929                    set tmp [format "%12.6E" $value]
     1930                    set pos [string first "." $tmp]
     1931                    while {$pos < 4} {
     1932                        set tmp " $tmp"
     1933                        set pos [string first "." $tmp]
    19251934                    }
    1926                 }]} {return 0}
    1927                 setexp "${key}ABSCOR" $tmp 16 15
     1935                    if {$pos == 4} {
     1936                        setexp "${key}ABSCOR" $tmp 16 15
     1937                        return
     1938                    }
     1939                }
     1940                return 0
    19281941            }
    19291942            abstype-get {
    … …  
    21692182
    21702183proc atom_constraint_read {phase} {
    2171 
    2172          set fix_list ""
    2173          foreach k {1 2 3 4 5 6 7 8 9} {
    2174                   set key [format "LEQV HOLD%1d%2d" $phase $k]
    2175                   set line [readexp $key]
    2176                   foreach j {2 10 18 26 34 42 50 58} {
    2177                            set fix_param [string range $line $j [expr $j+7]]
    2178                            if {[string trim $fix_param] == ""} {return $fix_list}
    2179                            lappend fix_list $fix_param
    2180                   }
    2181          }
     2184    set fix_list ""
     2185    foreach k {1 2 3 4 5 6 7 8 9} {
     2186        set key [format "LEQV HOLD%1d%2d" $phase $k]
     2187        set line [readexp $key]
     2188        foreach j {2 10 18 26 34 42 50 58} {
     2189            set fix_param [string range $line $j [expr $j+7]]
     2190            if {[string trim $fix_param] == ""} {return $fix_list}
     2191            lappend fix_list $fix_param
     2192        }
     2193    }
    21822194}
    21832195
    21842196# load all atom constraints into global array fix_param
    21852197proc atom_constraint_load { } {
    2186      catch {unset ::fix_param}
    2187      foreach i $::expmap(phaselist) {
    2188              set temp [atom_constraint_read $i]
    2189              foreach j $temp {
    2190                      set atomnum [string trim [string range $j 2 3]]
    2191                      set param [string trim [string range $j 4 6]]
    2192                      set ::fix_param($i,$atomnum,$param) 1
    2193 
    2194                      }
    2195      }
     2198    catch {unset ::fix_param}
     2199    foreach i $::expmap(phaselist) {
     2200        set temp [atom_constraint_read $i]
     2201        foreach j $temp {
     2202            set atomnum [string trim [string range $j 2 3]]
     2203            set param [string trim [string range $j 4 6]]
     2204            set ::fix_param($i,$atomnum,$param) 1   
     2205        }
     2206    }
    21962207}
    21972208
    21982209proc atom_constraint_write {phase fix_list} {
    2199 
    2200      foreach key [array names ::exparray "LEQV HOLD$phase*"] {
    2201              delexp $key
    2202      }
    2203      set k 0
    2204      set j 1
    2205      set line ""
    2206      foreach fix $fix_list {
    2207              incr k
    2208              append line $fix
    2209              if {$k == 8} {
    2210                 set key [format "LEQV HOLD%1d%2d" $phase $j]
    2211                 makeexprec $key
    2212                 setexp $key $line 3 [expr ($k * 8) + 2]
    2213                 set k 0
    2214                 incr j
    2215                 set line ""
    2216              }
    2217      }
    2218      if {$line != ""} {
     2210    foreach key [array names ::exparray "LEQV HOLD$phase*"] {
     2211        delexp $key
     2212    }
     2213    set k 0
     2214    set j 1
     2215    set line ""
     2216    foreach fix $fix_list {
     2217        incr k
     2218        append line $fix
     2219        if {$k == 8} {
     2220            set key [format "LEQV HOLD%1d%2d" $phase $j]
     2221            makeexprec $key
     2222            setexp $key $line 3 [expr ($k * 8) + 2]
     2223            set k 0
     2224            incr j
     2225            set line ""
     2226        }
     2227    }
     2228    if {$line != ""} {
    22192229        set key [format "LEQV HOLD%1d%2d" $phase $j]
    22202230        makeexprec $key
    22212231        setexp $key $line 3 [expr ($k * 8) + 2]
    2222      }
    2223 
    2224 }
    2225 
     2232    }   
     2233}
    22262234
    22272235
    … …  
    35043512    }
    35053513}
     3514#============================================================================
     3515# rigid body EXP editing routines (to move into readexp.tcl)
     3516# RigidBodyList -- returns a list of the defined rigid body types
     3517# SetRigidBodyVar -- set variables and damping for rigid body type multipliers
     3518# ReadRigidBody  -- # of times a body is mapped, scaling factors, var #s & coordinates
     3519# RigidBodyMappingList - return a list instances where a RB is mapped in phase
     3520# RigidBodyEnableTLS -- Enable or Disable TLS use for a rigid body mapping
     3521# RigidBodySetTLS  -- change the TLS values for a rigid body mapping
     3522# RigidBodySetDamp -- change the damping values for a rigid body mapping
     3523# RigidBodyVary    -- set refinement variable numbers for a rigid body mapping
     3524# RigidBodyTLSVary -- set TLS refinement variable nums for a rigid body mapping
     3525# AddRigidBody -- defines a new rigid body type
     3526# DeleteRigidBody -- remove a rigid body definition
     3527# ReplaceRigidBody -- replaces a previous rigid body type
     3528# ReadRigidBodyMapping  -- get parameters for a rigid body mapping
     3529# MapRigidBody -- map a rigid body type into a phase
     3530# EditRigidBodyMapping -- change the parameters in a rigid body mapping
     3531# UnMapRigidBody --remove a rigid body constraint by removing a RB "instance"
     3532#----- note that these older routines should not be used ------
     3533# RigidBodyCount -- returns the number of defined rigid bodies (body types)
     3534#    use RigidBodyList instead
     3535# RigidBodyMappingCount -- # of times a rigid body is mapped in phase
     3536#    use RigidBodyMappingList instead
     3537#============================================================================
     3538# returns the number of defined rigid bodies
     3539proc RigidBodyCount {} {
     3540    set n [string trim [readexp "RGBD  NRBDS"]]
     3541    if {$n == ""} {
     3542        set n 0
     3543    }
     3544    return $n
     3545}
     3546
     3547# returns a list of the defined rigid body types
     3548proc RigidBodyList {} {
     3549    set n [string trim [readexp "RGBD  NRBDS"]]
     3550    if {$n == ""} {
     3551        set n 0
     3552    }
     3553    set rblist {}
     3554    foreach rbnum {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
     3555        set value $rbnum
     3556        validint value 2
     3557        set key "RGBD${value}"
     3558        if {[existsexp "$key NATR "]} {
     3559            lappend rblist $rbnum
     3560        }
     3561        if {[llength $rblist] == $n} break
     3562    }
     3563    return $rblist
     3564}
     3565
     3566# ReadRigidBody provides all information associated with a rigid body type
     3567#  rbnum is the rigid body type number
     3568# it returns two items:
     3569#   the number of times the rigid body is mapped
     3570#   a list containing an element for each scaling factor in rigid body #rbnum.
     3571# in each element there are four items:
     3572#    a multiplier value for the rigid body coordinates
     3573#    a damping value (0-9) for the refinement of the multiplier
     3574#    a variable number if the multiplier will be refined
     3575#    a list of cartesian coordinates coordinates
     3576# each cartesian coordinate contains 4 items: x,y,z and a label
     3577#  note that the label is present only when the RB is created in EXPGUI and is
     3578#  not used in GSAS.
     3579proc ReadRigidBody {rbnum} {
     3580    if {[lsearch [RigidBodyList] $rbnum] == -1} {
     3581        return ""
     3582    }
     3583    set value $rbnum
     3584    validint value 2
     3585    set key "RGBD${value}"
     3586    set n [string trim [string range [readexp "$key NATR"] 0 4]]
     3587    set used [string trim [string range [readexp "$key NBDS"] 0 4]]
     3588    set nmult [string trim [string range [readexp "$key NSMP"] 0 4]]
     3589    set out {}
     3590    for {set i 1} {$i <= $nmult} {incr i} {
     3591        set line [readexp "${key}${i}PARM"]
     3592        set mult [string trim [string range $line 0 9]]
     3593        set var [string trim [string range $line 10 14]]
     3594        set damp [string trim [string range $line 15 19]]
     3595        set coordlist {}
     3596        for {set j 1} {$j <= $n} {incr j} {
     3597            set value $j
     3598            validint value 3
     3599            set line [readexp "${key}${i}SC$value"]
     3600            set x [string trim [string range $line 0 9]]
     3601            set y [string trim [string range $line 10 19]]
     3602            set z [string trim [string range $line 20 29]]
     3603            set lbl [string trim [string range $line 30 39]]
     3604            lappend coordlist [list $x $y $z $lbl]
     3605        }
     3606        lappend out [list $mult $damp $var $coordlist]
     3607    }
     3608    return [list $used $out]
     3609}
     3610
     3611# SetRigidBodyVar
     3612#   rbnum is the rigid body type number
     3613#   varnumlist is a list of variable numbers
     3614#      note that if this list is shorter than the number of actual multipliers
     3615#      for the body, the unspecified variable will not be changed
     3616#   damplist   is a list of damping values (0-9)
     3617#      note that if the damplist is shorter than the number of actual multipliers
     3618#      the unspecified values are not changed
     3619#  SetRigidBodVar 2 {1 2 3} {}
     3620#       will vary the (first 3) translations in body #3 and will not change the
     3621#       damping values
     3622#  SetRigidBodVar 3 {} {0 0 0}
     3623#       will not change variable settings but will change the (first 3) damping values
     3624#  SetRigidBodVar 4 {11 11} {8 8}
     3625#      changes both variable numbers and damping at the same time
     3626# Nothing is returned
     3627proc SetRigidBodyVar {rbnum varnumlist damplist} {
     3628    if {[lsearch [RigidBodyList] $rbnum] == -1} {
     3629        return ""
     3630    }
     3631    set value $rbnum
     3632    validint value 2
     3633    set key "RGBD${value}"
     3634    set nmult [string trim [string range [readexp "$key NSMP"] 0 4]]
     3635    for {set i 1} {$i <= $nmult} {incr i} {
     3636        set j $i
     3637        incr j -1
     3638        set var [lindex $varnumlist $j]
     3639        if {$var != ""} {
     3640            validint var 5
     3641            setexp "${key}${i}PARM" $var 11 15
     3642        }
     3643        set damp [lindex $damplist $j]
     3644        if {$damp != ""} {
     3645            if {$damp > 9} {set damp 9}
     3646            if {$damp < 0} {set damp 0}
     3647            validint damp 5
     3648        }
     3649        setexp "${key}${i}PARM" $damp 16 20
     3650    }
     3651}
     3652
     3653
     3654# return the number of times rigid body $bodytyp is mapped in phase $phase
     3655proc RigidBodyMappingCount {phase bodytyp} {
     3656    set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1]"
     3657    if {! [existsexp "$key  NBDS"]} {return 0}
     3658    set n [string trim [readexp "$key  NBDS"]]
     3659    if {$n == ""} {
     3660        set n 0
     3661    }
     3662    return $n
     3663}
     3664# return a list of the instances where rigid body $bodytyp is mapped in phase $phase
     3665proc RigidBodyMappingList {phase bodytyp} {
     3666    set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1]"
     3667    if {! [existsexp "$key  NBDS"]} {return {}}
     3668    set n [string trim [readexp "$key  NBDS"]]
     3669    if {$n == ""} {
     3670        set n 0
     3671    }
     3672    set rblist {}
     3673    foreach rbnum {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
     3674        set value $rbnum
     3675        validint value 2
     3676        set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $rbnum 1]"
     3677        if {[existsexp "$key  NDA"]} {
     3678            lappend rblist $rbnum
     3679        }
     3680        if {[llength $rblist] == $n} break
     3681    }
     3682    return $rblist
     3683}
     3684
     3685
     3686
     3687# reads rigid body mapping parameters for phase ($phase), body type # ($bodytyp) and instance # ($num)
     3688# returns a list of items (most lists) as follows:
     3689#   1) sequence # of first atom in body
     3690#   2) origin of body in fractional coordinates (3 elements)
     3691#   3) Euler angles as 6 pairs of numbers (see below)
     3692#   4) variable numbers for the 9 position variables (origin followed by rotations)
     3693#   5) damping vals for the 9 position variables (origin followed by rotations)
     3694#   6) the TLS values, in order below (empty list if TLS is not in use)
     3695#   7) the variable numbers for each TLS values, in order below (or empty)
     3696#   8) three damping values for the T, L and S terms.
     3697# returns an empty list if no such body exists.
     3698#
     3699# Euler angles are a list of axes and angles to rotate:
     3700#   { {axis1 angle1} {axis2 angle2} ...}
     3701# where axis1,... can be 1, 2 or 3 corresponding to the cartesian X, Y or Z axes
     3702#
     3703# The 20 TLS terms are ordered:
     3704#    T11, T22, T33, T12, T13, T23
     3705#    L11, L22, L33, L12, L13, L23
     3706#    S12, S13, S21, S23, S31, S32, SAA, SBB
     3707#
     3708proc ReadRigidBodyMapping {phase bodytyp num} {
     3709    if {[lsearch [RigidBodyMappingList $phase $bodytyp] $num] == -1} {
     3710        return ""
     3711    }
     3712    set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $num 1]"
     3713    set first [string trim [string range [readexp "$key  NDA"] 0 4]]
     3714    set line [readexp "$key BDFL"]
     3715    set varlist {}
     3716    set damplist {}
     3717    foreach i {0 1 2 3 4 5 6 7 8} {
     3718        lappend varlist [string trim [string range $line [expr {5*$i}] [expr {4 + 5*$i}] ]]
     3719        lappend damplist [string trim [string range $line [expr {45 + $i}] [expr {45 + $i}] ]]
     3720    }
     3721    set TLSdamplist {}
     3722    foreach i {54 55 56} {
     3723        lappend TLSdamplist [string trim [string range $line $i $i ]]
     3724    }
     3725    set line [readexp "${key} BDLC"]
     3726    set x [string trim [string range $line 0 9]]
     3727    set y [string trim [string range $line 10 19]]
     3728    set z [string trim [string range $line 20 29]]
     3729    set origin [list $x $y $z]
     3730    set line [readexp "${key} BDOR"]
     3731    set rotations {}
     3732    foreach i {0 10 20 30 40 50} {
     3733        set angle [string trim [string range $line $i [expr {$i+7}]]]
     3734        set axis [string trim [string range $line [expr {$i+8}] [expr {$i+9}]]]
     3735        lappend rotations [list $angle $axis]
     3736    }
     3737    set TLS [string trim [string range [readexp "${key} LSTF"] 0 4]]
     3738    set tlsvars {}
     3739    set tlsvals {}
     3740    if {$TLS != 0} {
     3741        set line [readexp "${key}TLSF1"]
     3742        for {set j 0} {$j < 20} {incr j} {
     3743            set var [string trim [string range $line [expr {3*$j}] [expr {3*$j+2}]]]
     3744            if {$var == ""} {set var 0}
     3745            lappend tlsvars $var
     3746        }
     3747        for {set j 0} {$j < 20} {incr j} {
     3748            set i 0
     3749            if {$j == 0} {
     3750                set i 1
     3751            } elseif {$j == 8} {
     3752                set i 2
     3753            } elseif {$j == 16} {
     3754                set i 3
     3755            }
     3756            if {$i != 0} {
     3757                set line [readexp "${key}TLSP$i"]
     3758                set i 0
     3759                set j1 0
     3760                set j2 7
     3761            } else {
     3762                incr j1 8
     3763                incr j2 8
     3764            }
     3765            set val [string trim [string range $line $j1 $j2]]
     3766            if {$val == ""} {set val 0}
     3767            lappend tlsvals $val
     3768        }
     3769    }
     3770    return [list $first $origin $rotations $varlist $damplist $tlsvals $tlsvars $TLSdamplist]
     3771}
     3772
     3773# Control TLS representation for phase, body # and instance number of a Rigid body mapping
     3774#   for mapping with phase ($phase), body type # ($bodytyp) and instance # ($num)
     3775# Enable TLS use if TLS is non-zero (true). Disable if zero
     3776proc RigidBodyEnableTLS {phase bodytyp num TLS} {
     3777    if {[lsearch [RigidBodyMappingList $phase $bodytyp] $num] == -1} {
     3778        return ""
     3779    }
     3780    set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $num 1]"
     3781    if {$TLS} {
     3782        setexp "${key} LSTF" [format "%5d" 1] 1 5
     3783        if {![existsexp "${key}TLSF1"]} {makeexprec "${key}TLSF1"}
     3784        if {![existsexp "${key}TLSP1"]} {
     3785            makeexprec "${key}TLSP1"
     3786            set str {}
     3787            foreach v {.01 .01 .01 0 0 0 0 0} d {4 4 4 4 4 4 2 2} {
     3788                validreal v 8 $d
     3789                append str $v
     3790            }
     3791            setexp "${key}TLSP1" $str 1 64
     3792        }
     3793        if {![existsexp "${key}TLSP2"]} {
     3794            makeexprec "${key}TLSP2"
     3795            set str {}
     3796            set v 0
     3797            foreach d {2 2 2 2 4 4 4 4} {
     3798                validreal v 8 $d
     3799                append str $v
     3800            }
     3801            setexp "${key}TLSP2" $str 1 64
     3802        }
     3803        if {![existsexp "${key}TLSP3"]} {
     3804            makeexprec "${key}TLSP3"
     3805            set str {}
     3806            set v 0
     3807            foreach d {4 4 4 4} {
     3808                validreal v 8 $d
     3809                append str $v
     3810            }
     3811            setexp "${key}TLSP3" $str 1 64
     3812        }
     3813    } else {
     3814        setexp "${key} LSTF" [format "%5d" 0] 1 5
     3815    }
     3816    return 1
     3817}
     3818
     3819# Control the TLS values for Rigid body mapping for mapping with
     3820#    phase ($phase), body type # ($bodytyp) and instance # ($num)
     3821# set the 20 TLS values to the values in TLSvals
     3822# There must be exactly 20 TLS terms, which are ordered:
     3823#    T11, T22, T33, T12, T13, T23
     3824#    L11, L22, L33, L12, L13, L23
     3825#    S12, S13, S21, S23, S31, S32, SAA, SBB
     3826proc RigidBodySetTLS {phase bodytyp num TLSvals} {
     3827    if {[lsearch [RigidBodyMappingList $phase $bodytyp] $num] == -1} {
     3828        return ""
     3829    }
     3830    if {[llength $TLSvals] != 20} {return ""}
     3831    set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $num 1]"
     3832    set TLS [string trim [string range [readexp "${key} LSTF"] 0 4]]
     3833    if {$TLS == 0} {return ""}
     3834    if {![existsexp "${key}TLSF1"]} {makeexprec "${key}TLSF1"}
     3835    foreach n {1 2 3} {
     3836        if {![existsexp "${key}TLSP$n"]} {makeexprec "${key}TLSP$n"}
     3837    }
     3838    set str {}
     3839    set n 1
     3840    set i 0
     3841    foreach v $TLSvals d {4 4 4 4 4 4 2 2 2 2 2 2 4 4 4 4 4 4 4 4} {
     3842        incr i
     3843        validreal v 8 $d
     3844        append str $v
     3845        if {$i == 8} {
     3846            set i 0
     3847            setexp "${key}TLSP$n" $str 1 64
     3848            incr n
     3849            set str {}
     3850        }
     3851    }
     3852    setexp "${key}TLSP$n" $str 1 64
     3853    return 1
     3854}
     3855
     3856# set damping values for a Rigid body mapping
     3857#   for mapping with phase ($phase), body type # ($bodytyp) and instance # ($num)
     3858# there must be 9 damping values in RBdamp for the 9 position variables (origin followed by rotations)
     3859# Use of TLSdamp is optional, but to be used, TLS representation must be enabled and there must be
     3860# three damping terms (for all T terms; for all L terms and for all S terms)
     3861proc RigidBodySetDamp {phase bodytyp num RBdamp "TLSdamp {}"} {
     3862    if {[lsearch [RigidBodyMappingList $phase $bodytyp] $num] == -1} {
     3863        return ""
     3864    }
     3865    set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $num 1]"
     3866    if {[llength $RBdamp] != 9} {return ""}
     3867    set str {}
     3868    foreach v $RBdamp {
     3869        if {[validint v 1] != 1} {set v " "}
     3870        append str $v
     3871    }
     3872    setexp "$key BDFL" $str 46 9
     3873    set TLS [string trim [string range [readexp "${key} LSTF"] 0 4]]
     3874    if {$TLS != 0 &&  [llength $TLSdamp] == 3} {
     3875        set str {}
     3876        foreach v $TLSdamp {
     3877        if {[validint v 1] != 1} {set v " "}
     3878            append str $v
     3879        }
     3880        setexp "$key BDFL" $str 55 3
     3881    }
     3882    return 1
     3883}
     3884
     3885# set refinement variable numbers for a Rigid body mapping
     3886#   for mapping with phase ($phase), body type # ($bodytyp) and instance # ($num)
     3887# there must be 9 variable values in RBvar for the 9 position variables (origin followed by rotations)
     3888# note that the variable values should be unique integers
     3889proc RigidBodyVary {phase bodytyp num RBvar} {
     3890    if {[lsearch [RigidBodyMappingList $phase $bodytyp] $num] == -1} {
     3891        return ""
     3892    }
     3893    set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $num 1]"
     3894    if {[llength $RBvar] != 9} {return ""}
     3895    set str {}
     3896    foreach v $RBvar {
     3897        if {[validint v 5] != 1} {set v " "}
     3898        append str $v
     3899    }
     3900    setexp "$key BDFL" $str 1 45   
     3901}
     3902
     3903# set TLS refinement variable numbers for a Rigid body mapping
     3904#   for mapping with phase ($phase), body type # ($bodytyp) and instance # ($num)
     3905# there must be 20 variable values in TLSvar for the 20 parameters:
     3906#    T11, T22, T33, T12, T13, T23
     3907#    L11, L22, L33, L12, L13, L23
     3908#    S12, S13, S21, S23, S31, S32, SAA, SBB
     3909# note that the variable values should be unique integers
     3910proc RigidBodyTLSVary {phase bodytyp num TLSvar} {
     3911    if {[lsearch [RigidBodyMappingList $phase $bodytyp] $num] == -1} {
     3912        return ""
     3913    }
     3914    set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $num 1]"
     3915    if {[llength $TLSvar] != 20} {return ""}
     3916    set TLS [string trim [string range [readexp "${key} LSTF"] 0 4]]
     3917    if {$TLS == 0} {return ""}
     3918    set str {}
     3919    foreach v $TLSvar {
     3920        if {[validint v 3] != 1} {set v " "}
     3921        append str $v
     3922    }
     3923    setexp "${key}TLSF1" $str 1 60
     3924
     3925# AddRigidBody: add a new rigid body definition into the .EXP file
     3926# arguments are:
     3927#   multlist: defines a list of multipliers for each set of coordinates. In the
     3928#             simplest case this will be {1}
     3929#   coordlist: a nested list of coordinates such as { { {0 0 0} {.1 .1 .1} {.2 .2 .2} } }
     3930# note that when the length of multlist > 1 then coordlist must have the same length.
     3931# for input where
     3932#     multlist = {s1 s2} and
     3933#     coordlist = { { {0 0 0} {1 1 0} {.0 .0 .0} ...}
     3934#                     {0 0 0} {1 1 0} {2 1 2} ...}
     3935#                 }
     3936# the cartesian coordinates are defined from the input as
     3937#    atom 1 = s1 * (0,0,0) + s2*(0,0,0) [ = (0,0,0)]
     3938#    atom 2 = s1 * (1,1,0) + s2*(1,1,0) [ = (s1+s2) * (1,1,0)]
     3939#    atom 3 = s1 * (0,0,0) + s2*(2,1,2) [ = s2 * (2,1,2)]
     3940#    ...
     3941# Returns the number of the rigid body that has been created
     3942proc AddRigidBody {multlist coordlist} {
     3943    # find the first unused body #
     3944    foreach rbnum {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16} {
     3945        set value $rbnum
     3946        validint value 2
     3947        set key "RGBD${value}"
     3948        if {! [existsexp "$key NATR "]} {break}
     3949    }
     3950    # did we go too far?
     3951    if {$rbnum == 16} {return ""}
     3952    # increment the RB counter
     3953    set n [string trim [readexp "RGBD  NRBDS"]]
     3954    if {$n == ""} {
     3955        makeexprec "RGBD  NRBDS"
     3956        set n 0
     3957    }
     3958    incr n
     3959    validint n 5
     3960    setexp "RGBD  NRBDS" $n 1 5
     3961    SetRigidBody $rbnum $multlist $coordlist
     3962    return $rbnum
     3963}
     3964
     3965# DeleteRigidBody: remove a rigid body definition from the .EXP file
     3966# The body may not be mapped. I am not sure if GSAS allows more than 9 bodies,
     3967# but if it does, the simplifed approach used here will fail, so this
     3968# is not allowed.
     3969# Input:
     3970#   Rigid body number
     3971# Returns:
     3972#   1 on success
     3973#   -1 if the body number is 11 or greater
     3974#   -2 if the body is mapped
     3975#   -3 if the body is not defined
     3976proc DeleteRigidBody {rbnum} {
     3977    # can't delete bodies with numbers higher than 10, since the key prefix
     3978    # (RGBD11... will overlap with rigid body instance records, which would be
     3979    # deleted below
     3980    if {$rbnum > 10} {
     3981        return -1
     3982    }
     3983    set value $rbnum
     3984    validint value 2
     3985    set key "RGBD${value}"
     3986    if {![existsexp "$key NATR "]} {
     3987        return -2
     3988    }
     3989    # make sure the body is not mapped
     3990    if {[string trim [string range [readexp "$key NBDS"] 0 4]] != 0} {
     3991        return -3
     3992    }
     3993    # delete the records starting with "RGBD x" or "RGBD10"
     3994    foreach key [array names ::exparray "${key}*"] {
     3995        #puts $key
     3996        delexp $key
     3997    }
     3998    # decrement the RB counter
     3999    set n [string trim [readexp "RGBD  NRBDS"]]
     4000    if {$n == ""} {
     4001        set n 0
     4002    }
     4003    incr n -1
     4004    validint n 5
     4005    if {$n > 0} {
     4006        setexp "RGBD  NRBDS" $n 1 5
     4007    } else {
     4008        delexp "RGBD  NRBDS"
     4009    }
     4010    return 1
     4011}
     4012
     4013# ReplaceRigidBody: replace all the information for rigid body #rbnum
     4014# Works the sames as AddRigidBody (see above) except that the rigid body is replaced rather
     4015# than added.
     4016# Note that count of the # of times the body is used is preserved
     4017proc ReplaceRigidBody {rbnum multlist coordlist {varlist ""} {damplist ""}} {
     4018    set value $rbnum
     4019    validint value 2
     4020    set key "RGBD${value}"
     4021    set line [readexp "$key NBDS"]
     4022    foreach key [array names ::exparray "${key}*"] {
     4023        #puts $key
     4024        delexp $key
     4025    }
     4026    SetRigidBody $rbnum $multlist $coordlist $varlist $damplist
     4027    setexp "$key NBDS" $line 1 68
     4028}
     4029
     4030# Edit the parameters for rigid body #rbnum
     4031# (normally called from ReplaceRigidBody or AddRigidBody)
     4032proc SetRigidBody {rbnum multlist coordlist {varlist ""} {damplist ""}} {
     4033    set value $rbnum
     4034    validint value 2
     4035    set key "RGBD${value}"
     4036    # number of atoms
     4037    set value [llength [lindex $coordlist 0]]
     4038    validint value 5
     4039    makeexprec "$key NATR"
     4040    setexp "$key NATR" $value 1 5
     4041    # number of times used
     4042    set value 0
     4043    validint value 5
     4044    makeexprec "$key NBDS"
     4045    setexp "$key NBDS" $value 1 5
     4046    # number of coordinate matrices
     4047    set value [llength $multlist]
     4048    validint value 5
     4049    makeexprec "$key NSMP"
     4050    setexp "$key NSMP" $value 1 5
     4051    set i 0
     4052    foreach mult $multlist coords $coordlist {
     4053        set var [lindex $varlist $i]
     4054        if {$var == ""} {set var 0}
     4055        set damp [lindex $damplist $i]
     4056        if {$damp == ""} {set damp 0}
     4057        incr i
     4058        makeexprec "${key}${i}PARM"
     4059        setexp "${key}${i}PARM" [format "%10.5f%5d%5d" $mult $var $damp] 1 20
     4060        set j 0
     4061        foreach item $coords {
     4062            #puts $item
     4063            incr j
     4064            set value $j
     4065            validint value 3
     4066            makeexprec "${key}${i}SC$value"
     4067            if {[llength $item] == 4} {
     4068                setexp "${key}${i}SC$value" [eval format "%10.6f%10.6f%10.6f%10s" $item] 1 40
     4069            } elseif {[llength $item] == 3} {
     4070                setexp "${key}${i}SC$value" [eval format "%10.6f%10.6f%10.6f" $item] 1 30
     4071            } else {
     4072                return -code 3 "Invalid number of coordinates"
     4073            }
     4074        }
     4075    }
     4076}
     4077
     4078# convert a decimal to the GSAS hex encoding with a field $digits long.
     4079proc ToHex {num digits} {
     4080    return [string toupper [format "%${digits}x" $num]]
     4081}
     4082
     4083# convert a GSAS hex encoding to a decimal integer
     4084proc FromHex {hex} {
     4085    return [scan $hex "%x"]
     4086}
     4087
     4088# MapRigidBody: define an "instance" of a rigid body: meaning that the coordinates
     4089# (and optionally U values) for a set of atoms will be generated from the rigid body
     4090# arguments:
     4091#   phase: phase number (1-9)
     4092#   bodytyp: number of rigid body (1-15) as returned from AddRigidBody
     4093#   firstatom: sequence number of the first atom in phase (note that atoms may
     4094#              not be numbered sequentially)
     4095#   position: list of three fractional coordinates for the origin of the rigid body coordinates
     4096#   angles: list of 3 angles to rotate the rigid body coordinates around x, y, z of the
     4097#           cartesian system before the body is translated to position.
     4098# returns the instance # (number of times body $bodytyp has been used in phase $phase)
     4099proc MapRigidBody {phase bodytyp firstatom position angles} {
     4100    # find the first unused body # for this phase & type
     4101    foreach rbnum {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16} {
     4102        set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $rbnum 1]"
     4103        if {! [existsexp "$key  NDA"]} {break}
     4104    }
     4105    # did we go too far?
     4106    if {$rbnum == 16} {return ""}
     4107    # increment number of mapped bodies of this type overall
     4108    set value $bodytyp
     4109    validint value 2
     4110    set key "RGBD${value}"
     4111    set used [string trim [string range [readexp "$key NBDS"] 0 4]]
     4112    incr used
     4113    set value $used
     4114    validint value 5
     4115    setexp "$key NBDS" $value 1 5
     4116    # increment number of mapped bodies of this type in this phase
     4117    set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1]"
     4118    if {[existsexp "$key  NBDS"]} {
     4119        set used [string trim [string range [readexp "$key  NBDS"] 0 4]]
     4120    } else {
     4121        makeexprec "$key  NBDS"
     4122        set used 0
     4123    }
     4124    incr used
     4125    set value $used
     4126    validint value 5
     4127    setexp "$key  NBDS" $value 1 5
     4128    # now write the mapping parameters
     4129    set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $rbnum 1]"
     4130    set value $firstatom
     4131    validint value 5
     4132    makeexprec "$key  NDA"
     4133    setexp "$key  NDA" $value 1 5
     4134    set l1 {}
     4135    set l2 {}
     4136    for {set i 0} {$i < 9} {incr i} {
     4137        append l1 [format %5d 0]
     4138        append l2 [format %1d 0]
     4139    }
     4140    makeexprec "$key BDFL"
     4141    setexp "$key BDFL" $l1$l2 1 54
     4142    makeexprec "${key} BDLC"
     4143    setexp "${key} BDLC" [eval format "%10.6f%10.6f%10.6f" $position] 1 30
     4144    makeexprec "${key} BDOR"
     4145    set l1 {}
     4146    foreach val "$angles 0 0 0" dir "1 2 3 1 1 1" {
     4147        append l1 [format "%8.2f%2d" $val $dir]
     4148    }
     4149    setexp "${key} BDOR" $l1 1 60
     4150    makeexprec "${key} LSTF"
     4151    setexp "${key} LSTF" [format "%5d" 0] 1 5
     4152    return $rbnum
     4153}
     4154
     4155# EditRigidBodyMapping: edit parameters that define an "instance" of a rigid body (see MapRigidBody)
     4156# arguments:
     4157#   phase: phase number (1-9)
     4158#   bodytyp: number of rigid body (1-15) as returned from AddRigidBody
     4159#   bodynum: instance number, as returned by MapRigidBody
     4160#   position: list of three fractional coordinates for the origin of the rigid body coordinates
     4161#   angles: list of 3 angles to rotate the rigid body coordinates around x, y, z of the
     4162#           cartesian system before the body is translated to position.
     4163#
     4164proc EditRigidBodyMapping {phase bodytyp bodynum position angles} {
     4165    # number of bodies of this type in this phase
     4166    set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $bodynum 1]"
     4167    setexp "${key} BDLC" [eval format "%10.6f%10.6f%10.6f" $position] 1 30
     4168    set l1 {}
     4169    foreach val "$angles 0 0 0" dir "1 2 3 1 1 1" {
     4170        append l1 [format "%8.2f%2d" $val $dir]
     4171    }
     4172    setexp "${key} BDOR" $l1 1 60
     4173}
     4174
     4175# UnMapRigidBody: remove a rigid body constraint by removing a RB "instance"
     4176# (undoes MapRigidBody)
     4177# arguments:
     4178#   phase: phase number (1-9)
     4179#   bodytyp: number of rigid body (1-15) as returned from AddRigidBody
     4180#   bodynum: instance number, as returned by MapRigidBody
     4181proc UnMapRigidBody {phase bodytyp mapnum} {
     4182    if {[lsearch [RigidBodyMappingList $phase $bodytyp] $mapnum] == -1} {
     4183        return ""
     4184    }
     4185    # decrement number of mapped bodies of this type overall
     4186    set value $bodytyp
     4187    validint value 2
     4188    set key "RGBD${value}"
     4189    set used [string trim [string range [readexp "$key NBDS"] 0 4]]
     4190    incr used -1
     4191    set value $used
     4192    validint value 5
     4193    setexp "$key NBDS" $value 1 5
     4194    # decrement number of mapped bodies of this type in this phase
     4195    set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1]"
     4196    if {[existsexp "$key  NBDS"]} {
     4197        set used [string trim [string range [readexp "$key  NBDS"] 0 4]]
     4198    } else {
     4199        set used 0
     4200    }
     4201    incr used -1
     4202    set value $used
     4203    validint value 5
     4204    if {$used > 0} {
     4205        setexp "$key  NBDS" $value 1 5
     4206    } else {
     4207        delexp "$key  NBDS"
     4208    }
     4209    # now delete the mapping parameter records
     4210    set key "RGBD[ToHex $phase 1][ToHex $bodytyp 1][ToHex $mapnum 1]"
     4211    foreach key [array names ::exparray "${key}*"] {
     4212        delexp $key
     4213    }
     4214    return $used
     4215}
     4216

  • branches/sandbox/rigid.tcl

    r1146 r1152  
    8686    source c:/gsas/sandboxexpgui/readexp.tcl
    8787    source c:/gsas/sandboxexpgui/gsascmds.tcl
     88    # test code (package already loaded in expgui)
     89    lappend auto_path [file dirname [info script]]
     90    package require La
    8891    source C:/gsas/sandboxexpgui/rb.tcl
    8992#    puts beforeread
Note: See TracChangeset for help on using the changeset viewer.