Changeset 252

Timestamp:

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

Author:

toby

Message:

# on 2000/08/04 18:19:37, toby did:
redo error msgs
phaseinfo: change atoms and spacegroup
atominfo: change iso/aniso flag
new routine: SetPhaseFlag? (control which phases are used in a histogram)
new routine: EraseAtom?

File:

• trunk/readexp.tcl (modified) (13 diffs, 3 props)

trunk/readexp.tcl

@@ -122 +122 @@
             if {$line == ""} {
                 set msg "No HTYP$n entry for Histogram $ihist. This is an invalid .EXP file"
-                tk_dialog .badexp "Error in EXP" $msg error 0 Exit 
-                destroy .
+                tk_dialog .badexp "Error in readexp" $msg error 0 Exit 
             }
             set j 0
@@ -148 +147 @@
         if {$line == ""} {
             set msg "No NPHAS entry for Histogram $ihist. This is an invalid .EXP file"
-            tk_dialog .badexp "Error in EXP" $msg error 0 Exit 
-            destroy .
+            tk_dialog .badexp "Error in readexp" $msg error 0 Exit 
         }
         set expmap(phaselist_$ihist) {}
@@ -321 +319 @@
         default {
             set msg "Unsupported expinfo access: parm=$parm action=$action"
-            tk_dialog .badexp "Error in EXP" $msg error 0 Exit 
-            destroy .
+            tk_dialog .badexp "Error in readexp" $msg error 0 Exit 
         }
     }
@@ -382 +379 @@
 #   parm:
 #     name -- phase name
-#     natoms -- number of atoms
+#     natoms -- number of atoms (*)
 #     a b c alpha beta gamma -- cell parameters (*)
 #     cellref -- refinement flag for the unit cell(*)
 #     celldamp  -- damping for the unit cell refinement (*)
-#     spacegroup -- space group symbol
+#     spacegroup -- space group symbol (*)
 #     ODForder -- spherical harmonic order (*)
 #     ODFsym   -- sample symmetry (0-3) (*)
@@ -410 +407 @@
         }
 
+        name-set {
+            setexp "CRS$phase    PNAM" " $value" 2 68
+        }
+
         spacegroup-get {
             return [string trim [readexp "CRS$phase  SG SYM"]]
         }
 
-        name-set {
-            setexp "CRS$phase    PNAM" " $value" 2 68
+        spacegroup-set {
+            setexp "CRS$phase  SG SYM" " $value" 2 68
         }
 
         natoms-get {
             return [string trim [readexp "CRS$phase   NATOM"]]      
+        }
+
+        natoms-set {
+            if ![validint value 5] {return 0}
+            setexp "CRS$phase   NATOM" $value 1 5
         }
 
@@ -687 +693 @@
         default {
             set msg "Unsupported phaseinfo access: parm=$parm action=$action"
-            tk_dialog .badexp "Error in EXP" $msg error 0 Exit 
-#           destroy .
+            tk_dialog .badexp "Error in readexp" $msg error 0 Exit 
         }
     }
@@ -751 +756 @@
                 return [string trim [string range [readexp ${key}B] 62 62] ]
             }
+            temptype-set {
+                if {$value == "A"} {
+                    setexp ${key}B A 63 1
+                    # copy the Uiso to the diagonal terms
+                    set value [string range [readexp ${key}B] 0 9]
+                    setexp ${key}B $value 11 10
+                    setexp ${key}B $value 21 10
+                    set value 0.0
+                    validreal value 10 6
+                    setexp ${key}B $value 31 10
+                    setexp ${key}B $value 41 10
+                    setexp ${key}B $value 51 10
+                } else {
+                    setexp ${key}B I 63 1
+                    set value 0.0
+                    catch {
+                        # get the trace
+                        set value [expr ( \
+                                [string range [readexp ${key}B] 0 9] + \
+                                [string range [readexp ${key}B] 10 19] + \
+                                [string range [readexp ${key}B] 20 29])/3.]
+                    }
+                    validreal value 10 6
+                    setexp ${key}B $value 1 10
+                    # blank out the remaining terms
+                    set value " "
+                    setexp ${key}B $value 11 10
+                    setexp ${key}B $value 21 10
+                    setexp ${key}B $value 31 10
+                    setexp ${key}B $value 41 10
+                    setexp ${key}B $value 51 10
+                }
+            }
             x-get {
                 return [string trim [string range [readexp ${key}A] 10 19] ]
@@ -878 +916 @@
             default {
                 set msg "Unsupported atominfo access: parm=$parm action=$action"
-                tk_dialog .badexp "Error in EXP" $msg error 0 Exit 
-                destroy .
+                tk_dialog .badexp "Error in readexp" $msg error 0 Exit 
             }
         }
