Changeset 229

Timestamp:

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

Author:

toby

Message:

# on 2000/07/06 20:35:35, toby did:
delete the old expmap (except for expmap(Revision)) before doing mapexp
set proftype, profterms & pterm$n in hapinfo
profile constraints now in constrinfo
add profdefinfo to get default profile values

File:

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

trunk/readexp.tcl

@@ -72 +72 @@
 proc mapexp {} {
     global expmap exparray
+    # clear out the old array
+    set expmap_Revision $expmap(Revision)
+    unset expmap
+    set expmap(Revision) $expmap_Revision
     # get the defined phases
     set line [readexp " EXPR NPHAS"]
@@ -1019 +1023 @@
 #     frac -- phase fraction (*)
 #     frref/frdamp -- refinement flag/damping value for the phase fraction (*)
-#     proftype -- profile function number
-#     profterms -- number of profile terms
+#     proftype -- profile function number (*)
+#     profterms -- number of profile terms (*)
 #     pdamp -- damping value for the profile (*)
 #     pcut -- cutoff value for the profile (*)
-#     pterm$n -- profile term #n
+#     pterm$n -- profile term #n (*)
 #     pref$n -- refinement flag value for profile term #n (*)
 #     extmeth -- Fobs extraction method (*)
@@ -1079 +1083 @@
                 return $val
             }
