source: trunk/readexp.tcl @ 229

Last change on this file since 229 was 229, checked in by toby, 11 years ago

# 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

  • Property rcs:author set to toby
  • Property rcs:date set to 2000/07/06 20:35:35
  • Property rcs:lines set to +335 -12
  • Property rcs:rev set to 1.16
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 44.8 KB
Line 
1# $Id: readexp.tcl 229 2009-12-04 23:02:33Z toby $
2# Routines to deal with the .EXP "data structure"
3set expmap(Revision) {$Revision: 229 $ $Date: 2009-12-04 23:02:33 +0000 (Fri, 04 Dec 2009) $}
4
5#  The GSAS data is read from an EXP file.
6#   ... reading an EXP file into an array
7proc expload {expfile} {
8    global exparray
9    # $expfile is the path to the data file.
10    if [catch {set fil [open "$expfile" r]}] {
11        tk_dialog .expFileErrorMsg "File Open Error" \
12                "Unable to open file $expfile" error 0 "Exit" ; return -1
13    }
14    set len [gets $fil line]
15    if {[string length $line] != $len} {
16        tk_dialog .expConvErrorMsg "old tcl" \
17                "You are using an old version of Tcl/Tk and your .EXP file has binary characters; run convstod or upgrade" \
18                error 0 "Exit"
19        return -1
20    }
21    catch {
22        unset exparray
23    }
24    if {$len > 160} {
25        set fmt 0
26        # a UNIX-type file
27        set i1 0
28        set i2 79
29        while {$i2 < $len} {
30            set nline [string range $line $i1 $i2]
31            incr i1 80
32            incr i2 80
33            set key [string range $nline 0 11]
34            set exparray($key) [string range $nline 12 end]
35        }
36    } else {
37        set fmt 1
38        while {$len > 0} {
39            set key [string range $line 0 11]
40            set exparray($key) [string range $line 12 end]
41            set len [gets $fil line]
42        }
43    }
44    close $fil
45    return $fmt
46}
47
48proc createexp {expfile title} {
49    global exparray expmap
50    catch {unset exparray}
51    foreach key   {"     VERSION" "      DESCR" "ZZZZZZZZZZZZ" " EXPR NPHAS"} \
52            value {"   6"         ""            "  Last EXP file record" ""} {
53        # truncate long keys & pad short ones
54        set key [string range "$key        " 0 11]
55        set exparray($key) $value
56    }
57    expinfo title set $title
58    exphistory add " created readexp.tcl [lindex $expmap(Revision) 1] [clock format [clock seconds]]"
59    expwrite $expfile
60}
61
62# get information out from an EXP file
63#   creates the following entries in global array expmap
64#     expmap(phaselist)     gives a list of defined phases
65#     expmap(phasetype)     gives the phase type for each defined phase
66#                           =1 nuclear; 2 mag+nuc; 3 mag; 4 macro
67#     expmap(atomlist_$p)   gives a list of defined atoms in phase $p
68#     expmap(htype_$n)      gives the GSAS histogram type for histogram
69#     expmap(powderlist)    gives a list of powder histograms
70#     expmap(phaselist_$n)  gives a list of phases used in histogram $n
71#
72proc mapexp {} {
73    global expmap exparray
74    # clear out the old array
75    set expmap_Revision $expmap(Revision)
76    unset expmap
77    set expmap(Revision) $expmap_Revision
78    # get the defined phases
79    set line [readexp " EXPR NPHAS"]
80#    if {$line == ""} {
81#       set msg "No EXPR NPHAS entry. This is an invalid .EXP file"
82#       tk_dialog .badexp "Error in EXP" $msg error 0 Exit
83#       destroy .
84#    }
85    set expmap(phaselist) {}
86    set expmap(phasetype) {}
87    # loop over phases
88    foreach iph {1 2 3 4 5 6 7 8 9} {
89        set i5s [expr ($iph - 1)*5]
90        set i5e [expr $i5s + 4]
91        set flag [string trim [string range $line $i5s $i5e]]
92        if {$flag == ""} {set flag 0}
93        if $flag {
94            lappend expmap(phaselist) $iph
95            lappend expmap(phasetype) $flag
96        }
97    }
98    # get the list of defined atoms for each phase
99    foreach iph $expmap(phaselist) {
100        set expmap(atomlist_$iph) {}
101        foreach key [array names exparray "CRS$iph  AT*A"] {
102            regexp { AT *([0-9]+)A} $key a num
103            lappend expmap(atomlist_$iph) $num
104        }
105        # note that sometimes an .EXP file contains more atoms than are actually defined
106        # drop the extra ones
107        set expmap(atomlist_$iph) [lsort -integer $expmap(atomlist_$iph)]
108        set natom [phaseinfo $iph natoms]
109        if {$natom != [llength $expmap(atomlist_$iph)]} {
110            set expmap(atomlist_$iph) [lrange $expmap(atomlist_$iph) 0 [expr $natom-1]]
111        }
112    }
113    # now get the histogram types
114    set nhist [string trim [readexp { EXPR  NHST }]]
115    set n 0
116    set expmap(powderlist) {}
117    for {set i 0} {$i < $nhist} {incr i} {
118        set ihist [expr $i + 1]
119        if {[expr $i % 12] == 0} {
120            incr n
121            set line [readexp " EXPR  HTYP$n"]
122            if {$line == ""} {
123                set msg "No HTYP$n entry for Histogram $ihist. This is an invalid .EXP file"
124                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
125                destroy .
126            }
127            set j 0
128        } else {
129            incr j
130        }
131        set expmap(htype_$ihist) [lindex $line $j]
132        # at least for now, ignore non-powder histograms
133        if {[string range $expmap(htype_$ihist) 0 0] == "P" && \
134                [string range $expmap(htype_$ihist) 3 3] != "*"} {
135            lappend expmap(powderlist) $ihist
136        }
137    }
138
139    # now process powder histograms
140    foreach ihist $expmap(powderlist) {
141        # make a 2 digit key -- hh
142        if {$ihist < 10} {
143            set hh " $ihist"
144        } else {
145            set hh $ihist
146        }
147        set line [readexp "HST $hh NPHAS"]
148        if {$line == ""} {
149            set msg "No NPHAS entry for Histogram $ihist. This is an invalid .EXP file"
150            tk_dialog .badexp "Error in EXP" $msg error 0 Exit
151            destroy .
152        }
153        set expmap(phaselist_$ihist) {}
154        # loop over phases
155        foreach iph {1 2 3 4 5 6 7 8 9} {
156            set i5s [expr ($iph - 1)*5]
157            set i5e [expr $i5s + 4]
158            set flag [string trim [string range $line $i5s $i5e]]
159            if {$flag == ""} {set flag 0}
160            if $flag {lappend expmap(phaselist_$ihist) $iph}
161        }
162    }
163}
164
165# return the value for a ISAM key
166proc readexp {key} {
167    global exparray
168    # truncate long keys & pad short ones
169    set key [string range "$key        " 0 11]
170    if [catch {set val $exparray($key)}] {
171        global expgui
172        if $expgui(debug) {puts "Error accessing record $key"}
173        return ""
174    }
175    return $val
176}
177
178# return the number of records matching ISAM key (may contain wildcards)
179proc existsexp {key} {
180    global exparray
181    # key can contain wild cards so don't pad
182    return [llength [array names exparray  $key]]
183}
184
185
186# replace a section of the exparray with $value
187#   replace $char characters starting at character $start (numbered from 1)
188proc setexp {key value start chars} {
189    global exparray
190    # truncate long keys & pad short ones
191    set key [string range "$key        " 0 11]
192    if [catch {set exparray($key)}] {
193        global expgui
194        if $expgui(debug) {puts "Error accessing record $key"}
195        return ""
196    }
197
198    # pad value to $chars
199    set l0 [expr $chars - 1]
200    set value [string range "$value                                           " 0 $l0]
201
202    if {$start == 1} {
203        set ret {}
204        set l1 $chars
205    } else {
206        set l0 [expr $start - 2]
207        set l1 [expr $start + $chars - 1]
208        set ret [string range $exparray($key) 0 $l0]
209    }
210    append ret $value [string range $exparray($key) $l1 end]
211    set exparray($key) $ret
212}
213
214proc makeexprec {key} {
215    global exparray
216    # truncate long keys & pad short ones
217    set key [string range "$key        " 0 11]
218    if [catch {set exparray($key)}] {
219        # set to 68 blanks
220        set exparray($key) [format %68s " "]
221    }
222}
223
224# delete an exp record
225# returns 1 if OK; 0 if not found
226proc delexp {key} {
227    global exparray
228    # truncate long keys & pad short ones
229    set key [string range "$key        " 0 11]
230    if [catch {unset exparray($key)}] {
231        return 0
232    }
233    return 1
234}
235# test an argument if it is a valid number; reform the number to fit
236proc validreal {val length decimal} {
237    upvar $val value
238    if [catch {expr $value}] {return 0}
239    if [catch {
240        set tmp [format "%${length}.${decimal}f" $value]
241        while {[string length $tmp] > $length} {
242            set tmp [format "%${length}.${decimal}E" $value]
243            incr decimal -1
244        }
245        set value $tmp
246    }] {return 0}
247    return 1
248}
249
250# test an argument if it is a valid integer; reform the number into
251# an integer, if appropriate -- be sure to pass the name of the variable not the value
252proc validint {val length} {
253    upvar $val value
254    # FORTRAN type assumption: blank is 0
255    if {$value == ""} {set value 0}
256    set tmp [expr round($value)]
257    if {$tmp != $value} {return 0}
258    if [catch {
259        set value [format "%${length}d" $tmp]
260    }] {return 0}
261    return 1
262}
263
264# process history information
265#    action == last
266#       returns number and value of last record
267#    action == add
268#
269proc exphistory {action "value 0"} {
270    global exparray
271    if {$action == "last"} {
272        set key [lindex [lsort -decreasing [array names exparray *HSTRY*]] 0]
273        if {$key == ""} {return ""}
274        return [list [string trim [string range $key 9 end]] $exparray($key)]
275    } elseif {$action == "add"} {
276        set key [lindex [lsort -decreasing [array names exparray *HSTRY*]] 0]
277        if {$key == ""} {
278            set index 1
279        } else {
280            set index [string trim [string range $key 9 end]]
281            if {$index != "***"} {
282                if {$index < 999} {incr index}
283                set key [format "    HSTRY%3d" $index]
284                set exparray($key) $value
285            }
286        }
287        set key [format "    HSTRY%3d" $index]
288        set exparray($key) $value
289    }
290}
291# get overall info
292#   parm:
293#     print     -- GENLES print option (*)
294#     cycles    -- number of GENLES cycles (*)
295#     title     -- the overall title (*)
296proc expinfo {parm "action get" "value {}"} {
297    switch ${parm}-$action {
298        title-get {
299            return [string trim [readexp "      DESCR"]]
300        }
301        title-set {
302            setexp "      DESCR" "  $value" 2 68
303        }
304
305        cycles-get {
306            return [string trim [cdatget MXCY]]
307        }
308        cycles-set {
309            if ![validint value 1] {return 0}
310            cdatset MXCY [format %4d $value]
311        }
312        print-get {
313            set print [string trim [cdatget PRNT]]
314            if {$print != ""} {return $print}
315            return 0
316        }
317        print-set {
318            if ![validint value 1] {return 0}
319            cdatset PRNT [format %3d $value]
320        }
321        default {
322            set msg "Unsupported expinfo access: parm=$parm action=$action"
323            tk_dialog .badexp "Error in EXP" $msg error 0 Exit
324            destroy .
325        }
326    }
327    return 1
328}
329
330proc cdatget {key} {
331    foreach i {1 2 3 4 5 6 7 8 9} {
332        if {[existsexp "  GNLS CDAT$i"] == 0} break
333        set line [readexp "  GNLS CDAT$i"]
334        if {$line == {}} break
335        foreach i1 {2 10 18 26 34 42 50 58 66} \
336                i2 {9 17 25 33 41 49 57 65 73} {
337            set item [string range $line $i1 $i2]
338            if {[string trim $item] == {}} continue
339            if [regexp "${key}(.*)" $item a b] {return $b}
340        }
341    }
342    return {}
343}
344
345proc cdatset {key value} {
346    # round 1 see if we can find the string
347    foreach i {1 2 3 4 5 6 7 8 9} {
348        set line [readexp "  GNLS CDAT$i"]
349        if {$line == {}} break
350        foreach i1 {2 10 18 26 34 42 50 58 66} \
351                i2 {9 17 25 33 41 49 57 65 73} {
352            set item [string range $line $i1 $i2]
353            if {[string trim $item] == {}} continue
354            if [regexp "${key}(.*)" $item a b] {
355                # found it now replace it
356                incr i1
357                setexp "  GNLS CDAT$i" "${key}${value}" $i1 8
358                return
359            }
360        }
361    }
362    # not found, take the 1st blank space, creating a card if needed
363    foreach i {1 2 3 4 5 6 7 8 9} {
364        set line [readexp "  GNLS CDAT$i"]
365        if {$line == {}} {makeexprec "  GNLS CDAT$i"}
366        foreach i1 {2 10 18 26 34 42 50 58 66} \
367                i2 {9 17 25 33 41 49 57 65 73} {
368            set item [string range $line $i1 $i2]
369            if {[string trim $item] == {}} {
370                # found a blank space: now replace it
371                incr i1
372                setexp "  GNLS CDAT$i" "${key}${value}" $i1 8
373                return
374            }
375        }
376    }
377    return {}
378}
379
380# get phase information: phaseinfo phase parm action value
381#   phase: 1 to 9 (as defined)
382#   parm:
383#     name -- phase name
384#     natoms -- number of atoms
385#     a b c alpha beta gamma -- cell parameters (*)
386#     cellref -- refinement flag for the unit cell(*)
387#     celldamp  -- damping for the unit cell refinement (*)
388#     spacegroup -- space group symbol
389#  action: get (default) or set
390#  value: used only with set
391#  * =>  read+write supported
392proc phaseinfo {phase parm "action get" "value {}"} {
393    switch ${parm}-$action {
394
395        name-get {
396            return [string trim [readexp "CRS$phase    PNAM"]]
397        }
398
399        spacegroup-get {
400            return [string trim [readexp "CRS$phase  SG SYM"]]
401        }
402
403        name-set {
404            setexp "CRS$phase    PNAM" " $value" 2 68
405        }
406
407        natoms-get {
408            return [string trim [readexp "CRS$phase   NATOM"]]     
409        }
410
411        a-get {
412           return [string trim [string range [readexp "CRS$phase  ABC"] 0 9]]
413        }
414        b-get {
415           return [string trim [string range [readexp "CRS$phase  ABC"] 10 19]]
416        }
417        c-get {
418           return [string trim [string range [readexp "CRS$phase  ABC"] 20 29]]
419        }
420        alpha-get {
421           return [string trim [string range [readexp "CRS$phase  ANGLES"] 0 9]]
422        }
423        beta-get {
424           return [string trim [string range [readexp "CRS$phase  ANGLES"] 10 19]]
425        }
426        gamma-get {
427           return [string trim [string range [readexp "CRS$phase  ANGLES"] 20 29]]
428        }
429
430        a-set {
431            if ![validreal value 10 6] {return 0}
432            setexp "CRS$phase  ABC" $value 1 10             
433        }
434        b-set {
435            if ![validreal value 10 6] {return 0}
436            setexp "CRS$phase  ABC" $value 11 10           
437        }
438        c-set {
439            if ![validreal value 10 6] {return 0}
440            setexp "CRS$phase  ABC" $value 21 10           
441        }
442        alpha-set {
443            if ![validreal value 10 4] {return 0}
444            setexp "CRS$phase  ANGLES" $value 1 10         
445        }
446        beta-set {
447            if ![validreal value 10 4] {return 0}
448            setexp "CRS$phase  ANGLES" $value 11 10         
449        }
450        gamma-set {
451            if ![validreal value10 4] {return 0}
452            setexp "CRS$phase  ANGLES" $value 21 10         
453        }
454        cellref-get {
455            if {[string toupper [string range [readexp "CRS$phase  ABC"] 34 34]] == "Y"} {
456                return 1
457            }
458            return 0
459        }
460        cellref-set {
461            if $value {
462                setexp "CRS$phase  ABC" "Y" 35 1
463            } else {
464                setexp "CRS$phase  ABC" "N" 35 1
465            }       
466        }
467        celldamp-get {
468            set val [string range [readexp "CRS$phase  ABC"] 39 39]
469            if {$val == " "} {return 0}
470            return $val
471        }
472        celldamp-set {
473            setexp "CRS$phase  ABC" $value 40 1
474        }
475
476        default {
477            set msg "Unsupported phaseinfo access: parm=$parm action=$action"
478            tk_dialog .badexp "Error in EXP" $msg error 0 Exit
479            destroy .
480        }
481    }
482    return 1
483}
484
485# get atom information: atominfo phase atom parm action value
486#   phase: 1 to 9 (as defined)
487#   atom: a valid atom number [see expmap(atomlist_$phase)]
488#      Note that atom and phase can be paired lists, but if there are extra
489#      entries in the atoms list, the last phase will be repeated.
490#      so that atominfo 1 {1 2 3} xset 1
491#               will set the xflag for atoms 1-3 in phase 1
492#      but atominfo {1 2 3} {1 1 1} xset 1
493#               will set the xflag for atoms 1 in phase 1-3
494#   parm:
495#     type -- element code
496#     mult -- atom multiplicity
497#     label -- atom label (*)
498#     x y z -- coordinates (*)
499#     frac --  occupancy (*)
500#     temptype -- I or A for Isotropic/Anisotropic
501#     Uiso  -- Isotropic temperature factor (*)
502#     U11  -- Anisotropic temperature factor (*)
503#     U22  -- Anisotropic temperature factor (*)
504#     U33  -- Anisotropic temperature factor (*)
505#     U12  -- Anisotropic temperature factor (*)
506#     U13  -- Anisotropic temperature factor (*)
507#     U23  -- Anisotropic temperature factor (*)
508#     xref/xdamp -- refinement flag/damping value for the coordinates (*)
509#     uref/udamp -- refinement flag/damping value for the temperature factor(s)  (*)
510#     fref/fdamp -- refinement flag/damping value for the occupancy (*)
511#  action: get (default) or set
512#  value: used only with set
513#  * =>  read+write supported
514
515proc atominfo {phaselist atomlist parm "action get" "value {}"} {
516    foreach phase $phaselist atom $atomlist {
517        if {$phase == ""} {set phase [lindex $phaselist end]}
518        if {$atom < 10} {
519            set key "CRS$phase  AT  $atom"
520        } elseif {$atom < 100} {
521            set key "CRS$phase  AT $atom"
522        } else {
523            set key "CRS$phase  AT$atom"
524        }
525        switch -glob ${parm}-$action {
526            type-get {
527                return [string trim [string range [readexp ${key}A] 2 9] ]
528            }
529            mult-get {
530                return [string trim [string range [readexp ${key}A] 58 61] ]
531            }
532            label-get {
533                return [string trim [string range [readexp ${key}A] 50 57] ]
534            }
535            label-set {
536                setexp ${key}A $value 51 8
537            }
538            temptype-get {
539                return [string trim [string range [readexp ${key}B] 62 62] ]
540            }
541            x-get {
542                return [string trim [string range [readexp ${key}A] 10 19] ]
543            }
544            x-set {
545                if ![validreal value 10 6] {return 0}
546                setexp ${key}A $value 11 10
547            }
548            y-get {
549                return [string trim [string range [readexp ${key}A] 20 29] ]
550            }
551            y-set {
552                if ![validreal value 10 6] {return 0}
553                setexp ${key}A $value 21 10
554            }
555            z-get {
556                return [string trim [string range [readexp ${key}A] 30 39] ]
557            }
558            z-set {
559                if ![validreal value 10 6] {return 0}
560                setexp ${key}A $value 31 10
561            }
562            frac-get {
563                return [string trim [string range [readexp ${key}A] 40 49] ]
564            }
565            frac-set {
566                if ![validreal value 10 6] {return 0}
567                setexp ${key}A $value 41 10
568            }
569            U*-get {
570                regsub U $parm {} type
571                if {$type == "iso" || $type == "11"} {
572                    return [string trim [string range [readexp ${key}B] 0 9] ]
573                } elseif {$type == "22"} {
574                    return [string trim [string range [readexp ${key}B] 10 19] ]
575                } elseif {$type == "33"} {
576                    return [string trim [string range [readexp ${key}B] 20 29] ]
577                } elseif {$type == "12"} {
578                    return [string trim [string range [readexp ${key}B] 30 39] ]
579                } elseif {$type == "13"} {
580                    return [string trim [string range [readexp ${key}B] 40 49] ]
581                } elseif {$type == "23"} {
582                    return [string trim [string range [readexp ${key}B] 50 59] ]
583                }
584            }
585            U*-set {
586                if ![validreal value 10 6] {return 0}
587                regsub U $parm {} type
588                if {$type == "iso" || $type == "11"} {
589                    setexp ${key}B $value 1 10
590                } elseif {$type == "22"} {
591                    setexp ${key}B $value 11 10
592                } elseif {$type == "33"} {
593                    setexp ${key}B $value 21 10
594                } elseif {$type == "12"} {
595                    setexp ${key}B $value 31 10
596                } elseif {$type == "13"} {
597                    setexp ${key}B $value 41 10
598                } elseif {$type == "23"} {
599                    setexp ${key}B $value 51 10
600                }
601            }
602            xref-get {
603                if {[string toupper [string range [readexp ${key}B] 64 64]] == "X"} {
604                    return 1
605                }
606                return 0
607            }
608            xref-set {
609                if $value {
610                    setexp ${key}B "X" 65 1
611                } else {
612                    setexp ${key}B " " 65 1
613                }           
614            }
615            xdamp-get {
616                set val [string range [readexp ${key}A] 64 64]
617                if {$val == " "} {return 0}
618                return $val
619            }
620            xdamp-set {
621                setexp ${key}A $value 65 1
622            }
623            fref-get {
624                if {[string toupper [string range [readexp ${key}B] 63 63]] == "F"} {
625                    return 1
626                }
627                return 0
628            }
629            fref-set {
630                if $value {
631                    setexp ${key}B "F" 64 1
632                } else {
633                    setexp ${key}B " " 64 1
634                }           
635            }
636            fdamp-get {
637                set val [string range [readexp ${key}A] 63 63]
638                if {$val == " "} {return 0}
639                return $val
640            }
641            fdamp-set {
642                setexp ${key}A $value 64 1
643            }
644
645            uref-get {
646                if {[string toupper [string range [readexp ${key}B] 65 65]] == "U"} {
647                    return 1
648                }
649                return 0
650            }
651            uref-set {
652                if $value {
653                    setexp ${key}B "U" 66 1
654                } else {
655                    setexp ${key}B " " 66 1
656                }           
657            }
658            udamp-get {
659                set val [string range [readexp ${key}A] 65 65]
660                if {$val == " "} {return 0}
661                return $val
662            }
663            udamp-set {
664                setexp ${key}A $value 66 1
665            }
666            default {
667                set msg "Unsupported atominfo access: parm=$parm action=$action"
668                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
669                destroy .
670            }
671        }
672    }
673    return 1
674}
675
676# get histogram information: histinfo histlist parm action value
677# histlist is a list of histogram numbers
678# parm:
679#     title
680#     scale (*)
681#     sref/sdamp -- refinement flag/damping value for the scale factor (*)
682#     lam1, lam2 (*)
683#     ttref refinement flag for the 2theta (ED Xray) (*)
684#     wref refinement flag for the wavelength (*)
685#     ratref refinement flag for the wavelength ratio (*)
686#     difc, difa -- TOF calibration constants (*)
687#     dcref,daref -- refinement flag for difc, difa (*)
688#     zero (*)
689#     zref refinement flag for the zero correction (*)
690#     ipola (*)
691#     pola (*)
692#     pref refinement flag for the polarization (*)
693#     kratio (*)
694#     ddamp -- damping value for the diffractometer constants (*)
695#     backtype -- background function number *
696#     backterms -- number of background terms *
697#     bref/bdamp -- refinement flag/damping value for the background (*)
698#     bterm$n -- background term #n (*)
699#     bank -- Bank number
700#     tofangle -- detector angle (TOF only)
701#     foextract  -- Fobs extraction flag (*)
702proc histinfo {histlist parm "action get" "value {}"} {
703    global expgui
704    foreach hist $histlist {
705        if {$hist < 10} {
706            set key "HST  $hist"
707        } else {
708            set key "HST $hist"
709        }
710        switch -glob ${parm}-$action {
711            foextract-get {
712                set line [readexp "${key} EPHAS"]
713                # add a EPHAS if not exists
714                if {$line == {}} {
715                    makeexprec "${key} EPHAS"
716                    # expedt defaults this to "F", but I think "T" is better
717                    setexp "${key} EPHAS" "T" 50 1
718                    if $expgui(debug) {puts "Warning: creating a ${key} EPHAS record"}
719                }
720                if {[string toupper [string range $line 49 49]] == "T"} {
721                    return 1
722                }
723                return 0
724            }
725            foextract-set {
726                if $value {
727                    setexp "${key} EPHAS" "T" 50 1
728                } else {
729                    setexp "${key} EPHAS" "F" 50 1
730                }           
731            }
732            title-get {
733                return [string trim [readexp "${key}  HNAM"] ]
734            }
735            scale-get {
736                return [string trim [string range [readexp ${key}HSCALE] 0 14]]
737            }
738            scale-set {
739                if ![validreal value 15 6] {return 0}
740                setexp ${key}HSCALE $value 1 15
741            }
742            sref-get {
743                if {[string toupper [string range [readexp ${key}HSCALE] 19 19]] == "Y"} {
744                    return 1
745                }
746                return 0
747            }
748            sref-set {
749                if $value {
750                    setexp ${key}HSCALE "Y" 20 1
751                } else {
752                    setexp ${key}HSCALE "N" 20 1
753                }           
754            }
755            sdamp-get {
756                set val [string range [readexp ${key}HSCALE] 24 24]
757                if {$val == " "} {return 0}
758                return $val
759            }
760            sdamp-set {
761                setexp ${key}HSCALE $value 25 1
762            }
763
764            difc-get -
765            lam1-get {
766                return [string trim [string range [readexp "${key} ICONS"] 0 9]]
767            }
768            difc-set -
769            lam1-set {
770                if ![validreal value 10 7] {return 0}
771                setexp "${key} ICONS" $value 1 10
772            }
773            difa-get -
774            lam2-get {
775                return [string trim [string range [readexp "${key} ICONS"] 10 19]]
776            }
777            difa-set -
778            lam2-set {
779                if ![validreal value 10 7] {return 0}
780                setexp "${key} ICONS" $value 11 10
781            }
782            zero-get {
783                return [string trim [string range [readexp "${key} ICONS"] 20 29]]
784            }
785            zero-set {
786                if ![validreal value 10 5] {return 0}
787                setexp "${key} ICONS" $value 21 10
788            }
789            ipola-get {
790                return [string trim [string range [readexp "${key} ICONS"] 54 54]]
791            }
792            ipola-set {
793                if ![validint value 1] {return 0}
794                setexp "${key} ICONS" $value 55 1
795            }
796            pola-get {
797                return [string trim [string range [readexp "${key} ICONS"] 40 49]]
798            }
799            pola-set {
800                if ![validreal value 10 5] {return 0}
801                setexp "${key} ICONS" $value 41 10
802            }
803            kratio-get {
804                return [string trim [string range [readexp "${key} ICONS"] 55 64]]
805            }
806            kratio-set {
807                if ![validreal value 10 5] {return 0}
808                setexp "${key} ICONS" $value 56 10
809            }
810
811            wref-get {
812            #------------------------------------------------------
813            # col 33: refine flag for lambda, difc, ratio and theta
814            #------------------------------------------------------
815                if {[string toupper [string range \
816                        [readexp "${key} ICONS"] 32 32]] == "L"} {
817                    return 1
818                }
819                return 0
820            }
821            wref-set {
822                if $value {
823                    setexp "${key} ICONS" "L" 33 1
824                } else {
825                    setexp "${key} ICONS" " " 33 1
826                }           
827            }
828            ratref-get {
829                if {[string toupper [string range \
830                        [readexp "${key} ICONS"] 32 32]] == "R"} {
831                    return 1
832                }
833                return 0
834            }
835            ratref-set {
836                if $value {
837                    setexp "${key} ICONS" "R" 33 1
838                } else {
839                    setexp "${key} ICONS" " " 33 1
840                }           
841            }
842            dcref-get {
843                if {[string toupper [string range \
844                        [readexp "${key} ICONS"] 32 32]] == "C"} {
845                    return 1
846                }
847                return 0
848            }
849            dcref-set {
850                if $value {
851                    setexp "${key} ICONS" "C" 33 1
852                } else {
853                    setexp "${key} ICONS" " " 33 1
854                }           
855            }
856            ttref-get {
857                if {[string toupper [string range \
858                        [readexp "${key} ICONS"] 32 32]] == "T"} {
859                    return 1
860                }
861                return 0
862            }
863            ttref-set {
864                if $value {
865                    setexp "${key} ICONS" "T" 33 1
866                } else {
867                    setexp "${key} ICONS" " " 33 1
868                }           
869            }
870
871
872            pref-get {
873            #------------------------------------------------------
874            # col 34: refine flag for POLA & DIFA
875            #------------------------------------------------------
876                if {[string toupper [string range \
877                        [readexp "${key} ICONS"] 33 33]] == "P"} {
878                    return 1
879                }
880                return 0
881            }
882            pref-set {
883                if $value {
884                    setexp "${key} ICONS" "P" 34 1
885                } else {
886                    setexp "${key} ICONS" " " 34 1
887                }           
888            }
889            daref-get {
890                if {[string toupper [string range \
891                        [readexp "${key} ICONS"] 33 33]] == "A"} {
892                    return 1
893                }
894                return 0
895            }
896            daref-set {
897                if $value {
898                    setexp "${key} ICONS" "A" 34 1
899                } else {
900                    setexp "${key} ICONS" " " 34 1
901                }           
902            }
903
904            zref-get {
905            #------------------------------------------------------
906            # col 34: refine flag for zero correction
907            #------------------------------------------------------
908                if {[string toupper [string range [readexp "${key} ICONS"] 34 34]] == "Z"} {
909                    return 1
910                }
911                return 0
912            }
913            zref-set {
914                if $value {
915                    setexp "${key} ICONS" "Z" 35 1
916                } else {
917                    setexp "${key} ICONS" " " 35 1
918                }           
919            }
920
921            ddamp-get {
922                set val [string range [readexp "${key} ICONS"] 39 39]
923                if {$val == " "} {return 0}
924                return $val
925            }
926            ddamp-set {
927                setexp "${key} ICONS" $value 40 1
928            }
929
930            backtype-get {
931                set val [string trim [string range [readexp "${key}BAKGD "] 0 4]]
932                if {$val == " "} {return 0}
933                return $val
934            }
935            backtype-set {
936                if ![validint value 5] {return 0}
937                setexp "${key}BAKGD " $value 1 5
938            }
939            backterms-get {
940                set val [string trim [string range [readexp "${key}BAKGD "] 5 9]]
941                if {$val == " "} {return 0}
942                return $val
943            }
944            backterms-set {
945                # this takes a bit of work -- if terms are added, add lines as needed to the .EXP
946                set oldval [string trim [string range [readexp "${key}BAKGD "] 5 9]]
947                if ![validint value 5] {return 0}
948                if {$oldval < $value} {
949                    set line1  [expr 2 + ($oldval - 1) / 4]
950                    set line2  [expr 1 + ($value - 1) / 4]
951                    for {set i $line1} {$i <= $line2} {incr i} {
952                        # create a blank entry if needed
953                        makeexprec ${key}BAKGD$i
954                    }
955                    incr oldval
956                    for {set num $oldval} {$num <= $value} {incr num} {
957                        set f1 [expr 15*(($num - 1) % 4)]
958                        set f2 [expr 15*(1 + ($num - 1) % 4)-1]
959                        set line  [expr 1 + ($num - 1) / 4]
960                        if {[string trim [string range [readexp ${key}BAKGD$line] $f1 $f2]] == ""} {
961                            set f1 [expr 15*(($num - 1) % 4)+1]
962                            setexp ${key}BAKGD$line 0.0 $f1 15                 
963                        }
964                    }
965                }
966                setexp "${key}BAKGD " $value 6 5
967
968            }
969            bref-get {
970                if {[string toupper [string range [readexp "${key}BAKGD"] 14 14]] == "Y"} {
971                    return 1
972                }
973                return 0
974            }
975            bref-set {
976                if $value {
977                    setexp "${key}BAKGD "  "Y" 15 1
978                } else {
979                    setexp "${key}BAKGD "  "N" 15 1
980                }           
981            }
982            bdamp-get {
983                set val [string range [readexp "${key}BAKGD "] 19 19]
984                if {$val == " "} {return 0}
985                return $val
986            }
987            bdamp-set {
988                setexp "${key}BAKGD " $value 20 1
989            }
990            bterm*-get {
991                regsub bterm $parm {} num
992                set f1 [expr 15*(($num - 1) % 4)]
993                set f2 [expr 15*(1 + ($num - 1) % 4)-1]
994                set line  [expr 1 + ($num - 1) / 4]
995                return [string trim [string range [readexp ${key}BAKGD$line] $f1 $f2] ]
996            }
997            bterm*-set {
998                regsub bterm $parm {} num
999                if ![validreal value 15 6] {return 0}
1000                set f1 [expr 15*(($num - 1) % 4)+1]
1001                set line  [expr 1 + ($num - 1) / 4]
1002                setexp ${key}BAKGD$line $value $f1 15
1003            }
1004            bank-get {
1005                return [string trim [string range [readexp "${key} BANK"] 0 4]]
1006            }
1007            tofangle-get {
1008                return [string trim [string range [readexp "${key}BNKPAR"] 10 19]]
1009            }
1010            default {
1011                set msg "Unsupported histinfo access: parm=$parm action=$action"
1012                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
1013                destroy .
1014            }
1015        }
1016    }
1017    return 1
1018}
1019
1020# read the information that differs by both histogram and phase (profile & phase fraction)
1021# use: hapinfo hist phase parm action value
1022
1023#     frac -- phase fraction (*)
1024#     frref/frdamp -- refinement flag/damping value for the phase fraction (*)
1025#     proftype -- profile function number (*)
1026#     profterms -- number of profile terms (*)
1027#     pdamp -- damping value for the profile (*)
1028#     pcut -- cutoff value for the profile (*)
1029#     pterm$n -- profile term #n (*)
1030#     pref$n -- refinement flag value for profile term #n (*)
1031#     extmeth -- Fobs extraction method (*)
1032#     POnaxis -- number of defined M-D preferred axes
1033proc hapinfo {histlist phaselist parm "action get" "value {}"} {
1034    foreach phase $phaselist hist $histlist {
1035        if {$phase == ""} {set phase [lindex $phaselist end]}
1036        if {$hist == ""} {set hist [lindex $histlist end]}
1037        if {$hist < 10} {
1038            set hist " $hist"
1039        }
1040        set key "HAP${phase}${hist}"
1041        switch -glob ${parm}-$action {
1042            extmeth-get {
1043                set i1 [expr ($phase - 1)*5]
1044                set i2 [expr $i1 + 4]
1045                return [string trim [string range [readexp "HST $hist EPHAS"] $i1 $i2]]
1046            }
1047            extmeth-set {
1048                set i1 [expr ($phase - 1)*5 + 1]
1049                if ![validint value 5] {return 0}
1050                setexp "HST $hist EPHAS" $value $i1 5
1051            }
1052            frac-get {
1053                return [string trim [string range [readexp ${key}PHSFR] 0 14]]
1054            }
1055            frac-set {
1056                if ![validreal value 15 6] {return 0}
1057                setexp ${key}PHSFR $value 1 15
1058            }
1059            frref-get {
1060                if {[string toupper [string range [readexp ${key}PHSFR] 19 19]] == "Y"} {
1061                    return 1
1062                }
1063                return 0
1064            }
1065            frref-set {
1066                if $value {
1067                    setexp ${key}PHSFR "Y" 20 1
1068                } else {
1069                    setexp ${key}PHSFR "N" 20 1
1070                }           
1071            }
1072            frdamp-get {
1073                set val [string range [readexp ${key}PHSFR] 24 24]
1074                if {$val == " "} {return 0}
1075                return $val
1076            }
1077            frdamp-set {
1078                setexp ${key}PHSFR $value 25 1
1079            }
1080            proftype-get {
1081                set val [string range [readexp "${key}PRCF "] 0 4]
1082                if {$val == " "} {return 0}
1083                return $val
1084            }
1085            proftype-set {
1086                if ![validint value 5] {return 0}
1087                setexp "${key}PRCF " $value 1 5
1088            }
1089            profterms-get {
1090                set val [string range [readexp "${key}PRCF "] 5 9]
1091                if {$val == " "} {return 0}
1092                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                }
1102            }
1103            pcut-get {
1104                return [string trim [string range [readexp "${key}PRCF "] 10 19]]
1105            }
1106            pcut-set {
1107                if ![validreal value 10 5] {return 0}
1108                setexp "${key}PRCF " $value 11 10
1109            }
1110            pdamp-get {
1111                set val [string range [readexp "${key}PRCF "] 24 24]
1112                if {$val == " "} {return 0}
1113                return $val
1114            }
1115            pdamp-set {
1116                setexp "${key}PRCF   " $value 25 1
1117            }
1118            pterm*-get {
1119                regsub pterm $parm {} num
1120                set f1 [expr 15*(($num - 1) % 4)]
1121                set f2 [expr 15*(1 + ($num - 1) % 4)-1]
1122                set line  [expr 1 + ($num - 1) / 4]
1123                return [string trim [string range [readexp "${key}PRCF $line"] $f1 $f2] ]
1124            }
1125            pterm*-set {
1126                if ![validreal value 15 6] {return 0}
1127                regsub pterm $parm {} num
1128                set f1 [expr 1+ 15*(($num - 1) % 4)]
1129                set line  [expr 1 + ($num - 1) / 4]
1130                setexp "${key}PRCF $line" $value $f1 15
1131            }
1132            pref*-get {
1133                regsub pref $parm {} num
1134                set f [expr 24+$num]
1135                if {[string toupper [string range [readexp "${key}PRCF  "] $f $f]] == "Y"} {
1136                    return 1
1137                }
1138                return 0
1139            }
1140            pref*-set {
1141                regsub pref $parm {} num
1142                set f [expr 25+$num]
1143                if $value {
1144                    setexp ${key}PRCF "Y" $f 1
1145                } else {
1146                    setexp ${key}PRCF "N" $f 1
1147                }           
1148            }
1149            POnaxis-get {
1150                set val [string trim \
1151                        [string range [readexp "${key}NAXIS"] 0 4]]
1152                if {$val == ""} {return 0}
1153                return $val
1154            }
1155            POnaxis-set {
1156                if ![validint value 5] {return 0}
1157                # there should be a NAXIS record, but if not make one
1158                if {![existsexp "${key}NAXIS"]} {
1159                    makeexprec "${key}NAXIS"
1160                }
1161                setexp "${key}NAXIS  " $value 1 5
1162            }
1163            default {
1164                set msg "Unsupported hapinfo access: parm=$parm action=$action"
1165                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
1166                destroy .
1167            }
1168        }
1169    }
1170    return 1
1171}
1172
1173#  get a logical constraint
1174#
1175#  type action
1176#  -----------
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
1183# Each item in the list of constraints is composed of 4 items:
1184#              phase, atom, variable, multiplier
1185# If variable=UISO atom can be ALL, otherwise atom is a number
1186# legal variable names: FRAC, X, Y, Z, UISO, U11, U22, U33, U12, U23, U13,
1187#                       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
1203proc constrinfo {type action number "value {}"} {
1204    switch -glob ${type}-$action {
1205        atom-get {
1206            # does this constraint exist?
1207            set key [format "LNCN%4d%4d" $number 1]
1208            if {![existsexp $key]} {return -1}
1209            set clist {}
1210            for {set i 1} {$i < 999} {incr i} {
1211                set key [format "LNCN%4d%4d" $number $i]
1212                if {![existsexp $key]} break
1213                set line [readexp $key]
1214                set j1 2
1215                set j2 17
1216                set seg [string range $line $j1 $j2]
1217                while {[string trim $seg] != ""} {
1218                    lappend clist [list \
1219                            [string range $seg 0 0] \
1220                            [string trim [string range $seg 1 3]] \
1221                            [string trim [string range $seg 4 7]] \
1222                            [string trim [string range $seg 8 end]]]
1223                    incr j1 16
1224                    incr j2 16
1225                    set seg [string range $line $j1 $j2]
1226                }
1227            }
1228            return $clist
1229        }
1230        atom-set {
1231            # delete records for current constraint
1232            for {set i 1} {$i < 999} {incr i} {
1233                set key [format "LNCN%4d%4d" $number $i]
1234                if {![existsexp $key]} break
1235                delexp $key
1236            }
1237            set line {}
1238            set i 1
1239            foreach tuple $value {
1240                if {[string toupper [lindex $tuple 1]] == "ALL"} {
1241                    set seg [format %1dALL%-4s%8.4f \
1242                            [lindex $tuple 0] \
1243                            [lindex $tuple 2] \
1244                            [lindex $tuple 3]]
1245                } else {
1246                    set seg [eval format %1d%3d%-4s%8.4f $tuple]
1247                }
1248                append line $seg
1249                if {[string length $line] > 50} {
1250                    set key  [format "LNCN%4d%4d" $number $i]
1251                    makeexprec $key
1252                    setexp $key $line 3 68
1253                    set line {}
1254                    incr i
1255                }
1256            }
1257            if {$line != ""} {
1258                set key  [format "LNCN%4d%4d" $number $i]
1259                makeexprec $key
1260                setexp $key $line 3 68
1261            }
1262            return
1263        }
1264        atom-add {
1265            # loop over defined constraints
1266            for {set j 1} {$j < 9999} {incr j} {
1267                set key [format "LNCN%4d%4d" $j 1]
1268                if {![existsexp $key]} break
1269            }
1270            set number $j
1271            # save the constraint
1272            set line {}
1273            set i 1
1274            foreach tuple $value {
1275                if {[string toupper [lindex $tuple 1]] == "ALL"} {
1276                    set seg [format %1dALL%-4s%8.4f \
1277                            [lindex $tuple 0] \
1278                            [lindex $tuple 2] \
1279                            [lindex $tuple 3]]
1280                } else {
1281                    set seg [eval format %1d%3d%-4s%8.4f $tuple]
1282                }
1283                append line $seg
1284                if {[string length $line] > 50} {
1285                    set key  [format "LNCN%4d%4d" $number $i]
1286                    makeexprec $key
1287                    setexp $key $line 3 68
1288                    set line {}
1289                    incr i
1290                }
1291            }
1292            if {$line != ""} {
1293                set key  [format "LNCN%4d%4d" $number $i]
1294                makeexprec $key
1295                setexp $key $line 3 68
1296            }
1297            return
1298        }
1299        atom-delete {
1300            for {set j $number} {$j < 9999} {incr j} {
1301                # delete records for current constraint
1302                for {set i 1} {$i < 999} {incr i} {
1303                    set key [format "LNCN%4d%4d" $j $i]
1304                    if {![existsexp $key]} break
1305                    delexp $key
1306                }
1307                # now copy records, from the next entry, if any
1308                set j1 $j
1309                incr j1
1310                set key1 [format "LNCN%4d%4d" $j1 1]
1311                # if there is no record, there is nothing to copy -- done
1312                if {![existsexp $key1]} return
1313                for {set i 1} {$i < 999} {incr i} {
1314                    set key1 [format "LNCN%4d%4d" $j1 $i]
1315                    if {![existsexp $key1]} break
1316                    set key  [format "LNCN%4d%4d" $j  $i]
1317                    makeexprec $key
1318                    setexp $key [readexp $key1] 1 68
1319                }
1320            }
1321        }
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        }
1551        default {
1552            set msg "Unsupported constrinfo access: type=$type action=$action"
1553            tk_dialog .badexp "Error in EXP access" $msg error 0 OK
1554#           destroy .
1555        }
1556
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        }
1616    }
1617}
1618
1619# write the .EXP file
1620proc expwrite {expfile} {
1621    global tcl_platform exparray
1622    set blankline \
1623     "                                                                        "
1624    set fp [open ${expfile} w]
1625    set keylist [lsort [array names exparray]]
1626    # reorder the keys so that VERSION comes 1st
1627    set pos [lsearch -exact $keylist {     VERSION}]
1628    set keylist "{     VERSION} [lreplace $keylist $pos $pos]"
1629    if {$tcl_platform(platform) == "windows"} { 
1630        foreach key $keylist {
1631            puts $fp [string range \
1632                    "$key$exparray($key)$blankline" 0 79]
1633        }
1634    } else {
1635        foreach key $keylist {
1636            puts -nonewline $fp [string range \
1637                    "$key$exparray($key)$blankline" 0 79]
1638        }
1639    }
1640    close $fp
1641}
1642
1643# history commands -- delete all but last $keep history records,
1644# renumber if $renumber is true
1645proc DeleteHistory {keep renumber} {
1646    global exparray
1647    foreach y [lrange [lsort -decreasing \
1648            [array names exparray {    HSTRY*}]] $keep end] {
1649        unset exparray($y)
1650    }
1651    if !$renumber return
1652    # renumber
1653    set i 0
1654    foreach y [lsort -increasing \
1655            [array names exparray {    HSTRY*}]] {
1656        set key [format "    HSTRY%3d" [incr i]]
1657        set exparray($key) $exparray($y)
1658        unset exparray($y)
1659    }
1660    # list all history
1661    #    foreach y [lsort -decreasing [array names exparray {    HSTRY*}]] {puts "$y $exparray($y)"}
1662}
1663
1664proc CountHistory {} {
1665    global exparray
1666    return [llength [array names exparray {    HSTRY*}]]
1667}
Note: See TracBrowser for help on using the repository browser.