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

a bit of cleanup

File:
1 edited

Legend:

Unmodified
Added
Removed
  • 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
Note: See TracChangeset for help on using the changeset viewer.