+            proftype-set {
+                if ![validint value 5] {return 0}
+                setexp "${key}PRCF " $value 1 5
+            }
             profterms-get {
                 set val [string range [readexp "${key}PRCF "] 5 9]
                 if {$val == " "} {return 0}
                 return $val
+            }
+            profterms-set {
+                if ![validint value 5] {return 0}
+                setexp "${key}PRCF " $value 6 5
+                # now check that all needed entries exist
+                set lines [expr 1 + ($value - 1) / 4]
+                for {set i 1} {$i <= $lines} {incr i} {
+                    makeexprec "${key}PRCF $i"
+                }
             }
             pcut-get {
@@ -1155 +1172 @@
 
 #  get a logical constraint
+#
 #  type action
 #  -----------
-#  atom get    returns a list of constraints.
-#       set    replaces a list of constraints.
-#       add    inserts a new list of constraints 
-#       delete deletes a set of constraint entries
+#  atom get  number        returns a list of constraints.
+#   "   set  number value  replaces a list of constraints 
+#                          (value is a list of constraints)
+#   "   add  number value  inserts a new list of constraints 
+#                          (number is ignored)
+#   "   delete number      deletes a set of constraint entries
 # Each item in the list of constraints is composed of 4 items: 
-#   phase, atom, variable, multiplier
-#      if variable=UISO atom can be ALL, otherwise atom is a number
+#              phase, atom, variable, multiplier
+# If variable=UISO atom can be ALL, otherwise atom is a number
 # legal variable names: FRAC, X, Y, Z, UISO, U11, U22, U33, U12, U23, U13,
 #                       MX, MY, MZ
+#
+#  type action
+#  -----------
+#  profileXX get number         returns a list of constraints for term XX=1-36
+#                               use number=0 to get # of defined
+#                                  constraints for term XX
+#   "        set number value   replaces a list of constraints 
+#                               (value is a list of constraints)
+#   "        add number value   inserts a new list of constraints 
+#                               (number is ignored)
+#   "        delete number      deletes a set of constraint entries
+# Each item in the list of constraints is composed of 3 items: 
+#              phase-list, histogram-list, multiplier
+# Note that phase-list and/or histogram-list can be ALL
+
 proc constrinfo {type action number "value {}"} {
     switch -glob ${type}-$action {
@@ -1285 +1320 @@
             }
         }
+        profile*-delete {
+            regsub profile $type {} term
+            if {$term < 10} {
+                set term " $term"
+            }
+            set key "LEQV PF$term   "
+            # return nothing if no term exists
+            if {![existsexp $key]} {return 0}
+
+            # number of constraint terms
+            set nterms [string trim [string range [readexp ${key}] 0 4] ]
+            # don't delete a non-existing entry
+            if {$number > $nterms} {return 0}
+            set val [expr $nterms - 1]
+            validint val 5
+            setexp $key $val 1 5
+            for {set i1 $number} {$i1 < $nterms} {incr i1} {
+                set i2 [expr 1 + $i1]
+                # move the contents of constraint #i2 -> i1
+                if {$i1 > 9} {
+                    set k1 [expr ($i1+1)/10]
+                    set l1 $i1
+                } else {
+                    set k1 " "
+                    set l1 " $i1"
+                }
+                set key1 "LEQV PF$term  $k1"
+                # number of constraint lines for #i1
+                set n1 [string trim [string range [readexp ${key1}] \
+                        [expr ($i1%10)*5] [expr 4+(($i1%10)*5)]] ]
+                if {$i2 > 9} {
+                    set k2 [expr ($i2+1)/10]
+                    set l2 $i2
+                } else {
+                    set k2 " "
+                    set l2 " $i2"
+                }
+                set key2 "LEQV PF$term  $k2"
+                # number of constraint lines for #i2
+                set n2 [string trim [string range [readexp ${key2}] \
+                        [expr ($i2%10)*5] [expr 4+(($i2%10)*5)]] ]
+                set val $n2
+                validint val 5
+                # move the # of terms
+                setexp $key1 $val [expr 1+(($i1%10)*5)] 5
+                # move the terms
+                for {set j 1} {$j <= $n2} {incr j 1} {
+                    set key "LEQV PF${term}${l1}$j"
+                    makeexprec $key
+                    setexp $key [readexp "LEQV PF${term}${l2}$j"] 1 68
+                }
+                # delete any remaining lines
+                for {set j [expr $n2+1]} {$j <= $n1} {incr j 1} {
+                    delexp "LEQV PF${term}${l1}$j"
+                }
+            }
+
+            # clear the last term
+            if {$nterms > 9} {
+                set i [expr ($nterms+1)/10]
+            } else {
+                set i " "
+            }
+            set key "LEQV PF$term  $i"
+            set cb [expr ($nterms%10)*5]
+            set ce [expr 4+(($nterms%10)*5)]
+            set n2 [string trim [string range [readexp ${key}] $cb $ce] ]
+            incr cb
+            setexp $key "     " $cb 5
+            # delete any remaining lines
+            for {set j 1} {$j <= $n2} {incr j 1} {
+                delexp "LEQV PF${term}${nterms}$j"
+            }
+        }
+        profile*-set {
+            regsub profile $type {} term
+            if {$term < 10} {
+                set term " $term"
+            }
+            set key "LEQV PF$term   "
+            # get number of constraint terms
+            set nterms [string trim [string range [readexp ${key}] 0 4] ]
+            # don't change a non-existing entry
+            if {$number > $nterms} {return 0}
+            if {$number > 9} {
+                set k1 [expr ($number+1)/10]
+                set l1 $number
+            } else {
+                set k1 " "
+                set l1 " $number"
+            }
+            set key1 "LEQV PF$term  $k1"
+            # old number of constraint lines
+            set n1 [string trim [string range [readexp ${key1}] \
+                    [expr ($number%10)*5] [expr 4+(($number%10)*5)]] ]
+            # number of new constraints
+            set j2 [llength $value]
+            # number of new constraint lines
+            set val [set n2 [expr ($j2 + 2)/3]]
+            # store the new # of lines
+            validint val 5
+            setexp $key1 $val [expr 1+(($number%10)*5)] 5
+
+            # loop over the # of lines in the old or new, whichever is greater
+            set v0 0
+            for {set j 1} {$j <= [expr ($n1 > $n2) ? $n1 : $n2]} {incr j 1} {
+                set key "LEQV PF${term}${l1}$j"
+                # were there more lines in the old?
+                if {$j > $n2} {
+                    # this line is not needed
+                    if {$j % 3 == 1} {
+                        delexp %key
+                    }
+                    continue
+                }
+                # are we adding new lines?
+                if {$j > $n1} {
+                    makeexprec $key
+                }
+                # add the three constraints to the line
+                foreach s {3 23 43} \
+                        item [lrange $value $v0 [expr 2+$v0]] {
+                    if {$item != ""} {
+                        set val [format %-10s%9.3f \
+                                [lindex $item 0],[lindex $item 1] \
+                                [lindex $item 2]]
+                        setexp $key $val $s 19
+                    } else {
+                        setexp $key " " $s 19
+                    }
+                }
+                incr v0 3
+            }
+        }
+        profile*-add {
+            regsub profile $type {} term
+            if {$term < 10} {
+                set term " $term"
+            }
+            set key "LEQV PF$term   "
+            if {![existsexp $key]} {makeexprec $key}
+            set nterms [string trim [string range [readexp ${key}] 0 4] ]
+            if {$nterms == ""} {
+                set nterms 1
+            } elseif {$nterms >= 99} {
+                return 0
+            } else {
+                incr nterms
+            }
+            # store the new # of constraints
+            set val $nterms
+            validint val 5
+            setexp $key $val 1 5
+
+            if {$nterms > 9} {
+                set k1 [expr ($nterms+1)/10]
+                set l1 $nterms
+            } else {
+                set k1 " "
+                set l1 " $nterms"
+            }
+            set key1 "LEQV PF$term  $k1"
+
+            # number of new constraints
+            set j2 [llength $value]
+            # number of new constraint lines
+            set val [set n2 [expr ($j2 + 2)/3]]
+            # store the new # of lines
+            validint val 5
+            setexp $key1 $val [expr 1+(($nterms%10)*5)] 5
+
+            # loop over the # of lines to be added
+            set v0 0
+            for {set j 1} {$j <= $n2} {incr j 1} {
+                set key "LEQV PF${term}${l1}$j"
+                makeexprec $key
+                # add the three constraints to the line
+                foreach s {3 23 43} \
+                        item [lrange $value $v0 [expr 2+$v0]] {
+                    if {$item != ""} {
+                        set val [format %-10s%9.3f \
+                                [lindex $item 0],[lindex $item 1] \
+                                [lindex $item 2]]
+                        setexp $key $val $s 19
+                    } else {
+                        setexp $key " " $s 19
+                    }
+                }
+                incr v0 3
+            }
+        }
+        profile*-get {
+            regsub profile $type {} term
+            if {$term < 10} {
+                set term " $term"
+            }
+            if {$number > 9} {
+                set i [expr ($number+1)/10]
+            } else {
+                set i " "
+            }
+            set key "LEQV PF$term  $i"
+            # return nothing if no term exists
+            if {![existsexp $key]} {return 0}
+            # number of constraint lines
+            
+            set numline [string trim [string range [readexp ${key}] \
+                    [expr ($number%10)*5] [expr 4+(($number%10)*5)]] ]
+            if {$number == 0} {return $numline}
+            set clist {}
+            if {$number < 10} {
+                set number " $number"
+            }
+            for {set i 1} {$i <= $numline} {incr i} {
+                set key "LEQV PF${term}${number}$i"
+                set line [readexp ${key}]
+                foreach s {1 21 41} e {20 40 60} {
+                    set seg [string range $line $s $e]
+                    if {[string trim $seg] == ""} continue
+                    # parse the string segment
+                    set parse [regexp { *([0-9AL]+),([0-9AL]+) +([0-9.]+)} \
+                            $seg junk phase hist mult]
+                    # was parse successful
+                    if {!$parse} {continue}
+                    lappend clist [list $phase $hist $mult]
+                }
+            }
+            return $clist
+        }
         default {
             set msg "Unsupported constrinfo access: type=$type action=$action"
-#           tk_dialog .badexp "Error in EXP" $msg error 0 Exit 
+            tk_dialog .badexp "Error in EXP access" $msg error 0 OK
 #           destroy .
         }
 
+    }
+}
+
+# read the default profile information for a histogram 
+# use: profdefinfo hist set# parm action
+#  
+#     proftype -- profile function number
+#     profterms -- number of profile terms
+#     pdamp -- damping value for the profile (*)
+#     pcut -- cutoff value for the profile (*)
+#     pterm$n -- profile term #n
+#     pref$n -- refinement flag value for profile term #n (*)
+
+proc profdefinfo {hist set parm "action get"} {
+    global expgui
+    if {$hist < 10} {
+        set key "HST  $hist"
+    } else {
+        set key "HST $hist"
+    }
+    switch -glob ${parm}-$action {
+        proftype-get {
+            set val [string range [readexp "${key}PRCF$set"] 0 4]
+            if {$val == " "} {return 0}
+            return $val
+        }
+        profterms-get {
+            set val [string range [readexp "${key}PRCF$set"] 5 9]
+            if {$val == " "} {return 0}
+            return $val
+        }
+        pcut-get {
+            return [string trim [string range [readexp "${key}PRCF$set"] 10 19]]
+        }
+        pdamp-get {
+                set val [string range [readexp "${key}PRCF$set"] 24 24]
+            if {$val == " "} {return 0}
+            return $val
+        }
+        pterm*-get {
+            regsub pterm $parm {} num
+            set f1 [expr 15*(($num - 1) % 4)]
+            set f2 [expr 15*(1 + ($num - 1) % 4)-1]
+            set line  [expr 1 + ($num - 1) / 4]
+            return [string trim [string range [\
+                        readexp "${key}PRCF${set}$line"] $f1 $f2] ]
+        }
+        pref*-get {
+            regsub pref $parm {} num
+            set f [expr 24+$num]
+            if {[string toupper [string range [readexp "${key}PRCF$set"] $f $f]] == "Y"} {
+                return 1
+            }
+            return 0
+        }
+        default {
+            set msg "Unsupported profdefinfo access: parm=$parm action=$action"
+            tk_dialog .badexp "Code Error" $msg error 0 Exit 
+        }
     }
 }