Changeset 229 for trunk/readexp.tcl


Ignore:
Timestamp:
Dec 4, 2009 5:02:33 PM (11 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:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/readexp.tcl

    • Property rcs:date changed from 2000/06/09 03:41:16 to 2000/07/06 20:35:35
    • Property rcs:lines changed from +18 -3 to +335 -12
    • Property rcs:rev changed from 1.15 to 1.16
    r196 r229  
    7272proc mapexp {} {
    7373    global expmap exparray
     74    # clear out the old array
     75    set expmap_Revision $expmap(Revision)
     76    unset expmap
     77    set expmap(Revision) $expmap_Revision
    7478    # get the defined phases
    7579    set line [readexp " EXPR NPHAS"]
     
    10191023#     frac -- phase fraction (*)
    10201024#     frref/frdamp -- refinement flag/damping value for the phase fraction (*)
    1021 #     proftype -- profile function number
    1022 #     profterms -- number of profile terms
     1025#     proftype -- profile function number (*)
     1026#     profterms -- number of profile terms (*)
    10231027#     pdamp -- damping value for the profile (*)
    10241028#     pcut -- cutoff value for the profile (*)
    1025 #     pterm$n -- profile term #n
     1029#     pterm$n -- profile term #n (*)
    10261030#     pref$n -- refinement flag value for profile term #n (*)
    10271031#     extmeth -- Fobs extraction method (*)
     
    10791083                return $val
    10801084            }
     1085            proftype-set {
     1086                if ![validint value 5] {return 0}
     1087                setexp "${key}PRCF " $value 1 5
     1088            }
    10811089            profterms-get {
    10821090                set val [string range [readexp "${key}PRCF "] 5 9]
    10831091                if {$val == " "} {return 0}
    10841092                return $val
     1093            }
     1094            profterms-set {
     1095                if ![validint value 5] {return 0}
     1096                setexp "${key}PRCF " $value 6 5
     1097                # now check that all needed entries exist
     1098                set lines [expr 1 + ($value - 1) / 4]
     1099                for {set i 1} {$i <= $lines} {incr i} {
     1100                    makeexprec "${key}PRCF $i"
     1101                }
    10851102            }
    10861103            pcut-get {
     
    11551172
    11561173#  get a logical constraint
     1174#
    11571175#  type action
    11581176#  -----------
    1159 #  atom get    returns a list of constraints.
    1160 #       set    replaces a list of constraints.
    1161 #       add    inserts a new list of constraints
    1162 #       delete deletes a set of constraint entries
     1177#  atom get  number        returns a list of constraints.
     1178#   "   set  number value  replaces a list of constraints
     1179#                          (value is a list of constraints)
     1180#   "   add  number value  inserts a new list of constraints
     1181#                          (number is ignored)
     1182#   "   delete number      deletes a set of constraint entries
    11631183# Each item in the list of constraints is composed of 4 items:
    1164 #   phase, atom, variable, multiplier
    1165 #      if variable=UISO atom can be ALL, otherwise atom is a number
     1184#              phase, atom, variable, multiplier
     1185# If variable=UISO atom can be ALL, otherwise atom is a number
    11661186# legal variable names: FRAC, X, Y, Z, UISO, U11, U22, U33, U12, U23, U13,
    11671187#                       MX, MY, MZ
     1188#
     1189#  type action
     1190#  -----------
     1191#  profileXX get number         returns a list of constraints for term XX=1-36
     1192#                               use number=0 to get # of defined
     1193#                                  constraints for term XX
     1194#   "        set number value   replaces a list of constraints
     1195#                               (value is a list of constraints)
     1196#   "        add number value   inserts a new list of constraints
     1197#                               (number is ignored)
     1198#   "        delete number      deletes a set of constraint entries
     1199# Each item in the list of constraints is composed of 3 items:
     1200#              phase-list, histogram-list, multiplier
     1201# Note that phase-list and/or histogram-list can be ALL
     1202
    11681203proc constrinfo {type action number "value {}"} {
    11691204    switch -glob ${type}-$action {
     
    12851320            }
    12861321        }
     1322        profile*-delete {
     1323            regsub profile $type {} term
     1324            if {$term < 10} {
     1325                set term " $term"
     1326            }
     1327            set key "LEQV PF$term   "
     1328            # return nothing if no term exists
     1329            if {![existsexp $key]} {return 0}
     1330
     1331            # number of constraint terms
     1332            set nterms [string trim [string range [readexp ${key}] 0 4] ]
     1333            # don't delete a non-existing entry
     1334            if {$number > $nterms} {return 0}
     1335            set val [expr $nterms - 1]
     1336            validint val 5
     1337            setexp $key $val 1 5
     1338            for {set i1 $number} {$i1 < $nterms} {incr i1} {
     1339                set i2 [expr 1 + $i1]
     1340                # move the contents of constraint #i2 -> i1
     1341                if {$i1 > 9} {
     1342                    set k1 [expr ($i1+1)/10]
     1343                    set l1 $i1
     1344                } else {
     1345                    set k1 " "
     1346                    set l1 " $i1"
     1347                }
     1348                set key1 "LEQV PF$term  $k1"
     1349                # number of constraint lines for #i1
     1350                set n1 [string trim [string range [readexp ${key1}] \
     1351                        [expr ($i1%10)*5] [expr 4+(($i1%10)*5)]] ]
     1352                if {$i2 > 9} {
     1353                    set k2 [expr ($i2+1)/10]
     1354                    set l2 $i2
     1355                } else {
     1356                    set k2 " "
     1357                    set l2 " $i2"
     1358                }
     1359                set key2 "LEQV PF$term  $k2"
     1360                # number of constraint lines for #i2
     1361                set n2 [string trim [string range [readexp ${key2}] \
     1362                        [expr ($i2%10)*5] [expr 4+(($i2%10)*5)]] ]
     1363                set val $n2
     1364                validint val 5
     1365                # move the # of terms
     1366                setexp $key1 $val [expr 1+(($i1%10)*5)] 5
     1367                # move the terms
     1368                for {set j 1} {$j <= $n2} {incr j 1} {
     1369                    set key "LEQV PF${term}${l1}$j"
     1370                    makeexprec $key
     1371                    setexp $key [readexp "LEQV PF${term}${l2}$j"] 1 68
     1372                }
     1373                # delete any remaining lines
     1374                for {set j [expr $n2+1]} {$j <= $n1} {incr j 1} {
     1375                    delexp "LEQV PF${term}${l1}$j"
     1376                }
     1377            }
     1378
     1379            # clear the last term
     1380            if {$nterms > 9} {
     1381                set i [expr ($nterms+1)/10]
     1382            } else {
     1383                set i " "
     1384            }
     1385            set key "LEQV PF$term  $i"
     1386            set cb [expr ($nterms%10)*5]
     1387            set ce [expr 4+(($nterms%10)*5)]
     1388            set n2 [string trim [string range [readexp ${key}] $cb $ce] ]
     1389            incr cb
     1390            setexp $key "     " $cb 5
     1391            # delete any remaining lines
     1392            for {set j 1} {$j <= $n2} {incr j 1} {
     1393                delexp "LEQV PF${term}${nterms}$j"
     1394            }
     1395        }
     1396        profile*-set {
     1397            regsub profile $type {} term
     1398            if {$term < 10} {
     1399                set term " $term"
     1400            }
     1401            set key "LEQV PF$term   "
     1402            # get number of constraint terms
     1403            set nterms [string trim [string range [readexp ${key}] 0 4] ]
     1404            # don't change a non-existing entry
     1405            if {$number > $nterms} {return 0}
     1406            if {$number > 9} {
     1407                set k1 [expr ($number+1)/10]
     1408                set l1 $number
     1409            } else {
     1410                set k1 " "
     1411                set l1 " $number"
     1412            }
     1413            set key1 "LEQV PF$term  $k1"
     1414            # old number of constraint lines
     1415            set n1 [string trim [string range [readexp ${key1}] \
     1416                    [expr ($number%10)*5] [expr 4+(($number%10)*5)]] ]
     1417            # number of new constraints
     1418            set j2 [llength $value]
     1419            # number of new constraint lines
     1420            set val [set n2 [expr ($j2 + 2)/3]]
     1421            # store the new # of lines
     1422            validint val 5
     1423            setexp $key1 $val [expr 1+(($number%10)*5)] 5
     1424
     1425            # loop over the # of lines in the old or new, whichever is greater
     1426            set v0 0
     1427            for {set j 1} {$j <= [expr ($n1 > $n2) ? $n1 : $n2]} {incr j 1} {
     1428                set key "LEQV PF${term}${l1}$j"
     1429                # were there more lines in the old?
     1430                if {$j > $n2} {
     1431                    # this line is not needed
     1432                    if {$j % 3 == 1} {
     1433                        delexp %key
     1434                    }
     1435                    continue
     1436                }
     1437                # are we adding new lines?
     1438                if {$j > $n1} {
     1439                    makeexprec $key
     1440                }
     1441                # add the three constraints to the line
     1442                foreach s {3 23 43} \
     1443                        item [lrange $value $v0 [expr 2+$v0]] {
     1444                    if {$item != ""} {
     1445                        set val [format %-10s%9.3f \
     1446                                [lindex $item 0],[lindex $item 1] \
     1447                                [lindex $item 2]]
     1448                        setexp $key $val $s 19
     1449                    } else {
     1450                        setexp $key " " $s 19
     1451                    }
     1452                }
     1453                incr v0 3
     1454            }
     1455        }
     1456        profile*-add {
     1457            regsub profile $type {} term
     1458            if {$term < 10} {
     1459                set term " $term"
     1460            }
     1461            set key "LEQV PF$term   "
     1462            if {![existsexp $key]} {makeexprec $key}
     1463            set nterms [string trim [string range [readexp ${key}] 0 4] ]
     1464            if {$nterms == ""} {
     1465                set nterms 1
     1466            } elseif {$nterms >= 99} {
     1467                return 0
     1468            } else {
     1469                incr nterms
     1470            }
     1471            # store the new # of constraints
     1472            set val $nterms
     1473            validint val 5
     1474            setexp $key $val 1 5
     1475
     1476            if {$nterms > 9} {
     1477                set k1 [expr ($nterms+1)/10]
     1478                set l1 $nterms
     1479            } else {
     1480                set k1 " "
     1481                set l1 " $nterms"
     1482            }
     1483            set key1 "LEQV PF$term  $k1"
     1484
     1485            # number of new constraints
     1486            set j2 [llength $value]
     1487            # number of new constraint lines
     1488            set val [set n2 [expr ($j2 + 2)/3]]
     1489            # store the new # of lines
     1490            validint val 5
     1491            setexp $key1 $val [expr 1+(($nterms%10)*5)] 5
     1492
     1493            # loop over the # of lines to be added
     1494            set v0 0
     1495            for {set j 1} {$j <= $n2} {incr j 1} {
     1496                set key "LEQV PF${term}${l1}$j"
     1497                makeexprec $key
     1498                # add the three constraints to the line
     1499                foreach s {3 23 43} \
     1500                        item [lrange $value $v0 [expr 2+$v0]] {
     1501                    if {$item != ""} {
     1502                        set val [format %-10s%9.3f \
     1503                                [lindex $item 0],[lindex $item 1] \
     1504                                [lindex $item 2]]
     1505                        setexp $key $val $s 19
     1506                    } else {
     1507                        setexp $key " " $s 19
     1508                    }
     1509                }
     1510                incr v0 3
     1511            }
     1512        }
     1513        profile*-get {
     1514            regsub profile $type {} term
     1515            if {$term < 10} {
     1516                set term " $term"
     1517            }
     1518            if {$number > 9} {
     1519                set i [expr ($number+1)/10]
     1520            } else {
     1521                set i " "
     1522            }
     1523            set key "LEQV PF$term  $i"
     1524            # return nothing if no term exists
     1525            if {![existsexp $key]} {return 0}
     1526            # number of constraint lines
     1527           
     1528            set numline [string trim [string range [readexp ${key}] \
     1529                    [expr ($number%10)*5] [expr 4+(($number%10)*5)]] ]
     1530            if {$number == 0} {return $numline}
     1531            set clist {}
     1532            if {$number < 10} {
     1533                set number " $number"
     1534            }
     1535            for {set i 1} {$i <= $numline} {incr i} {
     1536                set key "LEQV PF${term}${number}$i"
     1537                set line [readexp ${key}]
     1538                foreach s {1 21 41} e {20 40 60} {
     1539                    set seg [string range $line $s $e]
     1540                    if {[string trim $seg] == ""} continue
     1541                    # parse the string segment
     1542                    set parse [regexp { *([0-9AL]+),([0-9AL]+) +([0-9.]+)} \
     1543                            $seg junk phase hist mult]
     1544                    # was parse successful
     1545                    if {!$parse} {continue}
     1546                    lappend clist [list $phase $hist $mult]
     1547                }
     1548            }
     1549            return $clist
     1550        }
    12871551        default {
    12881552            set msg "Unsupported constrinfo access: type=$type action=$action"
    1289 #           tk_dialog .badexp "Error in EXP" $msg error 0 Exit
     1553            tk_dialog .badexp "Error in EXP access" $msg error 0 OK
    12901554#           destroy .
    12911555        }
    12921556
     1557    }
     1558}
     1559
     1560# read the default profile information for a histogram
     1561# use: profdefinfo hist set# parm action
     1562
     1563#     proftype -- profile function number
     1564#     profterms -- number of profile terms
     1565#     pdamp -- damping value for the profile (*)
     1566#     pcut -- cutoff value for the profile (*)
     1567#     pterm$n -- profile term #n
     1568#     pref$n -- refinement flag value for profile term #n (*)
     1569
     1570proc profdefinfo {hist set parm "action get"} {
     1571    global expgui
     1572    if {$hist < 10} {
     1573        set key "HST  $hist"
     1574    } else {
     1575        set key "HST $hist"
     1576    }
     1577    switch -glob ${parm}-$action {
     1578        proftype-get {
     1579            set val [string range [readexp "${key}PRCF$set"] 0 4]
     1580            if {$val == " "} {return 0}
     1581            return $val
     1582        }
     1583        profterms-get {
     1584            set val [string range [readexp "${key}PRCF$set"] 5 9]
     1585            if {$val == " "} {return 0}
     1586            return $val
     1587        }
     1588        pcut-get {
     1589            return [string trim [string range [readexp "${key}PRCF$set"] 10 19]]
     1590        }
     1591        pdamp-get {
     1592                set val [string range [readexp "${key}PRCF$set"] 24 24]
     1593            if {$val == " "} {return 0}
     1594            return $val
     1595        }
     1596        pterm*-get {
     1597            regsub pterm $parm {} num
     1598            set f1 [expr 15*(($num - 1) % 4)]
     1599            set f2 [expr 15*(1 + ($num - 1) % 4)-1]
     1600            set line  [expr 1 + ($num - 1) / 4]
     1601            return [string trim [string range [\
     1602                        readexp "${key}PRCF${set}$line"] $f1 $f2] ]
     1603        }
     1604        pref*-get {
     1605            regsub pref $parm {} num
     1606            set f [expr 24+$num]
     1607            if {[string toupper [string range [readexp "${key}PRCF$set"] $f $f]] == "Y"} {
     1608                return 1
     1609            }
     1610            return 0
     1611        }
     1612        default {
     1613            set msg "Unsupported profdefinfo access: parm=$parm action=$action"
     1614            tk_dialog .badexp "Code Error" $msg error 0 Exit
     1615        }
    12931616    }
    12941617}
Note: See TracChangeset for help on using the changeset viewer.