@@ -1222 +1259 @@
             default {
                 set msg "Unsupported histinfo access: parm=$parm action=$action"
-                tk_dialog .badexp "Error in EXP" $msg error 0 Exit 
-                destroy .
+                tk_dialog .badexp "Error in readexp" $msg error 0 Exit 
             }
         }
@@ -1375 +1411 @@
             default {
                 set msg "Unsupported hapinfo access: parm=$parm action=$action"
-                tk_dialog .badexp "Error in EXP" $msg error 0 Exit 
-                destroy .
+                tk_dialog .badexp "Error in readexp" $msg error 0 Exit 
             }
         }
@@ -1763 +1798 @@
         default {
             set msg "Unsupported constrinfo access: type=$type action=$action"
-            tk_dialog .badexp "Error in EXP access" $msg error 0 OK
+            tk_dialog .badexp "Error in readexp access" $msg error 0 OK
         }
 
@@ -1947 +1982 @@
             default {
                 set msg "Unsupported MDprefinfo access: parm=$parm action=$action"
-                tk_dialog .badexp "Error in EXP" $msg error 0 Exit 
-                destroy .
+                tk_dialog .badexp "Error in readexp" $msg error 0 Exit 
             }
 
@@ -2005 +2039 @@
     return [llength [array names exparray {    HSTRY*}]]
 }
+
+# set the phase flags for histogram $hist to $plist
+proc SetPhaseFlag {hist plist} {
+    # make a 2 digit key -- hh
+    if {$hist < 10} {
+        set hh " $hist"
+    } else {
+        set hh $hist
+    }
+    set key "HST $hh NPHAS"
+    set str {}
+    foreach iph {1 2 3 4 5 6 7 8 9} {
+        if {[lsearch $plist $iph] != -1} {
+            append str {    1}
+        } else {
+            append str {    0}      
+        }
+    }
+    setexp $key $str 1 68
+}
+
+# erase atom $atom from phase $phase
+# update the list of atom types, erasing the record if not needed.
+proc EraseAtom {atom phase} {
+    set type [atominfo $phase $atom type]
+    if {$type == ""} return
+    if {$atom < 10} {
+        set key "CRS$phase  AT  $atom"
+    } elseif {$atom < 100} {
+        set key "CRS$phase  AT $atom"
+    } else {
+        set key "CRS$phase  AT$atom"
+    }
+    # delete the records for the atom
+    global exparray
+    foreach k [array names exparray ${key}*] {
+        delexp $k
+    }
+    # change the number of atoms in the phase
+    phaseinfo $phase natoms set [expr [phaseinfo $phase natoms] -1]
+
+    # now adjust numbers in "EXPR ATYP" records and delete, if needed.
+    set natypes [readexp " EXPR  NATYP"]
+    if {$natypes == ""} return
+    set j 0
+    for {set i 1} {$i <= $natypes} {incr i} {
+        incr j
+        if {$j <10} {
+            set key " EXPR ATYP $j"
+        } else {
+            set key " EXPR ATYP$j"
+        }
+        while {![existsexp $key]} {
+            incr j
+            if {$j > 99} {
+                return
+            } elseif {$j <10} {
+                set key " EXPR ATYP $j"
+            } else {
+                set key " EXPR ATYP$j"
+            }
+        }
+        set keytype [string trim [string range $exparray($key) 2 9]]
+        if {$type == $keytype} {
+            # found the type record
+            set val [string trim [string range $exparray($key) 10 14]]
+            incr val -1
+            # if this is the last reference, remove the record,
+            # otherwise, decrement the counter
+            if {$val <= 0} {
+                incr natypes -1 
+                validint natypes 5
+                setexp " EXPR  NATYP" $natypes 1 5
+                delexp $key
+            } else {
+                validint val 5
+                setexp $key $val 11 5
+            }
+            return
+        }
+    }
+}