source: branches/sandbox/readexp.tcl @ 1106

Last change on this file since 1106 was 1106, checked in by toby, 10 years ago

more fixes to validreal for small nums; add more RB control routines

  • Property svn:keywords set to Author Date Revision Id
File size: 92.6 KB
Line 
1# $Id: readexp.tcl 1106 2010-12-30 17:32:05Z toby $
2# Routines to deal with the .EXP "data structure"
3set expmap(Revision) {$Revision: 1106 $ $Date: 2010-12-30 17:32:05 +0000 (Thu, 30 Dec 2010) $}
4
5#  The GSAS data is read from an EXP file.
6#   ... reading an EXP file into an array
7# returns -1 on error
8# returns 0 if the file is old-style UNIX format (no CR/LF)
9# returns 1 if the file is 80 char/line + cr/lf
10# returns 2 if the file is sequential but not fixed-record length
11proc expload {expfile} {
12    global exparray tcl_platform
13    # $expfile is the path to the data file.
14
15    if [catch {set fil [open "$expfile" r]}] {
16        tk_dialog .expFileErrorMsg "File Open Error" \
17                "Unable to open file $expfile" error 0 "Exit" 
18        return -1
19    }
20    fconfigure $fil -translation lf
21    set len [gets $fil line]
22    if {[string length $line] != $len} {
23        tk_dialog .expConvErrorMsg "old tcl" \
24                "You are using an old version of Tcl/Tk and your .EXP file has binary characters; run convstod or upgrade" \
25                error 0 "Exit"
26        return -1
27    }
28    catch {
29        unset exparray
30    }
31    if {$len > 160} {
32        set fmt 0
33        # a UNIX-type file
34        set i1 0
35        set i2 79
36        while {$i2 < $len} {
37            set nline [string range $line $i1 $i2]
38            incr i1 80
39            incr i2 80
40            set key [string range $nline 0 11]
41            set exparray($key) [string range $nline 12 end]
42        }
43    } else {
44        set fmt 1
45        while {$len > 0} {
46            set key [string range $line 0 11]
47            set exparray($key) [string range $line 12 79]
48            if {$len != 81 || [string range $line end end] != "\r"} {set fmt 2}
49            set len [gets $fil line]
50        }
51    }
52    close $fil
53    return $fmt
54}
55
56proc createexp {expfile title} {
57    global exparray expmap
58    catch {unset exparray}
59    foreach key   {"     VERSION" "      DESCR" "ZZZZZZZZZZZZ" " EXPR NPHAS"} \
60            value {"   6"         ""            "  Last EXP file record" ""} {
61        # truncate long keys & pad short ones
62        set key [string range "$key        " 0 11]
63        set exparray($key) $value
64    }
65    expinfo title set $title
66    exphistory add " created readexp.tcl [lindex $expmap(Revision) 1] [clock format [clock seconds] -format %Y-%m-%dT%T]"
67    expwrite $expfile
68}
69
70# get information out from an EXP file
71#   creates the following entries in global array expmap
72#     expmap(phaselist)     gives a list of defined phases
73#     expmap(phasetype)     gives the phase type for each defined phase
74#                           =1 nuclear; 2 mag+nuc; 3 mag; 4 macro
75#     expmap(atomlist_$p)   gives a list of defined atoms in phase $p
76#     expmap(htype_$n)      gives the GSAS histogram type for histogram (all)
77#     expmap(powderlist)    gives a list of powder histograms in use
78#     expmap(phaselist_$n)  gives a list of phases used in histogram $n
79#     expmap(nhst)          the number of GSAS histograms
80#
81proc mapexp {} {
82    global expgui expmap exparray
83    # clear out the old array
84    set expmap_Revision $expmap(Revision)
85    unset expmap
86    set expmap(Revision) $expmap_Revision
87    # apply any updates to the .EXP file
88    updateexpfile
89    # get the defined phases
90    set line [readexp " EXPR NPHAS"]
91#    if {$line == ""} {
92#       set msg "No EXPR NPHAS entry. This is an invalid .EXP file"
93#       tk_dialog .badexp "Error in EXP" $msg error 0 Exit
94#       destroy .
95#    }
96    set expmap(phaselist) {}
97    set expmap(phasetype) {}
98    # loop over phases
99    foreach iph {1 2 3 4 5 6 7 8 9} {
100        set i5s [expr {($iph - 1)*5}]
101        set i5e [expr {$i5s + 4}]
102        set flag [string trim [string range $line $i5s $i5e]]
103        if {$flag == ""} {set flag 0}
104        if $flag {
105            lappend expmap(phaselist) $iph
106            lappend expmap(phasetype) $flag
107        }
108    }
109    # get the list of defined atoms for each phase
110    foreach iph $expmap(phaselist) {
111        set expmap(atomlist_$iph) {}
112        if {[lindex $expmap(phasetype) [expr {$iph - 1}]] != 4} {
113            foreach key [array names exparray "CRS$iph  AT*A"] {
114                regexp { AT *([0-9]+)A} $key a num
115                lappend expmap(atomlist_$iph) $num
116            }
117        } else {
118            foreach key [array names exparray "CRS$iph  AT*"] {
119                scan [string range $key 8 11] %x atm
120                lappend expmap(atomlist_$iph) $atm
121            }
122        }
123        # note that sometimes an .EXP file contains more atoms than are actually defined
124        # drop the extra ones
125        set expmap(atomlist_$iph) [lsort -integer $expmap(atomlist_$iph)]
126        set natom [phaseinfo $iph natoms]
127        if {$natom != [llength $expmap(atomlist_$iph)]} {
128            set expmap(atomlist_$iph) [lrange $expmap(atomlist_$iph) 0 [expr {$natom-1}]]
129        }
130    }
131    # now get the histogram types
132    set expmap(nhst) [string trim [readexp { EXPR  NHST }]]
133    set n 0
134    set expmap(powderlist) {}
135    for {set i 0} {$i < $expmap(nhst)} {incr i} {
136        set ihist [expr {$i + 1}]
137        if {[expr {$i % 12}] == 0} {
138            incr n
139            set line [readexp " EXPR  HTYP$n"]
140            if {$line == ""} {
141                set msg "No HTYP$n entry for Histogram $ihist. This is an invalid .EXP file"
142                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
143            }
144            set j 0
145        } else {
146            incr j
147        }
148        set expmap(htype_$ihist) [string range $line [expr 2+5*$j] [expr 5*($j+1)]]
149        # is this a dummy histogram?
150        if {$ihist <=9} {
151            set key "HST  $ihist DUMMY"
152        } else {
153            set key "HST $ihist DUMMY"
154        }
155        # at least for now, ignore non-powder histograms
156        if {[string range $expmap(htype_$ihist) 0 0] == "P" && \
157                [string range $expmap(htype_$ihist) 3 3] != "*"} {
158            if {[existsexp $key]} {
159                set expmap(htype_$ihist) \
160                        [string range $expmap(htype_$ihist) 0 2]D
161            }
162            lappend expmap(powderlist) $ihist
163        }
164    }
165
166    # now process powder histograms
167    foreach ihist $expmap(powderlist) {
168        # make a 2 digit key -- hh
169        if {$ihist < 10} {
170            set hh " $ihist"
171        } else {
172            set hh $ihist
173        }
174        set line [readexp "HST $hh NPHAS"]
175        if {$line == ""} {
176            set msg "No NPHAS entry for Histogram $ihist. This is an invalid .EXP file"
177            tk_dialog .badexp "Error in readexp" $msg error 0 Exit
178        }
179        set expmap(phaselist_$ihist) {}
180        # loop over phases
181        foreach iph {1 2 3 4 5 6 7 8 9} {
182            set i5s [expr {($iph - 1)*5}]
183            set i5e [expr {$i5s + 4}]
184            set flag [string trim [string range $line $i5s $i5e]]
185            if {$flag == ""} {set flag 0}
186            if $flag {lappend expmap(phaselist_$ihist) $iph}
187        }
188    }
189    set expgui(mapstat) 1
190}
191
192# this routine is called to update changes in the .EXP file
193proc updateexpfile {} {
194    global exparray
195    # change "CRSx  ODFxxx" records to "CRSx  OD xxx" records
196    # needed by the June 8, 2005 GSAS release
197    set ODFlist [array names exparray "CRS?  ODF*"]
198    if {[llength $ODFlist] > 0} {
199        catch {incr ::expgui(changed)}
200        foreach key $ODFlist {
201            regsub "ODF" $key "OD " newkey
202            set exparray($newkey) $exparray($key)
203            unset exparray($key)
204        }
205    }
206}
207
208
209# return the value for a ISAM key
210proc readexp {key} {
211    global exparray
212    # truncate long keys & pad short ones
213    set key [string range "$key        " 0 11]
214    if [catch {set val $exparray($key)}] {
215        global expgui
216        if $expgui(debug) {puts "Error accessing record $key"}
217        return ""
218    }
219    return $val
220}
221
222# return the number of records matching ISAM key (may contain wildcards)
223proc existsexp {key} {
224    global exparray
225    # key can contain wild cards so don't pad
226    return [llength [array names exparray  $key]]
227}
228
229
230# replace a section of the exparray with $value
231#   replace $char characters starting at character $start (numbered from 1)
232proc setexp {key value start chars} {
233    global exparray
234    # truncate long keys & pad short ones
235    set key [string range "$key        " 0 11]
236    if [catch {set exparray($key)}] {
237        global expgui
238        if $expgui(debug) {puts "Error accessing record $key"}
239        return ""
240    }
241
242    # pad value to $chars
243    set l0 [expr {$chars - 1}]
244    set value [string range "$value                                           " 0 $l0]
245
246    if {$start == 1} {
247        set ret {}
248        set l1 $chars
249    } else {
250        set l0 [expr {$start - 2}]
251        set l1 [expr {$start + $chars - 1}]
252        set ret [string range $exparray($key) 0 $l0]
253    }
254    append ret $value [string range $exparray($key) $l1 end]
255    set exparray($key) $ret
256}
257
258proc makeexprec {key} {
259    global exparray
260    # truncate long keys & pad short ones
261    set key [string range "$key        " 0 11]
262    if [catch {set exparray($key)}] {
263        # set to 68 blanks
264        set exparray($key) [format %68s " "]
265    }
266}
267
268# delete an exp record
269# returns 1 if OK; 0 if not found
270proc delexp {key} {
271    global exparray
272    # truncate long keys & pad short ones
273    set key [string range "$key        " 0 11]
274    if [catch {unset exparray($key)}] {
275        return 0
276    }
277    return 1
278}
279
280# test an argument if it is a valid number; reform the number to fit
281proc validreal {val length decimal} {
282    upvar $val value
283    # is this a number?
284    if [catch {expr {$value}}] {return 0}
285    if [catch {
286        # how many digits are needed to the left of the decimal?
287        set sign 0
288        if {$value > 0} {
289            set digits [expr {1 + int(log10($value))}]
290        } elseif {$value < 0} {
291            set digits [expr {1 + int(log10(-$value))}]
292            set sign 1
293        } else {
294            set digits 1
295        }
296        if {$digits <= 0} {set digits 1}
297        if {$digits + $sign >= $length} {
298            # the number is much too big -- use exponential notation
299            set decimal [expr {$length - 6 - $sign}]
300            # drop more decimal places, as needed
301            set tmp [format "%${length}.${decimal}E" $value]
302            while {[string length $tmp] > $length && $decimal >= 0} {
303                incr decimal -1
304                set tmp [format "%${length}.${decimal}E" $value]
305            }
306        } elseif {$digits + $sign >= $length - $decimal} {
307            # we will have to trim the number of decimal digits
308            set decimal [expr {$length - $digits - $sign - 1}]
309            set tmp [format "%#.${decimal}f" $value]
310        } elseif {abs($value) < pow(10,2-$decimal) && $length > 6 && $value != 0} {
311            # for small values, switch to exponential notation (2-$decimal -> three sig figs.)
312            set decimal [expr {$length - 6 - $sign}]
313            # drop more decimal places, as needed
314            set tmp [format "%${length}.${decimal}E" $value]
315            while {[string length $tmp] > $length && $decimal >= 0} {
316                incr decimal -1
317                set tmp [format "%${length}.${decimal}E" $value]
318            }
319        } else {
320            # use format as specified
321            set tmp [format "%${length}.${decimal}f" $value]
322        }
323        set value $tmp
324    } errmsg] {return 0}
325    return 1
326}
327
328# test an argument if it is a valid integer; reform the number into
329# an integer, if appropriate -- be sure to pass the name of the variable not the value
330proc validint {val length} {
331    upvar $val value
332    # FORTRAN type assumption: blank is 0
333    if {$value == ""} {set value 0}
334    if [catch {
335        set tmp [expr {round($value)}]
336        if {$tmp != $value} {return 0}
337        set value [format "%${length}d" $tmp]
338    }] {return 0}
339    return 1
340}
341
342# process history information
343#    action == last
344#       returns number and value of last record
345#    action == add
346#
347proc exphistory {action "value 0"} {
348    global exparray
349    if {$action == "last"} {
350        set key [lindex [lsort -decreasing [array names exparray *HSTRY*]] 0]
351        if {$key == ""} {return ""}
352        return [list [string trim [string range $key 9 end]] $exparray($key)]
353    } elseif {$action == "add"} {
354        set key [lindex [lsort -decreasing [array names exparray *HSTRY*]] 0]
355        if {$key == ""} {
356            set index 1
357        } else {
358            set index [string trim [string range $key 9 end]]
359            if {$index != "***"} {
360                if {$index < 999} {incr index}
361                set key [format "    HSTRY%3d" $index]
362                set exparray($key) $value
363            }
364        }
365        set key [format "    HSTRY%3d" $index]
366        set exparray($key) $value
367    }
368}
369# get overall info
370#   parm:
371#     print     -- GENLES print option (*)
372#     cycles    -- number of GENLES cycles (*)
373#     title     -- the overall title (*)
374#     convg     -- convergence criterion: -200 to 200 (*)
375#     marq      -- Marquardt damping factor: 1.0 to 9.99 (*)
376#     mbw       -- LS matrix bandwidth; =0 for full matrix (*)
377proc expinfo {parm "action get" "value {}"} {
378    switch ${parm}-$action {
379        title-get {
380            return [string trim [readexp "      DESCR"]]
381        }
382        title-set {
383            setexp "      DESCR" "  $value" 2 68
384        }
385        cycles-get {
386            return [string trim [cdatget MXCY]]
387        }
388        cycles-set {
389            if ![validint value 1] {return 0}
390            cdatset MXCY [format %4d $value]
391        }
392        cyclesrun-get {
393            set cycle -1
394            regexp {.*cycles run *([0-9]*) } [readexp "  GNLS  RUN"] x cycle
395            return $cycle
396        }
397        print-get {
398            set print [string trim [cdatget PRNT]]
399            if {$print != ""} {return $print}
400            return 0
401        }
402        print-set {
403            if ![validint value 1] {return 0}
404            cdatset PRNT [format %4d $value]
405        }
406        convg-get {
407            set cvg [string trim [cdatget CVRG]]
408            if {$cvg == ""} {return -200}
409            if [catch {expr {$cvg}}] {return -200}
410            return $cvg
411        }
412        convg-set {
413            if ![validint value 1] {return 0}
414            set value [expr {-200>$value?-200:$value}]
415            set value [expr {200<$value?200:$value}]
416            cdatset CVRG [format %4d $value]
417        }
418        marq-get {
419            set mar [string trim [cdatget MARQ]]
420            if {$mar == ""} {return 1.0}
421            if [catch {expr $mar}] {return 1.}
422            return $mar
423        }
424        marq-set {
425            if [catch {
426                set value [expr {1.0>$value?1.0:$value}]
427                set value [expr {9.99<$value?9.99:$value}]
428            }] {return 0}
429            if ![validreal value 4 2] {return 0}
430            cdatset MARQ $value
431        }
432        mbw-get {
433            set mbw [string trim [cdatget MBW]]
434            if {$mbw == ""} {return 0}
435            if [catch {expr $mbw}] {return 0}
436            return $mbw
437        }
438        mbw-set {
439            if ![validint value 1] {return 0}
440            if {$value < 0} {return 0}
441            cdatset MBW [format %5d $value]
442        }
443        default {
444            set msg "Unsupported expinfo access: parm=$parm action=$action"
445            tk_dialog .badexp "Error in readexp" $msg error 0 Exit
446        }
447    }
448    return 1
449}
450
451proc cdatget {key} {
452    foreach i {1 2 3 4 5 6 7 8 9} {
453        if {[existsexp "  GNLS CDAT$i"] == 0} break
454        set line [readexp "  GNLS CDAT$i"]
455        if {$line == {}} break
456        foreach i1 {2 10 18 26 34 42 50 58 66} \
457                i2 {9 17 25 33 41 49 57 65 73} {
458            set item [string range $line $i1 $i2]
459            if {[string trim $item] == {}} continue
460            if [regexp "${key}(.*)" $item a b] {return $b}
461        }
462    }
463    return {}
464}
465
466proc cdatset {key value} {
467    # round 1 see if we can find the string
468    foreach i {1 2 3 4 5 6 7 8 9} {
469        set line [readexp "  GNLS CDAT$i"]
470        if {$line == {}} break
471        foreach i1 {2 10 18 26 34 42 50 58 66} \
472                i2 {9 17 25 33 41 49 57 65 73} {
473            set item [string range $line $i1 $i2]
474            if {[string trim $item] == {}} continue
475            if [regexp "${key}(.*)" $item a b] {
476                # found it now replace it
477                incr i1
478                setexp "  GNLS CDAT$i" "${key}${value}" $i1 8
479                return
480            }
481        }
482    }
483    # not found, take the 1st blank space, creating a card if needed
484    foreach i {1 2 3 4 5 6 7 8 9} {
485        set line [readexp "  GNLS CDAT$i"]
486        if {$line == {}} {makeexprec "  GNLS CDAT$i"}
487        foreach i1 {2 10 18 26 34 42 50 58 66} \
488                i2 {9 17 25 33 41 49 57 65 73} {
489            set item [string range $line $i1 $i2]
490            if {[string trim $item] == {}} {
491                # found a blank space: now replace it
492                incr i1
493                setexp "  GNLS CDAT$i" "${key}${value}" $i1 8
494                return
495            }
496        }
497    }
498    return {}
499}
500
501proc disagldat_get {phase} {
502    set key "  DSGL CDAT$phase"
503    if {[existsexp $key] == 0} {return "{none} {none}"}
504    set line [readexp $key]
505    set i1 2
506    # read atom-atom distance parameter
507    set dist {}
508    set item [string range $line $i1 [expr {$i1+3}]]
509    if {$item == "DMAX"} {
510        set val [string range $line [expr {$i1+4}] [expr {$i1+11}]]
511        set dist [string trim $val]
512        incr i1 13
513    } else {
514        set dist "radii"
515        incr i1 5
516    }
517    # read atom-atom-atom angle parameter
518    set ang {}
519    set item [string range $line $i1 [expr {$i1+3}]]
520    if {$item == "DAGL"} {
521        set val [string range $line [expr {$i1+4}] [expr {$i1+11}]]
522        set ang [string trim $val]
523        incr i1 13
524    } else {
525        set ang "radii"
526        incr i1 5
527    }
528    # note there are two more parameters, NOFO/FORA & ONCR/DFLT, but they are not being processed yet
529    return "$dist $ang"
530}
531
532# get phase information: phaseinfo phase parm action value
533#   phase: 1 to 9 (as defined)
534#   parm:
535#     name -- phase name
536#     natoms -- number of atoms (*)
537#     a b c alpha beta gamma -- cell parameters (*)
538#     cellref -- refinement flag for the unit cell(*)
539#     celldamp  -- damping for the unit cell refinement (*)
540#     spacegroup -- space group symbol (*)
541#     ODForder -- spherical harmonic order (*)
542#     ODFsym   -- sample symmetry (0-3) (*)
543#     ODFdampA -- damping for angles (*)
544#     ODFdampC -- damping for coefficients (*)
545#     ODFomega -- omega oriention angle (*)
546#     ODFchi -- chi oriention angle (*)
547#     ODFphi -- phi oriention angle (*)
548#     ODFomegaRef -- refinement flag for omega (*)
549#     ODFchiRef -- refinement flag for chi (*)
550#     ODFphiRef -- refinement flag for phi (*)
551#     ODFterms -- a list of the {l m n} values for each ODF term (*)
552#     ODFcoefXXX -- the ODF coefficient for for ODF term XXX (*)
553#     ODFRefcoef -- refinement flag for ODF terms (*)
554#     DistCalc   -- returns "radii", "none" or a number (*)
555#                   none: no distance or angle computation for the phase
556#                   radii: computation will be done by sums of radii
557#                          (see AtmTypInfo and DefAtmTypInfo)
558#                   other: a distance specifing the maximum distance
559#     AngCalc    -- returns "radii", "none" or a number (*)
560#                   none: no distance or angle computation for the phase
561#                   radii: computation will be done by sums of radii
562#                          (see AtmTypInfo and DefAtmTypInfo)
563#                   other: a distance specifing the maximum distance
564#  action: get (default) or set
565#  value: used only with set
566#  * =>  read+write supported
567proc phaseinfo {phase parm "action get" "value {}"} {
568    switch -glob ${parm}-$action {
569
570        name-get {
571            return [string trim [readexp "CRS$phase    PNAM"]]
572        }
573
574        name-set {
575            setexp "CRS$phase    PNAM" " $value" 2 68
576        }
577
578        spacegroup-get {
579            return [string trim [readexp "CRS$phase  SG SYM"]]
580        }
581
582        spacegroup-set {
583            setexp "CRS$phase  SG SYM" " $value" 2 68
584        }
585
586        natoms-get {
587            return [string trim [readexp "CRS$phase   NATOM"]]     
588        }
589
590        natoms-set {
591            if ![validint value 5] {return 0}
592            setexp "CRS$phase   NATOM" $value 1 5
593        }
594
595        a-get {
596           return [string trim [string range [readexp "CRS$phase  ABC"] 0 9]]
597        }
598        b-get {
599           return [string trim [string range [readexp "CRS$phase  ABC"] 10 19]]
600        }
601        c-get {
602           return [string trim [string range [readexp "CRS$phase  ABC"] 20 29]]
603        }
604        alpha-get {
605           return [string trim [string range [readexp "CRS$phase  ANGLES"] 0 9]]
606        }
607        beta-get {
608           return [string trim [string range [readexp "CRS$phase  ANGLES"] 10 19]]
609        }
610        gamma-get {
611           return [string trim [string range [readexp "CRS$phase  ANGLES"] 20 29]]
612        }
613
614        a-set {
615            if ![validreal value 10 6] {return 0}
616            setexp "CRS$phase  ABC" $value 1 10             
617        }
618        b-set {
619            if ![validreal value 10 6] {return 0}
620            setexp "CRS$phase  ABC" $value 11 10           
621        }
622        c-set {
623            if ![validreal value 10 6] {return 0}
624            setexp "CRS$phase  ABC" $value 21 10           
625        }
626        alpha-set {
627            if ![validreal value 10 4] {return 0}
628            setexp "CRS$phase  ANGLES" $value 1 10         
629        }
630        beta-set {
631            if ![validreal value 10 4] {return 0}
632            setexp "CRS$phase  ANGLES" $value 11 10         
633        }
634        gamma-set {
635            if ![validreal value 10 4] {return 0}
636            setexp "CRS$phase  ANGLES" $value 21 10         
637        }
638        cellref-get {
639            if {[string toupper [string range [readexp "CRS$phase  ABC"] 34 34]] == "Y"} {
640                return 1
641            }
642            return 0
643        }
644        cellref-set {
645            if $value {
646                setexp "CRS$phase  ABC" "Y" 35 1
647            } else {
648                setexp "CRS$phase  ABC" "N" 35 1
649            }       
650        }
651        celldamp-get {
652            set val [string range [readexp "CRS$phase  ABC"] 39 39]
653            if {$val == " "} {return 0}
654            return $val
655        }
656        celldamp-set {
657            setexp "CRS$phase  ABC" $value 40 1
658        }
659
660        ODForder-get {
661            set val [string trim [string range [readexp "CRS$phase  OD "] 0 4]]
662            if {$val == " "} {return 0}
663            return $val
664        }
665        ODForder-set {
666            if ![validint value 5] {return 0}
667            setexp "CRS$phase  OD " $value 1 5
668        }
669        ODFsym-get {
670            set val [string trim [string range [readexp "CRS$phase  OD "] 10 14]]
671            if {$val == " "} {return 0}
672            return $val
673        }
674        ODFsym-set {
675            if ![validint value 5] {return 0}
676            setexp "CRS$phase  OD " $value 11 5
677        }
678        ODFdampA-get {
679            set val [string range [readexp "CRS$phase  OD "] 24 24]
680            if {$val == " "} {return 0}
681            return $val
682        }
683        ODFdampA-set {
684            setexp "CRS$phase  OD " $value 25 1
685        }
686        ODFdampC-get {
687            set val [string range [readexp "CRS$phase  OD "] 29 29]
688            if {$val == " "} {return 0}
689            return $val
690        }
691        ODFdampC-set {
692            setexp "CRS$phase  OD " $value 30 1
693        }
694        ODFomegaRef-get {
695            if {[string toupper [string range [readexp "CRS$phase  OD "] 16 16]] == "Y"} {
696                return 1
697            }
698            return 0
699        }
700        ODFomegaRef-set {
701            if $value {
702                setexp "CRS$phase  OD " "Y" 17 1
703            } else {
704                setexp "CRS$phase  OD " "N" 17 1
705            }       
706        }
707        ODFchiRef-get {
708            if {[string toupper [string range [readexp "CRS$phase  OD "] 17 17]] == "Y"} {
709                return 1
710            }
711            return 0
712        }
713        ODFchiRef-set {
714            if $value {
715                setexp "CRS$phase  OD " "Y" 18 1
716            } else {
717                setexp "CRS$phase  OD " "N" 18 1
718            }       
719        }
720        ODFphiRef-get {
721            if {[string toupper [string range [readexp "CRS$phase  OD "] 18 18]] == "Y"} {
722                return 1
723            }
724            return 0
725        }
726        ODFphiRef-set {
727            if $value {
728                setexp "CRS$phase  OD " "Y" 19 1
729            } else {
730                setexp "CRS$phase  OD " "N" 19 1
731            }       
732        }
733        ODFcoef*-get {
734            regsub ODFcoef $parm {} term
735            set k [expr {($term+5)/6}]
736            if {$k <= 9} {
737                set k "  $k"
738            } elseif {$k <= 99} {
739                set k " $k"
740            }
741            set j [expr {(($term-1) % 6)+1}]
742            set lineB [readexp "CRS$phase  OD${k}B"]
743            set j0 [expr { ($j-1) *10}]
744            set j1 [expr {$j0 + 9}]
745            set val [string trim [string range $lineB $j0 $j1]]
746            if {$val == ""} {return 0.0}
747            return $val
748        }
749        ODFcoef*-set {
750            regsub ODFcoef $parm {} term
751            if ![validreal value 10 3] {return 0}
752            set k [expr {($term+5)/6}]
753            if {$k <= 9} {
754                set k "  $k"
755            } elseif {$k <= 99} {
756                set k " $k"
757            }
758            set j [expr {(($term-1) % 6)+1}]
759            set col [expr { ($j-1)*10 + 1}]
760            setexp "CRS$phase  OD${k}B" $value $col 10
761        }
762        ODFRefcoef-get {
763            if {[string toupper [string range [readexp "CRS$phase  OD "] 19 19]] == "Y"} {
764                return 1
765            }
766            return 0
767        }
768        ODFRefcoef-set {
769            if $value {
770                setexp "CRS$phase  OD " "Y" 20 1
771            } else {
772                setexp "CRS$phase  OD " "N" 20 1
773            }       
774        }
775        ODFomega-get {
776           return [string trim [string range [readexp "CRS$phase  OD "] 30 39]]
777        }
778        ODFchi-get {
779           return [string trim [string range [readexp "CRS$phase  OD "] 40 49]]
780        }
781        ODFphi-get {
782           return [string trim [string range [readexp "CRS$phase  OD "] 50 59]]
783        }
784        ODFomega-set {
785            if ![validreal value 10 4] {return 0}
786            setexp "CRS$phase  OD " $value 31 10
787        }
788        ODFchi-set {
789            if ![validreal value 10 4] {return 0}
790            setexp "CRS$phase  OD " $value 41 10
791        }
792        ODFphi-set {
793            if ![validreal value 10 4] {return 0}
794            setexp "CRS$phase  OD " $value 51 10
795        }
796
797        ODFterms-get {
798            set vallist {}
799            set val [string trim [string range [readexp "CRS$phase  OD "] 5 9]]
800            for {set i 1} {$i <= $val} {incr i 6} {
801                set k [expr {1+($i-1)/6}]
802                if {$k <= 9} {
803                    set k "  $k"
804                } elseif {$k <= 99} {
805                    set k " $k"
806                }
807                set lineA [readexp "CRS$phase  OD${k}A"]
808                set k 0
809                for {set j $i} {$j <= $val && $j < $i+6} {incr j} {
810                    set j0 [expr {($k)*10}]
811                    set j1 [expr {$j0 + 9}]
812                    lappend vallist [string trim [string range $lineA $j0 $j1]]
813                    incr k
814                }
815            }
816            return $vallist
817        }
818        ODFterms-set {
819            set key "CRS$phase  OD    "
820            if {![existsexp $key]} {
821                makeexprec $key
822                set oldlen 0
823            } else {
824                set oldlen [string trim [string range [readexp $key] 5 9]]
825            }
826            set len [llength $value]
827            if ![validint len 5] {return 0}
828            setexp $key $len 6 5
829            set j 0
830            set k 0
831            foreach item $value {
832                incr j
833                if {$j % 6 == 1} {
834                    incr k
835                    if {$k <= 9} {
836                        set k "  $k"
837                    } elseif {$k <= 99} {
838                        set k " $k"
839                    }
840                    set col 1
841                    set keyA "CRS$phase  OD${k}A"
842                    set keyB "CRS$phase  OD${k}B"
843                    if {![existsexp $keyA]} {
844                        makeexprec $keyA
845                        makeexprec $keyB
846                    }
847                }
848                set col1 [expr {$col + 1}]
849                foreach n [lrange $item 0 2] {
850                    if ![validint n 3] {return 0}
851                    setexp $keyA $n $col1 3
852                    incr col1 3
853                }
854                incr col 10
855            }
856            for {incr j} {$j <= $oldlen} {incr j} {
857                if {$j % 6 == 1} {
858                    incr k
859                    if {$k <= 9} {
860                        set k "  $k"
861                    } elseif {$k <= 99} {
862                        set k " $k"
863                    }
864                    set col 1
865                    set keyA "CRS$phase  OD${k}A"
866                    set keyB "CRS$phase  OD${k}B"
867                    delexp $keyA
868                    delexp $keyB
869                }
870                if {[existsexp $keyA]} {
871                    setexp $keyA "          " $col 10
872                    setexp $keyB "          " $col 10
873                }
874                incr col 10
875            }
876        }
877        DistCalc-get {
878            set val [disagldat_get $phase]
879            return [lindex $val 0]
880        }
881        DistCalc-set {
882            set key "  DSGL CDAT$phase"
883            # for none delete the record & thats all folks
884            if {$value == "none"} {
885                catch {unset ::exparray($key)}
886                return
887            }
888            if {[existsexp $key] == 0} {
889                makeexprec $key
890            }
891            set line [readexp $key]
892            if {[string trim $line] == ""} {
893                # blank set to defaults
894                set line [string replace $line 2 15 "DRAD ARAD NOFO"]
895            }
896            if {$value == "radii"} {
897                if {[string range $line 2 5] == "DMAX"} {
898                    set line [string replace $line 2 13 "DRAD"]
899                } else {
900                    set line [string replace $line 2 5 "DRAD"]
901                }
902            } else {
903                if ![validreal value 8 2] {return 0}
904                if {[string range $line 2 5] == "DMAX"} {
905                    set line [string replace $line 6 13 $value]
906                } else {
907                    set line [string replace $line 2 5 "DMAX"]
908                    set line [string replace $line 6 6 "$value "]
909                }
910            }
911            setexp $key $line 0 68
912        }
913        AngCalc-get {
914            set val [disagldat_get $phase]
915            return [lindex $val 1]
916        }
917        AngCalc-set {
918            set key "  DSGL CDAT$phase"
919            # for none delete the record & thats all folks
920            if {$value == "none"} {
921                catch {unset ::exparray($key)}
922                return
923            }
924            if {[existsexp $key] == 0} {
925                makeexprec $key
926            }
927            set line [readexp $key]
928            if {[string trim $line] == ""} {
929                # blank set to defaults
930                set line [string replace $line 2 15 "DRAD ARAD NOFO"]
931            }
932            if {[string range $line 2 5] == "DMAX"} {
933                set i2 8
934            } else {
935                set i2 0
936            }
937            if {$value == "radii"} {
938                if {[string range $line [expr {$i2+7}] [expr {$i2+10}]] == "DAGL"} {
939                    set line [string replace $line [expr {$i2+7}] [expr {$i2+18}] "ARAD"]
940                } else {
941                    set line [string replace $line [expr {$i2+7}] [expr {$i2+10}] "ARAD"]
942                }
943            } else {
944                if ![validreal value 8 2] {return 0}
945                if {[string range $line [expr {$i2+7}] [expr {$i2+10}]] == "DAGL"} {
946                    set line [string replace $line [expr {$i2+11}] [expr {$i2+18}] $value]
947                } else {
948                    set line [string replace $line [expr {$i2+7}] [expr {$i2+10}] "DAGL"]
949                    set line [string replace $line [expr {$i2+11}] [expr {$i2+11}] "$value "]
950                }
951            }
952            setexp $key $line 0 68
953        }
954        default {
955            set msg "Unsupported phaseinfo access: parm=$parm action=$action"
956            tk_dialog .badexp "Error in readexp" $msg error 0 Exit
957        }
958    }
959    return 1
960}
961
962
963
964# get atom information: atominfo phase atom parm action value
965#   phase: 1 to 9 (as defined)
966#   atom: a valid atom number [see expmap(atomlist_$phase)]
967#      Note that atom and phase can be paired lists, but if there are extra
968#      entries in the atoms list, the last phase will be repeated.
969#      so that atominfo 1 {1 2 3} xset 1
970#               will set the xflag for atoms 1-3 in phase 1
971#      but atominfo {1 2 3} {1 1 1} xset 1
972#               will set the xflag for atoms 1 in phase 1-3
973#   parm:
974#     type -- element code
975#     mult -- atom multiplicity
976#     label -- atom label (*)
977#     x y z -- coordinates (*)
978#     frac --  occupancy (*)
979#     temptype -- I or A for Isotropic/Anisotropic (*)
980#     Uiso  -- Isotropic temperature factor (*)
981#     U11  -- Anisotropic temperature factor (*)
982#     U22  -- Anisotropic temperature factor (*)
983#     U33  -- Anisotropic temperature factor (*)
984#     U12  -- Anisotropic temperature factor (*)
985#     U13  -- Anisotropic temperature factor (*)
986#     U23  -- Anisotropic temperature factor (*)
987#     xref/xdamp -- refinement flag/damping value for the coordinates (*)
988#     uref/udamp -- refinement flag/damping value for the temperature factor(s)  (*)
989#     fref/fdamp -- refinement flag/damping value for the occupancy (*)
990#  action: get (default) or set
991#  value: used only with set
992#  * =>  read+write supported
993proc atominfo {phaselist atomlist parm "action get" "value {}"} {
994    foreach phase $phaselist atom $atomlist {
995        if {$phase == ""} {set phase [lindex $phaselist end]}
996        if {$atom < 10} {
997            set key "CRS$phase  AT  $atom"
998        } elseif {$atom < 100} {
999            set key "CRS$phase  AT $atom"
1000        } else {
1001            set key "CRS$phase  AT$atom"
1002        }
1003        switch -glob ${parm}-$action {
1004            type-get {
1005                return [string trim [string range [readexp ${key}A] 2 9] ]
1006            }
1007            mult-get {
1008                return [string trim [string range [readexp ${key}A] 58 61] ]
1009            }
1010            label-get {
1011                return [string trim [string range [readexp ${key}A] 50 57] ]
1012            }
1013            label-set {
1014                setexp ${key}A $value 51 8
1015            }
1016            temptype-get {
1017                return [string trim [string range [readexp ${key}B] 62 62] ]
1018            }
1019            temptype-set {
1020                if {$value == "A"} {
1021                    setexp ${key}B A 63 1
1022                    # copy the Uiso to the diagonal terms
1023                    set Uiso [string range [readexp ${key}B] 0 9]
1024                    foreach value [CalcAniso $phase $Uiso] \
1025                            col {1 11 21 31 41 51} {
1026                        validreal value 10 6
1027                        setexp ${key}B $value $col 10
1028                    }
1029                } else {
1030                    setexp ${key}B I 63 1
1031                    set value 0.0
1032                    catch {
1033                        # get the trace
1034                        set value [expr {( \
1035                                [string range [readexp ${key}B] 0 9] + \
1036                                [string range [readexp ${key}B] 10 19] + \
1037                                [string range [readexp ${key}B] 20 29])/3.}]
1038                    }
1039                    validreal value 10 6
1040                    setexp ${key}B $value 1 10
1041                    # blank out the remaining terms
1042                    set value " "
1043                    setexp ${key}B $value 11 10
1044                    setexp ${key}B $value 21 10
1045                    setexp ${key}B $value 31 10
1046                    setexp ${key}B $value 41 10
1047                    setexp ${key}B $value 51 10
1048                }
1049            }
1050            x-get {
1051                return [string trim [string range [readexp ${key}A] 10 19] ]
1052            }
1053            x-set {
1054                if ![validreal value 10 6] {return 0}
1055                setexp ${key}A $value 11 10
1056            }
1057            y-get {
1058                return [string trim [string range [readexp ${key}A] 20 29] ]
1059            }
1060            y-set {
1061                if ![validreal value 10 6] {return 0}
1062                setexp ${key}A $value 21 10
1063            }
1064            z-get {
1065                return [string trim [string range [readexp ${key}A] 30 39] ]
1066            }
1067            z-set {
1068                if ![validreal value 10 6] {return 0}
1069                setexp ${key}A $value 31 10
1070            }
1071            frac-get {
1072                return [string trim [string range [readexp ${key}A] 40 49] ]
1073            }
1074            frac-set {
1075                if ![validreal value 10 6] {return 0}
1076                setexp ${key}A $value 41 10
1077            }
1078            U*-get {
1079                regsub U $parm {} type
1080                if {$type == "iso" || $type == "11"} {
1081                    return [string trim [string range [readexp ${key}B] 0 9] ]
1082                } elseif {$type == "22"} {
1083                    return [string trim [string range [readexp ${key}B] 10 19] ]
1084                } elseif {$type == "33"} {
1085                    return [string trim [string range [readexp ${key}B] 20 29] ]
1086                } elseif {$type == "12"} {
1087                    return [string trim [string range [readexp ${key}B] 30 39] ]
1088                } elseif {$type == "13"} {
1089                    return [string trim [string range [readexp ${key}B] 40 49] ]
1090                } elseif {$type == "23"} {
1091                    return [string trim [string range [readexp ${key}B] 50 59] ]
1092                }
1093            }
1094            U*-set {
1095                if ![validreal value 10 6] {return 0}
1096                regsub U $parm {} type
1097                if {$type == "iso" || $type == "11"} {
1098                    setexp ${key}B $value 1 10
1099                } elseif {$type == "22"} {
1100                    setexp ${key}B $value 11 10
1101                } elseif {$type == "33"} {
1102                    setexp ${key}B $value 21 10
1103                } elseif {$type == "12"} {
1104                    setexp ${key}B $value 31 10
1105                } elseif {$type == "13"} {
1106                    setexp ${key}B $value 41 10
1107                } elseif {$type == "23"} {
1108                    setexp ${key}B $value 51 10
1109                }
1110            }
1111            xref-get {
1112                if {[string toupper [string range [readexp ${key}B] 64 64]] == "X"} {
1113                    return 1
1114                }
1115                return 0
1116            }
1117            xref-set {
1118                if $value {
1119                    setexp ${key}B "X" 65 1
1120                } else {
1121                    setexp ${key}B " " 65 1
1122                }           
1123            }
1124            xdamp-get {
1125                set val [string range [readexp ${key}A] 64 64]
1126                if {$val == " "} {return 0}
1127                return $val
1128            }
1129            xdamp-set {
1130                setexp ${key}A $value 65 1
1131            }
1132            fref-get {
1133                if {[string toupper [string range [readexp ${key}B] 63 63]] == "F"} {
1134                    return 1
1135                }
1136                return 0
1137            }
1138            fref-set {
1139                if $value {
1140                    setexp ${key}B "F" 64 1
1141                } else {
1142                    setexp ${key}B " " 64 1
1143                }           
1144            }
1145            fdamp-get {
1146                set val [string range [readexp ${key}A] 63 63]
1147                if {$val == " "} {return 0}
1148                return $val
1149            }
1150            fdamp-set {
1151                setexp ${key}A $value 64 1
1152            }
1153
1154            uref-get {
1155                if {[string toupper [string range [readexp ${key}B] 65 65]] == "U"} {
1156                    return 1
1157                }
1158                return 0
1159            }
1160            uref-set {
1161                if $value {
1162                    setexp ${key}B "U" 66 1
1163                } else {
1164                    setexp ${key}B " " 66 1
1165                }           
1166            }
1167            udamp-get {
1168                set val [string range [readexp ${key}A] 65 65]
1169                if {$val == " "} {return 0}
1170                return $val
1171            }
1172            udamp-set {
1173                setexp ${key}A $value 66 1
1174            }
1175            default {
1176                set msg "Unsupported atominfo access: parm=$parm action=$action"
1177                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
1178            }
1179        }
1180    }
1181    return 1
1182}
1183
1184# get macromolecular atom information: mmatominfo phase atom parm action value
1185#   phase: 1 (at present only one mm phase can be defined)
1186#   atom: a valid atom number [see expmap(atomlist_$phase)]
1187#      Note that atoms can be lists
1188#      so that mmatominfo 1 {1 2 3} xset 1
1189#               will set the xflag for atoms 1-3 in phase 1
1190#   parm:
1191#     type -- element code
1192#     frac --  occupancy (*)
1193#     x y z -- coordinates (*)
1194#     Uiso  -- Isotropic temperature factor (*)
1195#     label -- atom label (*)
1196#     residue -- residue label (*)
1197#     group -- group label (*)
1198#     resnum -- residue number (*)
1199#     xref/xdamp -- refinement flag/damping value for the coordinates (*)
1200#     uref/udamp -- refinement flag/damping value for the temperature factor(s)  (*)
1201#     fref/fdamp -- refinement flag/damping value for the occupancy (*)
1202#  action: get (default) or set
1203#  value: used only with set
1204#  * =>  read+write supported
1205proc mmatominfo {phaselist atomlist parm "action get" "value {}"} {
1206    foreach phase $phaselist atom $atomlist {
1207        if {$phase == ""} {set phase [lindex $phaselist end]}
1208        set num [string toupper [format %.4x $atom]]
1209        set key "CRS$phase  AT$num"
1210        switch -glob ${parm}-$action {
1211            type-get {
1212                return [string trim [string range [readexp ${key}] 2 9] ]
1213            }
1214            frac-get {
1215                return [string trim [string range [readexp ${key}] 10 15] ]
1216            }
1217            frac-set {
1218                if ![validreal value 6 4] {return 0}
1219                setexp ${key} $value 11 6
1220            }
1221            x-get {
1222                return [string trim [string range [readexp ${key}] 16 23] ]
1223            }
1224            x-set {
1225                if ![validreal value 8 5] {return 0}
1226                setexp ${key} $value 17 8
1227            }
1228            y-get {
1229                return [string trim [string range [readexp ${key}] 24 31] ]
1230            }
1231            y-set {
1232                if ![validreal value 8 5] {return 0}
1233                setexp ${key} $value 25 8
1234            }
1235            z-get {
1236                return [string trim [string range [readexp ${key}] 32 39] ]
1237            }
1238            z-set {
1239                if ![validreal value 8 5] {return 0}
1240                setexp ${key} $value 33 8
1241            }
1242            Uiso-get {
1243                return [string trim [string range [readexp ${key}] 40 45] ]
1244            }
1245            Uiso-set {
1246                if ![validreal value 6 4] {return 0}
1247                setexp ${key} $value 41 6
1248            }
1249            label-get {
1250                return [string trim [string range [readexp ${key}] 46 50] ]
1251            }
1252            label-set {
1253                setexp ${key} $value 47 5
1254            }
1255            residue-get {
1256                return [string range [readexp ${key}] 51 53]
1257            }
1258            residue-set {
1259                setexp ${key} $value 52 3
1260            }
1261            group-get {
1262                return [string range [readexp ${key}] 54 55]
1263            }
1264            group-set {
1265                setexp ${key} $value 55 2
1266            }
1267            resnum-get {
1268                return [string trim [string range [readexp ${key}] 56 59] ]
1269            }
1270            resnum-set {
1271                if ![validint value 4] {return 0}
1272                setexp "${key} EPHAS" $value 57 4
1273            }
1274            fref-get {
1275                if {[string toupper [string range [readexp $key] 60 60]] == "F"} {
1276                    return 1
1277                }
1278                return 0
1279            }
1280            fref-set {
1281                if $value {
1282                    setexp $key "F" 61 1
1283                } else {
1284                    setexp $key " " 61 1
1285                }           
1286            }
1287            xref-get {
1288                if {[string toupper [string range [readexp $key] 61 61]] == "X"} {
1289                    return 1
1290                }
1291                return 0
1292            }
1293            xref-set {
1294                if $value {
1295                    setexp $key "X" 62 1
1296                } else {
1297                    setexp ${key}B " " 62 1
1298                }           
1299            }
1300            uref-get {
1301                if {[string toupper [string range [readexp $key] 62 62]] == "U"} {
1302                    return 1
1303                }
1304                return 0
1305            }
1306            uref-set {
1307                if $value {
1308                    setexp $key "U" 63 1
1309                } else {
1310                    setexp $key " " 63 1
1311                }           
1312            }
1313
1314            fdamp-get {
1315                set val [string range [readexp ${key}] 63 63]
1316                if {$val == " "} {return 0}
1317                return $val
1318            }
1319            fdamp-set {
1320                setexp ${key} $value 64 1
1321            }
1322            xdamp-get {
1323                set val [string range [readexp ${key}] 64 64]
1324                if {$val == " "} {return 0}
1325                return $val
1326            }
1327            xdamp-set {
1328                setexp ${key} $value 65 1
1329            }
1330
1331            udamp-get {
1332                set val [string range [readexp ${key}] 65 65]
1333                if {$val == " "} {return 0}
1334                return $val
1335            }
1336            udamp-set {
1337                setexp ${key} $value 66 1
1338            }
1339            default {
1340                set msg "Unsupported mmatominfo access: parm=$parm action=$action"
1341                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
1342            }
1343        }
1344    }
1345    return 1
1346}
1347
1348
1349
1350# get histogram information: histinfo histlist parm action value
1351# histlist is a list of histogram numbers
1352# parm:
1353#     title
1354#     file  -- file name of raw data for histogram (*)
1355#     scale (*)
1356#     sref/sdamp -- refinement flag/damping value for the scale factor (*)
1357#     lam1, lam2 (*)
1358#     ttref refinement flag for the 2theta (ED Xray) (*)
1359#     wref refinement flag for the wavelength (*)
1360#     ratref refinement flag for the wavelength ratio (*)
1361#     difc, difa -- TOF calibration constants (*)
1362#     dcref,daref -- refinement flag for difc, difa (*)
1363#     zero (*)
1364#     zref refinement flag for the zero correction (*)
1365#     ipola (*)
1366#     pola (*)
1367#     pref refinement flag for the polarization (*)
1368#     kratio (*)
1369#     ddamp -- damping value for the diffractometer constants (*)
1370#     backtype -- background function number *
1371#     backterms -- number of background terms *
1372#     bref/bdamp -- refinement flag/damping value for the background (*)
1373#     bterm$n -- background term #n (*)
1374#     bank -- Bank number
1375#     tofangle -- detector angle (TOF only)
1376#     foextract  -- Fobs extraction flag (*)
1377#     LBdamp  -- LeBail damping value (*)
1378#     tmin/tmax -- minimum & maximum usable 2theta/TOF/energy
1379#     excl -- excluded regions (*)
1380#     dmin -- minimum d-space for reflection generation (*)
1381#     use  -- use flag; 1 = use; 0 = do not use (*)
1382#     dstart -- dummy histogram starting tmin/emin/2theta (*)
1383#     dstep -- dummy histogram step size tmin/emin/2theta (*)
1384#     dpoints -- dummy histogram number of points (*)
1385#     dtype   -- dummy histogram type (CONST or SLOG)
1386#     abscor1 -- 1st absorption correction (*)
1387#     abscor2 -- 2nd absorption correction (*)
1388#     abstype -- absorption correction type (*)
1389#     absdamp -- damping for absorption refinement (*)
1390#     absref -- refinement damping for absorption refinement (*)
1391#     proftbl -- returns number of profile table termns
1392#   parameters transferred from the instrument parameter file:
1393#     ITYP    -- returns the contents of the ITYP record
1394proc histinfo {histlist parm "action get" "value {}"} {
1395    global expgui
1396    foreach hist $histlist {
1397        if {$hist < 10} {
1398            set key "HST  $hist"
1399        } else {
1400            set key "HST $hist"
1401        }
1402        switch -glob ${parm}-$action {
1403            foextract-get {
1404                set line [readexp "${key} EPHAS"]
1405                # add a EPHAS if not exists
1406                if {$line == {}} {
1407                    makeexprec "${key} EPHAS"
1408                    # expedt defaults this to "F", but I think "T" is better
1409                    setexp "${key} EPHAS" "Y" 50 1
1410                    if $expgui(debug) {puts "Warning: creating a ${key} EPHAS record"}
1411                }
1412                if {[string toupper [string range $line 49 49]] == "T"} {
1413                    return 1
1414                }
1415                # the flag has changed to "Y/N" in the latest versions
1416                # of GSAS
1417                if {[string toupper [string range $line 49 49]] == "Y"} {
1418                    return 1
1419                }
1420                return 0
1421            }
1422            foextract-set {
1423                # the flag has changed to "Y/N" in the latest versions
1424                # of GSAS
1425                if $value {
1426                    setexp "${key} EPHAS" "Y" 50 1
1427                } else {
1428                    setexp "${key} EPHAS" "N" 50 1
1429                }
1430            }
1431            LBdamp-get {
1432                set v [string trim [string range [readexp "${key} EPHAS"] 54 54]]
1433                if {$v == ""} {return 0}
1434                return $v
1435            }
1436            LBdamp-set {
1437                if ![validint value 5] {return 0}
1438                setexp "${key} EPHAS" $value 51 5
1439            }
1440            title-get {
1441                return [string trim [readexp "${key}  HNAM"] ]
1442            }
1443            scale-get {
1444                return [string trim [string range [readexp ${key}HSCALE] 0 14]]
1445            }
1446            scale-set {
1447                if ![validreal value 15 6] {return 0}
1448                setexp ${key}HSCALE $value 1 15
1449            }
1450            sref-get {
1451                if {[string toupper [string range [readexp ${key}HSCALE] 19 19]] == "Y"} {
1452                    return 1
1453                }
1454                return 0
1455            }
1456            sref-set {
1457                if $value {
1458                    setexp ${key}HSCALE "Y" 20 1
1459                } else {
1460                    setexp ${key}HSCALE "N" 20 1
1461                }           
1462            }
1463            sdamp-get {
1464                set val [string range [readexp ${key}HSCALE] 24 24]
1465                if {$val == " "} {return 0}
1466                return $val
1467            }
1468            sdamp-set {
1469                setexp ${key}HSCALE $value 25 1
1470            }
1471
1472            difc-get -
1473            lam1-get {
1474                return [string trim [string range [readexp "${key} ICONS"] 0 9]]
1475            }
1476            difc-set -
1477            lam1-set {
1478                if ![validreal value 10 7] {return 0}
1479                setexp "${key} ICONS" $value 1 10
1480                # set the powpref warning (1 = suggested)
1481                catch {
1482                    global expgui
1483                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1484                    set msg "Diffractometer constants" 
1485                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1486                        append expgui(needpowpref_why) "\t$msg were changed\n"
1487                    }
1488                }
1489            }
1490            difa-get -
1491            lam2-get {
1492                return [string trim [string range [readexp "${key} ICONS"] 10 19]]
1493            }
1494            difa-set -
1495            lam2-set {
1496                if ![validreal value 10 7] {return 0}
1497                setexp "${key} ICONS" $value 11 10
1498                # set the powpref warning (1 = suggested)
1499                catch {
1500                    global expgui
1501                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1502                    set msg "Diffractometer constants" 
1503                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1504                        append expgui(needpowpref_why) "\t$msg were changed\n"
1505                    }
1506                }
1507            }
1508            zero-get {
1509                return [string trim [string range [readexp "${key} ICONS"] 20 29]]
1510            }
1511            zero-set {
1512                if ![validreal value 10 5] {return 0}
1513                setexp "${key} ICONS" $value 21 10
1514                # set the powpref warning (1 = suggested)
1515                catch {
1516                    global expgui
1517                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1518                    set msg "Diffractometer constants" 
1519                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1520                        append expgui(needpowpref_why) "\t$msg were changed\n"
1521                    }
1522                }
1523            }
1524            ipola-get {
1525                return [string trim [string range [readexp "${key} ICONS"] 54 54]]
1526            }
1527            ipola-set {
1528                if ![validint value 1] {return 0}
1529                setexp "${key} ICONS" $value 55 1
1530            }
1531            pola-get {
1532                return [string trim [string range [readexp "${key} ICONS"] 40 49]]
1533            }
1534            pola-set {
1535                if ![validreal value 10 5] {return 0}
1536                setexp "${key} ICONS" $value 41 10
1537            }
1538            kratio-get {
1539                set val [string trim [string range [readexp "${key} ICONS"] 55 64]]
1540                if {$val == ""} {set val 0}
1541                # N.B. this code is used w/CW, where Kratio may not be 0.0
1542                set lam2 [string trim [string range [readexp "${key} ICONS"] 10 19]]
1543                if {$lam2 == ""} {set lam2 0}
1544                # Change kratio & flag the change (this is rather kludged)
1545                if {$val == 0 && $lam2 != 0} {
1546                    set val 0.5
1547                    validreal val 10 5
1548                    setexp "${key} ICONS" $val 56 10
1549                    catch {incr ::expgui(changed)}
1550                }
1551                return $val
1552            }
1553            kratio-set {
1554                if ![validreal value 10 5] {return 0}
1555                setexp "${key} ICONS" $value 56 10
1556            }
1557
1558            wref-get {
1559            #------------------------------------------------------
1560            # col 33: refine flag for lambda, difc, ratio and theta
1561            #------------------------------------------------------
1562                if {[string toupper [string range \
1563                        [readexp "${key} ICONS"] 32 32]] == "L"} {
1564                    return 1
1565                }
1566                return 0
1567            }
1568            wref-set {
1569                if $value {
1570                    setexp "${key} ICONS" "L" 33 1
1571                } else {
1572                    setexp "${key} ICONS" " " 33 1
1573                }           
1574            }
1575            ratref-get {
1576                if {[string toupper [string range \
1577                        [readexp "${key} ICONS"] 32 32]] == "R"} {
1578                    return 1
1579                }
1580                return 0
1581            }
1582            ratref-set {
1583                if $value {
1584                    setexp "${key} ICONS" "R" 33 1
1585                } else {
1586                    setexp "${key} ICONS" " " 33 1
1587                }           
1588            }
1589            dcref-get {
1590                if {[string toupper [string range \
1591                        [readexp "${key} ICONS"] 32 32]] == "C"} {
1592                    return 1
1593                }
1594                return 0
1595            }
1596            dcref-set {
1597                if $value {
1598                    setexp "${key} ICONS" "C" 33 1
1599                } else {
1600                    setexp "${key} ICONS" " " 33 1
1601                }           
1602            }
1603            ttref-get {
1604                if {[string toupper [string range \
1605                        [readexp "${key} ICONS"] 32 32]] == "T"} {
1606                    return 1
1607                }
1608                return 0
1609            }
1610            ttref-set {
1611                if $value {
1612                    setexp "${key} ICONS" "T" 33 1
1613                } else {
1614                    setexp "${key} ICONS" " " 33 1
1615                }           
1616            }
1617
1618
1619            pref-get {
1620            #------------------------------------------------------
1621            # col 34: refine flag for POLA & DIFA
1622            #------------------------------------------------------
1623                if {[string toupper [string range \
1624                        [readexp "${key} ICONS"] 33 33]] == "P"} {
1625                    return 1
1626                }
1627                return 0
1628            }
1629            pref-set {
1630                if $value {
1631                    setexp "${key} ICONS" "P" 34 1
1632                } else {
1633                    setexp "${key} ICONS" " " 34 1
1634                }           
1635            }
1636            daref-get {
1637                if {[string toupper [string range \
1638                        [readexp "${key} ICONS"] 33 33]] == "A"} {
1639                    return 1
1640                }
1641                return 0
1642            }
1643            daref-set {
1644                if $value {
1645                    setexp "${key} ICONS" "A" 34 1
1646                } else {
1647                    setexp "${key} ICONS" " " 34 1
1648                }           
1649            }
1650
1651            zref-get {
1652            #------------------------------------------------------
1653            # col 34: refine flag for zero correction
1654            #------------------------------------------------------
1655                if {[string toupper [string range [readexp "${key} ICONS"] 34 34]] == "Z"} {
1656                    return 1
1657                }
1658                return 0
1659            }
1660            zref-set {
1661                if $value {
1662                    setexp "${key} ICONS" "Z" 35 1
1663                } else {
1664                    setexp "${key} ICONS" " " 35 1
1665                }           
1666            }
1667
1668            ddamp-get {
1669                set val [string range [readexp "${key} ICONS"] 39 39]
1670                if {$val == " "} {return 0}
1671                return $val
1672            }
1673            ddamp-set {
1674                setexp "${key} ICONS" $value 40 1
1675            }
1676
1677            backtype-get {
1678                set val [string trim [string range [readexp "${key}BAKGD "] 0 4]]
1679                if {$val == " "} {return 0}
1680                return $val
1681            }
1682            backtype-set {
1683                if ![validint value 5] {return 0}
1684                setexp "${key}BAKGD " $value 1 5
1685            }
1686            backterms-get {
1687                set val [string trim [string range [readexp "${key}BAKGD "] 5 9]]
1688                if {$val == " "} {return 0}
1689                return $val
1690            }
1691            backterms-set {
1692                # this takes a bit of work -- if terms are added, add lines as needed to the .EXP
1693                set oldval [string trim [string range [readexp "${key}BAKGD "] 5 9]]
1694                if ![validint value 5] {return 0}
1695                if {$oldval < $value} {
1696                    set line1  [expr {2 + ($oldval - 1) / 4}]
1697                    set line2  [expr {1 + ($value - 1) / 4}]
1698                    for {set i $line1} {$i <= $line2} {incr i} {
1699                        # create a blank entry if needed
1700                        makeexprec ${key}BAKGD$i
1701                    }
1702                    incr oldval
1703                    for {set num $oldval} {$num <= $value} {incr num} {
1704                        set f1 [expr {15*(($num - 1) % 4)}]
1705                        set f2 [expr {15*(1 + ($num - 1) % 4)-1}]
1706                        set line  [expr {1 + ($num - 1) / 4}]
1707                        if {[string trim [string range [readexp ${key}BAKGD$line] $f1 $f2]] == ""} {
1708                            set f1 [expr {15*(($num - 1) % 4)+1}]
1709                            setexp ${key}BAKGD$line 0.0 $f1 15                 
1710                        }
1711                    }
1712                }
1713                setexp "${key}BAKGD " $value 6 5
1714
1715            }
1716            bref-get {
1717                if {[string toupper [string range [readexp "${key}BAKGD"] 14 14]] == "Y"} {
1718                    return 1
1719                }
1720                return 0
1721            }
1722            bref-set {
1723                if $value {
1724                    setexp "${key}BAKGD "  "Y" 15 1
1725                } else {
1726                    setexp "${key}BAKGD "  "N" 15 1
1727                }
1728            }
1729            bdamp-get {
1730                set val [string range [readexp "${key}BAKGD "] 19 19]
1731                if {$val == " "} {return 0}
1732                return $val
1733            }
1734            bdamp-set {
1735                setexp "${key}BAKGD " $value 20 1
1736            }
1737            bterm*-get {
1738                regsub bterm $parm {} num
1739                set f1 [expr {15*(($num - 1) % 4)}]
1740                set f2 [expr {15*(1 + ($num - 1) % 4)-1}]
1741                set line  [expr {1 + ($num - 1) / 4}]
1742                return [string trim [string range [readexp ${key}BAKGD$line] $f1 $f2] ]
1743            }
1744            bterm*-set {
1745                regsub bterm $parm {} num
1746                if ![validreal value 15 6] {return 0}
1747                set f1 [expr {15*(($num - 1) % 4)+1}]
1748                set line  [expr {1 + ($num - 1) / 4}]
1749                setexp ${key}BAKGD$line $value $f1 15
1750            }
1751            bank-get {
1752                return [string trim [string range [readexp "${key} BANK"] 0 4]]
1753            }
1754            tofangle-get {
1755                return [string trim [string range [readexp "${key}BNKPAR"] 10 19]]
1756            }
1757            tmin-get {
1758                return [string trim [string range [readexp "${key} TRNGE"] 0 9]]
1759            }
1760            tmax-get {
1761                return [string trim [string range [readexp "${key} TRNGE"] 10 19]]
1762            }
1763            excl-get {
1764                set n [string trim [string range [readexp "${key} NEXC"] 0 4]]
1765                set exlist {}
1766                for {set i 1} {$i <= $n} {incr i} {
1767                    set line [readexp [format "${key}EXC%3d" $i]]
1768                    lappend exlist [list \
1769                            [string trim [string range $line  0  9]] \
1770                            [string trim [string range $line 10 19]]]
1771                }
1772                return $exlist
1773            }
1774            excl-set {
1775                set n [llength $value]
1776                if ![validint n 5] {return 0}
1777                setexp "${key} NEXC" $n 1 5
1778                set i 0
1779                foreach p $value {
1780                    incr i
1781                    foreach {r1 r2} $p {}
1782                    validreal r1 10 3
1783                    validreal r2 10 3
1784                    set k [format "${key}EXC%3d" $i]
1785                    if {![existsexp $k]} {
1786                        makeexprec $k
1787                    }
1788                    setexp $k ${r1}${r2} 1 20
1789                }
1790                # set the powpref warning (2 = required)
1791                catch {
1792                    global expgui
1793                    set expgui(needpowpref) 2
1794                    set msg "Excluded regions" 
1795                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1796                        append expgui(needpowpref_why) "\t$msg were changed\n"
1797                    }
1798                }
1799            }
1800            file-get {
1801                return [string trim [readexp "${key}  HFIL"] ]
1802            }
1803            file-set {
1804                setexp "${key}  HFIL" $value 3 65
1805            }
1806            bank-get {
1807                return [string trim [string range [readexp "${key} BANK"] 0 4]]
1808            }
1809            dmin-get {
1810                return [string trim [string range [readexp "${key} NREF"] 5 14]]
1811            }
1812            dmin-set {
1813                if ![validreal value 10 4] {return 0}
1814                setexp "${key} NREF" $value 6 10
1815                # set the powpref warning (2 = required)
1816                catch {
1817                    global expgui
1818                    set expgui(needpowpref) 2
1819                    set msg "Dmin (reflection range)" 
1820                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1821                        append expgui(needpowpref_why) "\t$msg was changed\n"
1822                    }
1823                }
1824            }
1825            use-get {
1826                set k [expr {($hist+11)/12}]
1827                set line [readexp " EXPR  HTYP$k"]
1828                set j [expr {((($hist-1) % 12)+1)*5}]
1829                if {[string range $line $j $j] == "*"} {return 0}
1830                return 1
1831            }
1832            use-set {
1833                set k [expr {($hist+11)/12}]
1834                set line [readexp " EXPR  HTYP$k"]
1835                set j [expr {((($hist-1) % 12)+1)*5+1}]
1836                if {$value} {
1837                    setexp " EXPR  HTYP$k" " " $j 1
1838                } else {
1839                    setexp " EXPR  HTYP$k" "*" $j 1
1840                }
1841                # set the powpref warning (2 = required)
1842                catch {
1843                    global expgui
1844                    set expgui(needpowpref) 2
1845                    set msg "Histogram use flags" 
1846                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1847                        append expgui(needpowpref_why) "\t$msg were changed\n"
1848                    }
1849                }
1850            }
1851            dstart-get {
1852                return [string trim [string range [readexp "${key} DUMMY"] 20 29]]
1853            }
1854            dstart-set {
1855                if ![validreal value 10 3] {return 0}
1856                setexp "${key} DUMMY" $value 21 10
1857                # set the powpref warning (1 = suggested)
1858                catch {
1859                    global expgui
1860                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1861                    set msg "Dummy histogram parameters" 
1862                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1863                        append expgui(needpowpref_why) "\t$msg were changed\n"
1864                    }
1865                }
1866            }
1867            dstep-get {
1868                return [string trim [string range [readexp "${key} DUMMY"] 30 39]]
1869            }
1870            dstep-set {
1871                if ![validreal value 10 3] {return 0}
1872                setexp "${key} DUMMY" $value 31 10
1873                catch {
1874                    global expgui
1875                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1876                    set msg "Dummy histogram parameters" 
1877                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1878                        append expgui(needpowpref_why) "\t$msg were changed\n"
1879                    }
1880                }
1881            }
1882            dpoints-get {
1883                return [string trim [string range [readexp "${key} DUMMY"] 0 9]]
1884            }
1885            dpoints-set {
1886                if ![validint value 10] {return 0}
1887                setexp "${key} DUMMY" $value 1 10
1888                catch {
1889                    global expgui
1890                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1891                    set msg "Dummy histogram parameters" 
1892                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1893                        append expgui(needpowpref_why) "\t$msg were changed\n"
1894                    }
1895                }
1896            }
1897            dtype-get {
1898                return [string trim [string range [readexp "${key} DUMMY"] 10 19]]
1899            }
1900            abscor1-get {
1901                return [string trim [string range [readexp "${key}ABSCOR"] 0 14]]
1902            }
1903            abscor1-set {
1904                if ![validreal value 15 7] {return 0}
1905                setexp "${key}ABSCOR" $value 1 15
1906            }
1907            abscor2-get {
1908                return [string trim [string range [readexp "${key}ABSCOR"] 15 29]]
1909            }
1910            abscor2-set {
1911                # can't use validreal as the decimal must be in col 20
1912                if {[catch {
1913                    if {abs($value) < 99.99 && abs($value) > 1.e-4} {
1914                        set tmp [format "%15.10f" $value]
1915                        # make a final check of decimal
1916                        if {[string range $tmp 4 4] != "."} {
1917                            set tmp [format "%15.6E" $value]
1918                        }
1919                    } else {
1920                        set tmp [format "%15.6E" $value]
1921                    }
1922                }]} {return 0}
1923                setexp "${key}ABSCOR" $tmp 16 15
1924            }
1925            abstype-get {
1926                set val [string trim [string range [readexp "${key}ABSCOR"] 40 44]]
1927                if {$val == ""} {set val 0}
1928                return $val
1929            }
1930            abstype-set {
1931                if ![validint value 5] {return 0}
1932                setexp "${key}ABSCOR" $value 41 5
1933            }
1934            absdamp-get {
1935                set val [string range [readexp "${key}ABSCOR"] 39 39]
1936                if {$val == " "} {return 0}
1937                return $val
1938            }
1939            absdamp-set {
1940                if ![validint value 5] {return 0}
1941                setexp "${key}ABSCOR" $value 36 5
1942            }
1943            absref-get {
1944                if {[string toupper \
1945                        [string range [readexp "${key}ABSCOR"] 34 34]] == "Y"} {
1946                    return 1
1947                }
1948                return 0
1949            }
1950            absref-set {
1951                if $value {
1952                    setexp "${key}ABSCOR" "    Y" 31 5
1953                } else {
1954                    setexp "${key}ABSCOR" "    N" 31 5
1955                }
1956            }
1957            ITYP-get {
1958                return [string trim [readexp "${key}I ITYP"]]
1959            }
1960            proftbl-get {
1961                set line [readexp "${key}PAB3"]
1962                if {$line == ""} {return 0}
1963                set val [string trim [string range $line 0 4]]
1964                if {$val == ""} {return 0}
1965                return $val
1966            }
1967            default {
1968                set msg "Unsupported histinfo access: parm=$parm action=$action"
1969                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
1970            }
1971        }
1972    }
1973    return 1
1974}
1975
1976# read the information that differs by both histogram and phase (profile & phase fraction)
1977# use: hapinfo hist phase parm action value
1978
1979#     frac -- phase fraction (*)
1980#     frref/frdamp -- refinement flag/damping value for the phase fraction (*)
1981#     proftype -- profile function number (*)
1982#     profterms -- number of profile terms (*)
1983#     pdamp -- damping value for the profile (*)
1984#     pcut -- cutoff value for the profile (*)
1985#     pterm$n -- profile term #n (*)
1986#     pref$n -- refinement flag value for profile term #n (*)
1987#     extmeth -- Fobs extraction method (*)
1988#     POnaxis -- number of defined M-D preferred axes
1989proc hapinfo {histlist phaselist parm "action get" "value {}"} {
1990    foreach phase $phaselist hist $histlist {
1991        if {$phase == ""} {set phase [lindex $phaselist end]}
1992        if {$hist == ""} {set hist [lindex $histlist end]}
1993        if {$hist < 10} {
1994            set hist " $hist"
1995        }
1996        set key "HAP${phase}${hist}"
1997        switch -glob ${parm}-$action {
1998            extmeth-get {
1999                set i1 [expr {($phase - 1)*5}]
2000                set i2 [expr {$i1 + 4}]
2001                return [string trim [string range [readexp "HST $hist EPHAS"] $i1 $i2]]
2002            }
2003            extmeth-set {
2004                set i1 [expr {($phase - 1)*5 + 1}]
2005                if ![validint value 5] {return 0}
2006                setexp "HST $hist EPHAS" $value $i1 5
2007            }
2008            frac-get {
2009                return [string trim [string range [readexp ${key}PHSFR] 0 14]]
2010            }
2011            frac-set {
2012                if ![validreal value 15 6] {return 0}
2013                setexp ${key}PHSFR $value 1 15
2014            }
2015            frref-get {
2016                if {[string toupper [string range [readexp ${key}PHSFR] 19 19]] == "Y"} {
2017                    return 1
2018                }
2019                return 0
2020            }
2021            frref-set {
2022                if $value {
2023                    setexp ${key}PHSFR "Y" 20 1
2024                } else {
2025                    setexp ${key}PHSFR "N" 20 1
2026                }           
2027            }
2028            frdamp-get {
2029                set val [string range [readexp ${key}PHSFR] 24 24]
2030                if {$val == " "} {return 0}
2031                return $val
2032            }
2033            frdamp-set {
2034                setexp ${key}PHSFR $value 25 1
2035            }
2036            proftype-get {
2037                set val [string range [readexp "${key}PRCF "] 0 4]
2038                if {$val == " "} {return 0}
2039                return $val
2040            }
2041            proftype-set {
2042                if ![validint value 5] {return 0}
2043                setexp "${key}PRCF " $value 1 5
2044                # set the powpref warning (1 = suggested)
2045                catch {
2046                    global expgui
2047                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
2048                    set msg "Profile parameters" 
2049                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
2050                        append expgui(needpowpref_why) "\t$msg were changed\n"
2051                    }
2052                }
2053            }
2054            profterms-get {
2055                set val [string range [readexp "${key}PRCF "] 5 9]
2056                if {$val == " "} {return 0}
2057                return $val
2058            }
2059            profterms-set {
2060                if ![validint value 5] {return 0}
2061                setexp "${key}PRCF " $value 6 5
2062                # now check that all needed entries exist
2063                set lines [expr {1 + ($value - 1) / 4}]
2064                for {set i 1} {$i <= $lines} {incr i} {
2065                    makeexprec "${key}PRCF $i"
2066                }
2067                # set the powpref warning (1 = suggested)
2068                catch {
2069                    global expgui
2070                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
2071                    set msg "Profile parameters" 
2072                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
2073                        append expgui(needpowpref_why) "\t$msg were changed\n"
2074                    }
2075                }
2076            }
2077            pcut-get {
2078                return [string trim [string range [readexp "${key}PRCF "] 10 19]]
2079            }
2080            pcut-set {
2081                if ![validreal value 10 5] {return 0}
2082                setexp "${key}PRCF " $value 11 10
2083                # set the powpref warning (1 = suggested)
2084                catch {
2085                    global expgui
2086                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
2087                    set msg "Profile parameters" 
2088                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
2089                        append expgui(needpowpref_why) "\t$msg were changed\n"
2090                    }
2091                }
2092            }
2093            pdamp-get {
2094                set val [string range [readexp "${key}PRCF "] 24 24]
2095                if {$val == " "} {return 0}
2096                return $val
2097            }
2098            pdamp-set {
2099                setexp "${key}PRCF   " $value 25 1
2100            }
2101            pterm*-get {
2102                regsub pterm $parm {} num
2103                set f1 [expr {15*(($num - 1) % 4)}]
2104                set f2 [expr {15*(1 + ($num - 1) % 4)-1}]
2105                set line  [expr {1 + ($num - 1) / 4}]
2106                return [string trim [string range [readexp "${key}PRCF $line"] $f1 $f2] ]
2107            }
2108            pterm*-set {
2109                if ![validreal value 15 6] {return 0}
2110                regsub pterm $parm {} num
2111                set f1 [expr {1+ 15*(($num - 1) % 4)}]
2112                set line  [expr {1 + ($num - 1) / 4}]
2113                setexp "${key}PRCF $line" $value $f1 15
2114                # set the powpref warning (1 = suggested)
2115                catch {
2116                    global expgui
2117                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
2118                    set msg "Profile parameters" 
2119                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
2120                        append expgui(needpowpref_why) "\t$msg were changed\n"
2121                    }
2122                }
2123            }
2124            pref*-get {
2125                regsub pref $parm {} num
2126                set f [expr {24+$num}]
2127                if {[string toupper [string range [readexp "${key}PRCF  "] $f $f]] == "Y"} {
2128                    return 1
2129                }
2130                return 0
2131            }
2132            pref*-set {
2133                regsub pref $parm {} num
2134                set f [expr {25+$num}]
2135                if $value {
2136                    setexp ${key}PRCF "Y" $f 1
2137                } else {
2138                    setexp ${key}PRCF "N" $f 1
2139                }           
2140            }
2141            POnaxis-get {
2142                set val [string trim \
2143                        [string range [readexp "${key}NAXIS"] 0 4]]
2144                if {$val == ""} {return 0}
2145                return $val
2146            }
2147            POnaxis-set {
2148                if ![validint value 5] {return 0}
2149                # there should be a NAXIS record, but if not make one
2150                if {![existsexp "${key}NAXIS"]} {
2151                    makeexprec "${key}NAXIS"
2152                }
2153                setexp "${key}NAXIS  " $value 1 5
2154            }
2155            default {
2156                set msg "Unsupported hapinfo access: parm=$parm action=$action"
2157                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
2158            }
2159        }
2160    }
2161    return 1
2162}
2163
2164#  get a logical constraint
2165#
2166#  type action
2167#  -----------
2168#  atom get  number        returns a list of constraints.
2169#   "   set  number value  replaces a list of constraints
2170#                          (value is a list of constraints)
2171#   "   add  number value  inserts a new list of constraints
2172#                          (number is ignored)
2173#   "   delete number      deletes a set of constraint entries
2174# Each item in the list of constraints is composed of 4 items:
2175#              phase, atom, variable, multiplier
2176# If variable=UISO atom can be ALL, otherwise atom is a number
2177# legal variable names: FRAC, X, Y, Z, UISO, U11, U22, U33, U12, U23, U13,
2178#                       MX, MY, MZ
2179#
2180#  type action
2181#  -----------
2182#  profileXX get number         returns a list of constraints for term XX=1-36
2183#                               use number=0 to get # of defined
2184#                                  constraints for term XX
2185#   "        set number value   replaces a list of constraints
2186#                               (value is a list of constraints)
2187#   "        add number value   inserts a new list of constraints
2188#                               (number is ignored)
2189#   "        delete number      deletes a set of constraint entries
2190# Each item in the list of constraints is composed of 3 items:
2191#              phase-list, histogram-list, multiplier
2192# Note that phase-list and/or histogram-list can be ALL
2193
2194proc constrinfo {type action number "value {}"} {
2195    global expmap
2196    if {[lindex $expmap(phasetype) 0] == 4} {
2197        set mm 1
2198    } else {
2199        set mm 0
2200    }
2201    switch -glob ${type}-$action {
2202        atom-get {
2203            # does this constraint exist?
2204            set key [format "LNCN%4d%4d" $number 1]
2205            if {![existsexp $key]} {return -1}
2206            set clist {}
2207            for {set i 1} {$i < 999} {incr i} {
2208                set key [format "LNCN%4d%4d" $number $i]
2209                if {![existsexp $key]} break
2210                set line [readexp $key]
2211                set j1 2
2212                set j2 17
2213                set seg [string range $line $j1 $j2]
2214                while {[string trim $seg] != ""} {
2215                    set p [string range $seg 0 0]
2216                    if {$p == 1 && $mm} {
2217                        set atom [string trim [string range $seg 1 4]]
2218                        set var [string trim [string range $seg 5 7]]
2219                        if {$atom == "ALL"} {
2220                            set var UIS
2221                        } else {
2222                            scan $atom %x atom
2223                        }
2224                        lappend clist [list $p $atom $var \
2225                                [string trim [string range $seg 8 end]]]
2226                    } else {
2227                        lappend clist [list $p \
2228                                [string trim [string range $seg 1 3]] \
2229                                [string trim [string range $seg 4 7]] \
2230                                [string trim [string range $seg 8 end]]]
2231                    }
2232                    incr j1 16
2233                    incr j2 16
2234                    set seg [string range $line $j1 $j2]
2235                }
2236            }
2237            return $clist
2238        }
2239        atom-set {
2240            # delete records for current constraint
2241            for {set i 1} {$i < 999} {incr i} {
2242                set key [format "LNCN%4d%4d" $number $i]
2243                if {![existsexp $key]} break
2244                delexp $key
2245            }
2246            set line {}
2247            set i 1
2248            foreach tuple $value {
2249                set p [lindex $tuple 0]
2250                if {$p == 1 && $mm && \
2251                        [string toupper [lindex $tuple 1]] == "ALL"} {
2252                    set seg [format %1dALL UIS%8.4f \
2253                            [lindex $tuple 0] \
2254                            [lindex $tuple 3]]
2255                } elseif {$p == 1 && $mm} {
2256                    set seg [eval format %1d%.4X%-3s%8.4f $tuple]
2257                } elseif {[string toupper [lindex $tuple 1]] == "ALL"} {
2258                    set seg [format %1dALL%-4s%8.4f \
2259                            [lindex $tuple 0] \
2260                            [lindex $tuple 2] \
2261                            [lindex $tuple 3]]
2262                } else {
2263                    set seg [eval format %1d%3d%-4s%8.4f $tuple]
2264                }
2265                append line $seg
2266                if {[string length $line] > 50} {
2267                    set key  [format "LNCN%4d%4d" $number $i]
2268                    makeexprec $key
2269                    setexp $key $line 3 68
2270                    set line {}
2271                    incr i
2272                }
2273            }
2274            if {$line != ""} {
2275                set key  [format "LNCN%4d%4d" $number $i]
2276                makeexprec $key
2277                setexp $key $line 3 68
2278            }
2279            return
2280        }
2281        atom-add {
2282            # loop over defined constraints
2283            for {set j 1} {$j < 9999} {incr j} {
2284                set key [format "LNCN%4d%4d" $j 1]
2285                if {![existsexp $key]} break
2286            }
2287            set number $j
2288            # save the constraint
2289            set line {}
2290            set i 1
2291            foreach tuple $value {
2292                set p [lindex $tuple 0]
2293                if {$p == 1 && $mm && \
2294                        [string toupper [lindex $tuple 1]] == "ALL"} {
2295                    set seg [format %1dALL UIS%8.4f \
2296                            [lindex $tuple 0] \
2297                            [lindex $tuple 3]]
2298                } elseif {$p == 1 && $mm} {
2299                    set seg [eval format %1d%.4X%-3s%8.4f $tuple]
2300                } elseif {[string toupper [lindex $tuple 1]] == "ALL"} {
2301                    set seg [format %1dALL%-4s%8.4f \
2302                            [lindex $tuple 0] \
2303                            [lindex $tuple 2] \
2304                            [lindex $tuple 3]]
2305                } else {
2306                    set seg [eval format %1d%3d%-4s%8.4f $tuple]
2307                }
2308                append line $seg
2309                if {[string length $line] > 50} {
2310                    set key  [format "LNCN%4d%4d" $number $i]
2311                    makeexprec $key
2312                    setexp $key $line 3 68
2313                    set line {}
2314                    incr i
2315                }
2316            }
2317            if {$line != ""} {
2318                set key  [format "LNCN%4d%4d" $number $i]
2319                makeexprec $key
2320                setexp $key $line 3 68
2321            }
2322            return
2323        }
2324        atom-delete {
2325            for {set j $number} {$j < 9999} {incr j} {
2326                # delete records for current constraint
2327                for {set i 1} {$i < 999} {incr i} {
2328                    set key [format "LNCN%4d%4d" $j $i]
2329                    if {![existsexp $key]} break
2330                    delexp $key
2331                }
2332                # now copy records, from the next entry, if any
2333                set j1 $j
2334                incr j1
2335                set key1 [format "LNCN%4d%4d" $j1 1]
2336                # if there is no record, there is nothing to copy -- done
2337                if {![existsexp $key1]} return
2338                for {set i 1} {$i < 999} {incr i} {
2339                    set key1 [format "LNCN%4d%4d" $j1 $i]
2340                    if {![existsexp $key1]} break
2341                    set key  [format "LNCN%4d%4d" $j  $i]
2342                    makeexprec $key
2343                    setexp $key [readexp $key1] 1 68
2344                }
2345            }
2346        }
2347        profile*-delete {
2348            regsub profile $type {} term
2349            if {$term < 10} {
2350                set term " $term"
2351            }
2352            set key "LEQV PF$term   "
2353            # return nothing if no term exists
2354            if {![existsexp $key]} {return 0}
2355
2356            # number of constraint terms
2357            set nterms [string trim [string range [readexp ${key}] 0 4] ]
2358            # don't delete a non-existing entry
2359            if {$number > $nterms} {return 0}
2360            set val [expr {$nterms - 1}]
2361            validint val 5
2362            setexp $key $val 1 5
2363            for {set i1 $number} {$i1 < $nterms} {incr i1} {
2364                set i2 [expr {1 + $i1}]
2365                # move the contents of constraint #i2 -> i1
2366                if {$i1 > 9} {
2367                    set k1 [expr {($i1+1)/10}]
2368                    set l1 $i1
2369                } else {
2370                    set k1 " "
2371                    set l1 " $i1"
2372                }
2373                set key1 "LEQV PF$term  $k1"
2374                # number of constraint lines for #i1
2375                set n1 [string trim [string range [readexp ${key1}] \
2376                        [expr {($i1%10)*5}] [expr {4+(($i1%10)*5)}]] ]
2377                if {$i2 > 9} {
2378                    set k2 [expr {($i2+1)/10}]
2379                    set l2 $i2
2380                } else {
2381                    set k2 " "
2382                    set l2 " $i2"
2383                }
2384                set key2 "LEQV PF$term  $k2"
2385                # number of constraint lines for #i2
2386                set n2 [string trim [string range [readexp ${key2}] \
2387                        [expr {($i2%10)*5}] [expr {4+(($i2%10)*5)}]] ]
2388                set val $n2
2389                validint val 5
2390                # move the # of terms
2391                setexp $key1 $val [expr {1+(($i1%10)*5)}] 5
2392                # move the terms
2393                for {set j 1} {$j <= $n2} {incr j 1} {
2394                    set key "LEQV PF${term}${l1}$j"
2395                    makeexprec $key
2396                    setexp $key [readexp "LEQV PF${term}${l2}$j"] 1 68
2397                }
2398                # delete any remaining lines
2399                for {set j [expr {$n2+1}]} {$j <= $n1} {incr j 1} {
2400                    delexp "LEQV PF${term}${l1}$j"
2401                }
2402            }
2403
2404            # clear the last term
2405            if {$nterms > 9} {
2406                set i [expr {($nterms+1)/10}]
2407            } else {
2408                set i " "
2409            }
2410            set key "LEQV PF$term  $i"
2411            set cb [expr {($nterms%10)*5}]
2412            set ce [expr {4+(($nterms%10)*5)}]
2413            set n2 [string trim [string range [readexp ${key}] $cb $ce] ]
2414            incr cb
2415            setexp $key "     " $cb 5
2416            # delete any remaining lines
2417            for {set j 1} {$j <= $n2} {incr j 1} {
2418                delexp "LEQV PF${term}${nterms}$j"
2419            }
2420        }
2421        profile*-set {
2422            regsub profile $type {} term
2423            if {$term < 10} {
2424                set term " $term"
2425            }
2426            set key "LEQV PF$term   "
2427            # get number of constraint terms
2428            set nterms [string trim [string range [readexp ${key}] 0 4] ]
2429            # don't change a non-existing entry
2430            if {$number > $nterms} {return 0}
2431            if {$number > 9} {
2432                set k1 [expr {($number+1)/10}]
2433                set l1 $number
2434            } else {
2435                set k1 " "
2436                set l1 " $number"
2437            }
2438            set key1 "LEQV PF$term  $k1"
2439            # old number of constraint lines
2440            set n1 [string trim [string range [readexp ${key1}] \
2441                    [expr {($number%10)*5}] [expr {4+(($number%10)*5)}]] ]
2442            # number of new constraints
2443            set j2 [llength $value]
2444            # number of new constraint lines
2445            set val [set n2 [expr {($j2 + 2)/3}]]
2446            # store the new # of lines
2447            validint val 5
2448            setexp $key1 $val [expr {1+(($number%10)*5)}] 5
2449
2450            # loop over the # of lines in the old or new, whichever is greater
2451            set v0 0
2452            for {set j 1} {$j <= [expr {($n1 > $n2) ? $n1 : $n2}]} {incr j 1} {
2453                set key "LEQV PF${term}${l1}$j"
2454                # were there more lines in the old?
2455                if {$j > $n2} {
2456                    # this line is not needed
2457                    if {$j % 3 == 1} {
2458                        delexp %key
2459                    }
2460                    continue
2461                }
2462                # are we adding new lines?
2463                if {$j > $n1} {
2464                    makeexprec $key
2465                }
2466                # add the three constraints to the line
2467                foreach s {3 23 43} \
2468                        item [lrange $value $v0 [expr {2+$v0}]] {
2469                    if {$item != ""} {
2470                        set val [format %-10s%9.3f \
2471                                [lindex $item 0],[lindex $item 1] \
2472                                [lindex $item 2]]
2473                        setexp $key $val $s 19
2474                    } else {
2475                        setexp $key " " $s 19
2476                    }
2477                }
2478                incr v0 3
2479            }
2480        }
2481        profile*-add {
2482            regsub profile $type {} term
2483            if {$term < 10} {
2484                set term " $term"
2485            }
2486            set key "LEQV PF$term   "
2487            if {![existsexp $key]} {makeexprec $key}
2488            set nterms [string trim [string range [readexp ${key}] 0 4] ]
2489            if {$nterms == ""} {
2490                set nterms 1
2491            } elseif {$nterms >= 99} {
2492                return 0
2493            } else {
2494                incr nterms
2495            }
2496            # store the new # of constraints
2497            set val $nterms
2498            validint val 5
2499            setexp $key $val 1 5
2500
2501            if {$nterms > 9} {
2502                set k1 [expr {($nterms+1)/10}]
2503                set l1 $nterms
2504            } else {
2505                set k1 " "
2506                set l1 " $nterms"
2507            }
2508            set key1 "LEQV PF$term  $k1"
2509
2510            # number of new constraints
2511            set j2 [llength $value]
2512            # number of new constraint lines
2513            set val [set n2 [expr {($j2 + 2)/3}]]
2514            # store the new # of lines
2515            validint val 5
2516            setexp $key1 $val [expr {1+(($nterms%10)*5)}] 5
2517
2518            # loop over the # of lines to be added
2519            set v0 0
2520            for {set j 1} {$j <= $n2} {incr j 1} {
2521                set key "LEQV PF${term}${l1}$j"
2522                makeexprec $key
2523                # add the three constraints to the line
2524                foreach s {3 23 43} \
2525                        item [lrange $value $v0 [expr {2+$v0}]] {
2526                    if {$item != ""} {
2527                        set val [format %-10s%9.3f \
2528                                [lindex $item 0],[lindex $item 1] \
2529                                [lindex $item 2]]
2530                        setexp $key $val $s 19
2531                    } else {
2532                        setexp $key " " $s 19
2533                    }
2534                }
2535                incr v0 3
2536            }
2537        }
2538        profile*-get {
2539            regsub profile $type {} term
2540            if {$term < 10} {
2541                set term " $term"
2542            }
2543            if {$number > 9} {
2544                set i [expr {($number+1)/10}]
2545            } else {
2546                set i " "
2547            }
2548            set key "LEQV PF$term  $i"
2549            # return nothing if no term exists
2550            if {![existsexp $key]} {return 0}
2551            # number of constraint lines
2552           
2553            set numline [string trim [string range [readexp ${key}] \
2554                    [expr {($number%10)*5}] [expr {4+(($number%10)*5)}]] ]
2555            if {$number == 0} {return $numline}
2556            set clist {}
2557            if {$number < 10} {
2558                set number " $number"
2559            }
2560            for {set i 1} {$i <= $numline} {incr i} {
2561                set key "LEQV PF${term}${number}$i"
2562                set line [readexp ${key}]
2563                foreach s {1 21 41} e {20 40 60} {
2564                    set seg [string range $line $s $e]
2565                    if {[string trim $seg] == ""} continue
2566                    # parse the string segment
2567                    set parse [regexp { *([0-9AL]+),([0-9AL]+) +([0-9.]+)} \
2568                            $seg junk phase hist mult]
2569                    # was parse successful
2570                    if {!$parse} {continue}
2571                    lappend clist [list $phase $hist $mult]
2572                }
2573            }
2574            return $clist
2575        }
2576        default {
2577            set msg "Unsupported constrinfo access: type=$type action=$action"
2578            tk_dialog .badexp "Error in readexp access" $msg error 0 OK
2579        }
2580
2581    }
2582}
2583
2584# read the default profile information for a histogram
2585# use: profdefinfo hist set# parm action
2586
2587#     proftype -- profile function number
2588#     profterms -- number of profile terms
2589#     pdamp -- damping value for the profile (*)
2590#     pcut -- cutoff value for the profile (*)
2591#     pterm$n -- profile term #n
2592#     pref$n -- refinement flag value for profile term #n (*)
2593
2594proc profdefinfo {hist set parm "action get"} {
2595    global expgui
2596    if {$hist < 10} {
2597        set key "HST  $hist"
2598    } else {
2599        set key "HST $hist"
2600    }
2601    switch -glob ${parm}-$action {
2602        proftype-get {
2603            set val [string range [readexp "${key}PRCF$set"] 0 4]
2604            if {$val == " "} {return 0}
2605            return $val
2606        }
2607        profterms-get {
2608            set val [string range [readexp "${key}PRCF$set"] 5 9]
2609            if {$val == " "} {return 0}
2610            return $val
2611        }
2612        pcut-get {
2613            return [string trim [string range [readexp "${key}PRCF$set"] 10 19]]
2614        }
2615        pdamp-get {
2616                set val [string range [readexp "${key}PRCF$set"] 24 24]
2617            if {$val == " "} {return 0}
2618            return $val
2619        }
2620        pterm*-get {
2621            regsub pterm $parm {} num
2622            set f1 [expr {15*(($num - 1) % 4)}]
2623            set f2 [expr {15*(1 + ($num - 1) % 4)-1}]
2624            set line  [expr {1 + ($num - 1) / 4}]
2625            return [string trim [string range [\
2626                        readexp "${key}PRCF${set}$line"] $f1 $f2] ]
2627        }
2628        pref*-get {
2629            regsub pref $parm {} num
2630            set f [expr {24+$num}]
2631            if {[string toupper [string range [readexp "${key}PRCF$set"] $f $f]] == "Y"} {
2632                return 1
2633            }
2634            return 0
2635        }
2636        default {
2637            set msg "Unsupported profdefinfo access: parm=$parm action=$action"
2638            tk_dialog .badexp "Code Error" $msg error 0 Exit
2639        }
2640    }
2641}
2642
2643# get March-Dollase preferred orientation information
2644# use MDprefinfo hist phase axis-number parm action value
2645#    ratio    -- ratio of xtallites in PO direction vs random (>1 for more)
2646#    fraction -- fraction in this direction, when more than one axis is used
2647#    h k & l  -- indices of P.O. axis
2648#    ratioref -- flag to vary ratio
2649#    fracref  -- flag to vary fraction
2650#    damp     -- damping value
2651#    type     -- model type (0 = P.O. _|_ to beam, 1 = || to beam)
2652#    new      -- creates a new record with default values (set only)
2653proc MDprefinfo {histlist phaselist axislist parm "action get" "value {}"} {
2654    foreach phase $phaselist hist $histlist axis $axislist {
2655        if {$phase == ""} {set phase [lindex $phaselist end]}
2656        if {$hist == ""} {set hist [lindex $histlist end]}
2657        if {$axis == ""} {set axis [lindex $axislist end]}
2658        if {$hist < 10} {
2659            set hist " $hist"
2660        }
2661        if {$axis > 9} {
2662            set axis "0"
2663        }
2664        set key "HAP${phase}${hist}PREFO${axis}"
2665        switch -glob ${parm}-$action {
2666            ratio-get {
2667                return [string trim [string range [readexp $key] 0 9]]
2668            }
2669            ratio-set {
2670                if ![validreal value 10 6] {return 0}
2671                setexp $key $value 1 10
2672            }
2673            fraction-get {
2674                return [string trim [string range [readexp $key] 10 19]]
2675            }
2676            fraction-set {
2677                if ![validreal value 10 6] {return 0}
2678                setexp $key $value 11 10
2679            }
2680            h-get {
2681                set h [string trim [string range [readexp $key] 20 29]]
2682                # why not allow negative h values?
2683                #               if {$h < 1} {return 0}
2684                return $h
2685            }
2686            h-set {
2687                if ![validreal value 10 2] {return 0}
2688                setexp $key $value 21 10
2689            }
2690            k-get {
2691                set k [string trim [string range [readexp $key] 30 39]]
2692                #               if {$k < 1} {return 0}
2693                return $k
2694            }
2695            k-set {
2696                if ![validreal value 10 2] {return 0}
2697                setexp $key $value 31 10
2698            }
2699            l-get {
2700                set l [string trim [string range [readexp $key] 40 49]]
2701                #if {$l < 1} {return 0}
2702                return $l
2703            }
2704            l-set {
2705                if ![validreal value 10 2] {return 0}
2706                setexp $key $value 41 10
2707            }
2708            ratioref-get {
2709                if {[string toupper \
2710                        [string range [readexp $key] 53 53]] == "Y"} {
2711                    return 1
2712                }
2713                return 0
2714            }
2715            ratioref-set {
2716                if $value {
2717                    setexp $key "Y" 54 1
2718                } else {
2719                    setexp $key "N" 54 1
2720                }
2721            }
2722            fracref-get {
2723                if {[string toupper \
2724                        [string range [readexp $key] 54 54]] == "Y"} {
2725                    return 1
2726                }
2727                return 0
2728            }
2729            fracref-set {
2730                if $value {
2731                    setexp $key "Y" 55 1
2732                } else {
2733                    setexp $key "N" 55 1
2734              }
2735            }
2736            damp-get {
2737                set val [string trim [string range [readexp $key] 59 59]]
2738                if {$val == " "} {return 0}
2739                return $val
2740            }
2741            damp-set {
2742                setexp $key $value 60 1
2743            }
2744            type-get {
2745                set val [string trim [string range [readexp $key] 64 64]]
2746                if {$val == " "} {return 0}
2747                return $val
2748            }
2749            type-set {
2750                # only valid settings are 0 & 1
2751                if {$value != "0" && $value != "1"} {set value "0"}
2752                setexp $key $value 65 1
2753            }
2754            new-set {
2755                makeexprec $key
2756                setexp $key \
2757                        {  1.000000  1.000000  0.000000  0.000000  1.000000   NN    0    0} \
2758                        1 68
2759            }
2760            default {
2761                set msg "Unsupported MDprefinfo access: parm=$parm action=$action"
2762                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
2763            }
2764
2765        }
2766
2767    }
2768}
2769
2770# get list of defined atom types
2771proc AtmTypList {} {
2772    set natypes [readexp " EXPR  NATYP"]
2773    if {$natypes == ""} return
2774    set j 0
2775    set typelist {}
2776    for {set i 1} {$i <= $natypes} {incr i} {
2777        set key {this should never be matched}
2778        while {![existsexp $key]} {
2779            incr j
2780            if {$j > 99} {
2781                return $typelist
2782            } elseif {$j <10} {
2783                set key " EXPR ATYP $j"
2784            } else {
2785                set key " EXPR ATYP$j"
2786            }
2787        }
2788        lappend typelist [string trim [string range $::exparray($key) 2 9]]
2789    }
2790    return $typelist
2791}
2792
2793# read information about atom types
2794#     distrad    atomic distance search radius (get/set)
2795#     angrad     atomic angle search radius (get/set)
2796proc AtmTypInfo {parm atmtype "action get" "value {}"} {
2797    # first, search through the records to find the record matching the type
2798    set natypes [readexp " EXPR  NATYP"]
2799    if {$natypes == ""} return
2800    set j 0
2801    set typelist {}
2802    for {set i 1} {$i <= $natypes} {incr i} {
2803        set key {this should never be matched}
2804        while {![existsexp $key]} {
2805            incr j
2806            if {$j > 99} {
2807                return $typelist
2808            } elseif {$j <10} {
2809                set key " EXPR ATYP $j"
2810            } else {
2811                set key " EXPR ATYP$j"
2812            }
2813        }
2814        if {[string toupper $atmtype] == \
2815                [string toupper [string trim [string range $::exparray($key) 2 9]]]} break
2816        set key {}
2817    }
2818    if {$key == ""} {
2819        # atom type not found
2820        return {}
2821    }
2822    switch -glob ${parm}-$action {
2823        distrad-get {
2824            return [string trim [string range [readexp $key] 15 24]]
2825        }
2826        distrad-set {
2827            if ![validreal value 10 2] {return 0}
2828            setexp $key $value 16 10
2829        }
2830        angrad-get {
2831            return [string trim [string range [readexp $key] 25 34]]
2832        }
2833        angrad-set {
2834            if ![validreal value 10 2] {return 0}
2835            setexp $key $value 26 10
2836        }
2837        default {
2838            set msg "Unsupported AtmTypInfo access: parm=$parm action=$action"
2839            tk_dialog .badexp "Error in readexp" $msg error 0 Exit
2840        }
2841    }
2842}
2843# read default information about atom types (records copied to the .EXP file
2844# from the gsas/data/atomdata.dat file as AFAC ...
2845#     distrad returns a list of atom types (one or two letters) and
2846#                the corresponding distance
2847# note that these values are read only (no set option)
2848proc DefAtmTypInfo {parm} {
2849    set keys [array names ::exparray " AFAC *_SIZ"]
2850    set elmlist {}
2851    if {[llength $keys] <= 0} {return ""}
2852    foreach key $keys {
2853        lappend elmlist [string trim [string range $key 6 7]]
2854    }
2855    switch -glob ${parm} {
2856        distrad {
2857            set out {}
2858            foreach key $keys elm $elmlist {
2859                set val [string range $::exparray($key) 0 9]
2860                lappend out "$elm [string trim $val]"
2861            }
2862            return $out
2863        }
2864        angrad {
2865            set out {}
2866            foreach key $keys elm $elmlist {
2867                set val [string range $::exparray($key) 10 19]
2868                lappend out "$elm [string trim $val]"
2869            }
2870            return $out
2871        }
2872        default {
2873            set msg "Unsupported DefAtmTypInfo access: parm=$parm"
2874            tk_dialog .badexp "Error in readexp" $msg error 0 Exit
2875        }
2876    }
2877}
2878# write the .EXP file
2879proc expwrite {expfile} {
2880    global exparray
2881    set blankline \
2882     "                                                                        "
2883    set fp [open ${expfile} w]
2884    fconfigure $fp -translation crlf -encoding ascii
2885    set keylist [lsort [array names exparray]]
2886    # reorder the keys so that VERSION comes 1st
2887    set pos [lsearch -exact $keylist {     VERSION}]
2888    set keylist "{     VERSION} [lreplace $keylist $pos $pos]"
2889    foreach key $keylist {
2890        puts $fp [string range \
2891                "$key$exparray($key)$blankline" 0 79]
2892    }
2893    close $fp
2894}
2895
2896# history commands -- delete all but last $keep history records,
2897# renumber if $renumber is true
2898proc DeleteHistory {keep renumber} {
2899    global exparray
2900    foreach y [lrange [lsort -decreasing \
2901            [array names exparray {    HSTRY*}]] $keep end] {
2902        unset exparray($y)
2903    }
2904    if !$renumber return
2905    # renumber
2906    set i 0
2907    foreach y [lsort -increasing \
2908            [array names exparray {    HSTRY*}]] {
2909        set key [format "    HSTRY%3d" [incr i]]
2910        set exparray($key) $exparray($y)
2911        unset exparray($y)
2912    }
2913    # list all history
2914    #    foreach y [lsort -decreasing [array names exparray {    HSTRY*}]] {puts "$y $exparray($y)"}
2915}
2916
2917proc CountHistory {} {
2918    global exparray
2919    return [llength [array names exparray {    HSTRY*}]]
2920}
2921
2922# set the phase flags for histogram $hist to $plist
2923proc SetPhaseFlag {hist plist} {
2924    # make a 2 digit key -- hh
2925    if {$hist < 10} {
2926        set hh " $hist"
2927    } else {
2928        set hh $hist
2929    }
2930    set key "HST $hh NPHAS"
2931    set str {}
2932    foreach iph {1 2 3 4 5 6 7 8 9} {
2933        if {[lsearch $plist $iph] != -1} {
2934            append str {    1}
2935        } else {
2936            append str {    0}     
2937        }
2938    }
2939    setexp $key $str 1 68
2940}
2941
2942# erase atom $atom from phase $phase
2943# update the list of atom types, erasing the record if not needed.
2944proc EraseAtom {atom phase} {
2945    set type [atominfo $phase $atom type]
2946    if {$type == ""} return
2947    if {$atom < 10} {
2948        set key "CRS$phase  AT  $atom"
2949    } elseif {$atom < 100} {
2950        set key "CRS$phase  AT $atom"
2951    } else {
2952        set key "CRS$phase  AT$atom"
2953    }
2954    # delete the records for the atom
2955    global exparray
2956    foreach k [array names exparray ${key}*] {
2957        delexp $k
2958    }
2959    # change the number of atoms in the phase
2960    phaseinfo $phase natoms set [expr {[phaseinfo $phase natoms] -1}]
2961
2962    # now adjust numbers in "EXPR ATYP" records and delete, if needed.
2963    set natypes [readexp " EXPR  NATYP"]
2964    if {$natypes == ""} return
2965    set j 0
2966    for {set i 1} {$i <= $natypes} {incr i} {
2967        incr j
2968        if {$j <10} {
2969            set key " EXPR ATYP $j"
2970        } else {
2971            set key " EXPR ATYP$j"
2972        }
2973        while {![existsexp $key]} {
2974            incr j
2975            if {$j > 99} {
2976                return
2977            } elseif {$j <10} {
2978                set key " EXPR ATYP $j"
2979            } else {
2980                set key " EXPR ATYP$j"
2981            }
2982        }
2983        set keytype [string trim [string range $exparray($key) 2 9]]
2984        if {$type == $keytype} {
2985            # found the type record
2986            set val [string trim [string range $exparray($key) 10 14]]
2987            incr val -1
2988            # if this is the last reference, remove the record,
2989            # otherwise, decrement the counter
2990            if {$val <= 0} {
2991                incr natypes -1 
2992                validint natypes 5
2993                setexp " EXPR  NATYP" $natypes 1 5
2994                delexp $key
2995            } else {
2996                validint val 5
2997                setexp $key $val 11 5
2998            }
2999            return
3000        }
3001    }
3002}
3003
3004# compute equivalent anisotropic temperature factor for Uequiv
3005proc CalcAniso {phase Uequiv} {
3006    foreach var {a b c alpha beta gamma} {
3007        set $var [phaseinfo $phase $var]
3008    }
3009
3010    set G(1,1) [expr {$a * $a}]
3011    set G(2,2) [expr {$b * $b}]
3012    set G(3,3) [expr {$c * $c}]
3013    set G(1,2) [expr {$a * $b * cos($gamma*0.017453292519943)}]
3014    set G(2,1) $G(1,2)
3015    set G(1,3) [expr {$a * $c * cos($beta *0.017453292519943)}]
3016    set G(3,1) $G(1,3)
3017    set G(2,3) [expr {$b * $c * cos($alpha*0.017453292519943)}]
3018    set G(3,2) $G(2,3)
3019
3020    # Calculate the volume**2
3021    set v2 0.0
3022    foreach i {1 2 3} {
3023        set J [expr {($i%3) + 1}]
3024        set K [expr {(($i+1)%3) + 1}]
3025        set v2 [expr {$v2+ $G(1,$i)*($G(2,$J)*$G(3,$K)-$G(3,$J)*$G(2,$K))}]
3026    }
3027    if {$v2 > 0} {
3028        set v [expr {sqrt($v2)}]
3029        foreach i {1 2 3} {
3030            set i1 [expr {($i%3) + 1}]
3031            set i2 [expr {(($i+1)%3) + 1}]
3032            foreach j {1 2 3} {
3033                set j1 [expr {($j%3) + 1}]
3034                set j2 [expr {(($j+1)%3) + 1}]
3035                set C($j,$i) [expr {(\
3036                        $G($i1,$j1) * $G($i2,$j2) - \
3037                        $G($i1,$j2)  * $G($i2,$j1)\
3038                        )/ $v}]
3039            }
3040        }
3041        set A(1,2) [expr {0.5 * ($C(1,2)+$C(2,1)) / sqrt( $C(1,1)* $C(2,2) )}]
3042        set A(1,3) [expr {0.5 * ($C(1,3)+$C(3,1)) / sqrt( $C(1,1)* $C(3,3) )}]
3043        set A(2,3) [expr {0.5 * ($C(2,3)+$C(3,2)) / sqrt( $C(2,2)* $C(3,3) )}]
3044        foreach i {1 1 2} j {2 3 3} {
3045            set A($i,$j) [expr {0.5 * ($C($i,$j) + $C($j,$i)) / \
3046                    sqrt( $C($i,$i)* $C($j,$j) )}]
3047            # clean up roundoff
3048            if {abs($A($i,$j)) < 1e-5} {set A($i,$j) 0.0}
3049        }
3050    } else {
3051        set A(1,2) 0.0
3052        set A(1,3) 0.0
3053        set A(2,3) 0.0
3054    }
3055    return "$Uequiv $Uequiv $Uequiv \
3056            [expr {$Uequiv * $A(1,2)}] \
3057            [expr {$Uequiv * $A(1,3)}] \
3058            [expr {$Uequiv * $A(2,3)}]"
3059}
3060
3061# read/edit soft (distance) restraint info
3062#  parm:
3063#    weight -- histogram weight (factr) *
3064#    restraintlist -- list of restraints *
3065#  action: get (default) or set
3066#  value: used only with set
3067#  * =>  read+write supported
3068proc SoftConst {parm "action get" "value {}"} {
3069    set HST {}
3070    # look for RSN record
3071    set n 0
3072    for {set i 0} {$i < $::expmap(nhst)} {incr i} {
3073        set ihist [expr {$i + 1}]
3074        if {[expr {$i % 12}] == 0} {
3075            incr n
3076            set line [readexp " EXPR  HTYP$n"]
3077            if {$line == ""} {
3078                set msg "No HTYP$n entry for Histogram $ihist. This is an invalid .EXP file"
3079                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
3080            }
3081            set j 0
3082        } else {
3083            incr j
3084        }
3085        if {[string range $line [expr 2+5*$j] [expr 5*($j+1)]] == "RSN "} {
3086            set HST $ihist
3087        }
3088    }
3089    if {$HST <=9} {
3090        set key "HST  $HST"
3091    } else {
3092        set key "HST $HST"
3093    }
3094    if {$HST == "" && $action == "set"} {
3095        # no RSN found need to add the soft constr. histogram
3096        # increment number of histograms
3097        set hst [string trim [string range [readexp { EXPR  NHST }] 0 4]]
3098        incr hst
3099        set HST $hst
3100        if ![validint hst 5] {return 0}
3101        setexp  { EXPR  NHST } $hst 1 5
3102        # add to EXPR HTYPx rec, creating if needed
3103        set n [expr { 1+ (($HST - 1) / 12) }]
3104        set key " EXPR  HTYP$n"
3105        if {[array names ::exparray $key] == ""} {
3106            makeexprec $key
3107        }
3108        setexp $key "RSN " [expr 3 + 5*(($HST-1) % 12)] 5
3109        # create other HST  xx recs
3110        if {$HST <=9} {
3111            set key "HST  $HST"
3112        } else {
3113            set key "HST $HST"
3114        }
3115        makeexprec "$key  HNAM"
3116        setexp "$key  HNAM" "Bond distance restraints" 3 24
3117        makeexprec "$key FACTR"
3118        makeexprec "$key NBNDS"
3119        mapexp
3120    } elseif {$HST == ""} {
3121        if $::expgui(debug) {puts "no restraints"}
3122        return "1"
3123    }
3124
3125    switch -glob ${parm}-$action {
3126        weight-get {
3127            return [string trim [string range [readexp "$key FACTR"] 0 14]]
3128        }
3129        weight-set {
3130            # update FACTR
3131            if ![validreal value 15 6] {return 0}
3132            setexp "$key FACTR" $value 1 15
3133        }
3134        restraintlist-get {
3135            set ncons [string trim [string range [readexp "$key NBNDS"] 0 4]]
3136            set conslist {}
3137            for {set i 1} {$i <= $ncons} {incr i} {
3138                set fi [string toupper [format %.4x $i]]
3139                set line [readexp "${key}BD$fi"]
3140                set const {}
3141                foreach len {3 5 5 3 3 3 3 3 6 6} {
3142                  set lenm1 [expr {$len - 1}]
3143                  lappend const [string trim [string range $line 0 $lenm1]]
3144                  set line [string range $line $len end]
3145                }
3146                lappend conslist $const
3147            }
3148            return $conslist
3149        }
3150        restraintlist-set {
3151            set num [llength $value]
3152            if ![validint num 5] {return 0}
3153            setexp "$key NBNDS" $num 1 5
3154            # delete all old records
3155            foreach i [array names ::exparray "${key}BD*"] {unset ::exparray($i)}
3156            set i 0
3157            foreach cons $value {
3158                incr i
3159                set fi [string toupper [format %.4x $i]]
3160                makeexprec "${key}BD$fi"
3161                set pos 1
3162                foreach num $cons len {3 5 5 3 3 3 3 3 -6 -6} {
3163                    if {$len > 0} {
3164                        validint num $len
3165                        setexp "${key}BD$fi" $num $pos $len
3166                    } else {
3167                        set len [expr abs($len)]
3168                        validreal num $len 3
3169                        setexp "${key}BD$fi" $num $pos $len
3170                    }
3171                    incr pos $len
3172                }
3173            }
3174        }
3175        default {
3176            set msg "Unsupported phaseinfo access: parm=$parm action=$action"
3177            tk_dialog .badexp "Error in readexp" $msg error 0 Exit
3178        }
3179    return 1
3180    }
3181}
3182
3183#======================================================================
3184# conversion routines
3185#======================================================================
3186
3187# convert x values to d-space
3188proc tod {xlist hst} {
3189    global expmap
3190    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
3191        return [toftod $xlist $hst]
3192    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
3193        return [tttod $xlist $hst]
3194    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
3195        return [engtod $xlist $hst]
3196    } else {
3197        return {}
3198    }
3199}
3200
3201# convert tof to d-space
3202proc toftod {toflist hst} {
3203    set difc [expr {[histinfo $hst difc]/1000.}]
3204    set difc2 [expr {$difc*$difc}]
3205    set difa [expr {[histinfo $hst difa]/1000.}]
3206    set zero [expr {[histinfo $hst zero]/1000.}]
3207    set ans {}
3208    foreach tof $toflist {
3209        if {$tof == 0.} {
3210            lappend ans 0.
3211        } elseif {$tof == 1000.} {
3212            lappend ans 1000.
3213        } else {
3214            set td [expr {$tof-$zero}]
3215            lappend ans [expr {$td*($difc2+$difa*$td)/ \
3216                    ($difc2*$difc+2.0*$difa*$td)}]
3217        }
3218    }
3219    return $ans
3220}
3221
3222# convert two-theta to d-space
3223proc tttod {twotheta hst} {
3224    set lamo2 [expr {0.5 * [histinfo $hst lam1]}]
3225    set zero [expr [histinfo $hst zero]/100.]
3226    set ans {}
3227    set cnv [expr {acos(0.)/180.}]
3228    foreach tt $twotheta {
3229        if {$tt == 0.} {
3230            lappend ans 99999.
3231        } elseif {$tt == 1000.} {
3232            lappend ans 0.
3233        } else {
3234            lappend ans [expr {$lamo2 / sin($cnv*($tt-$zero))}]
3235        }
3236    }
3237    return $ans
3238}
3239
3240# convert energy (edx-ray) to d-space
3241# (note that this ignores the zero correction)
3242proc engtod {eng hst} {
3243    set lam [histinfo $hst lam1]
3244    set zero [histinfo $hst zero]
3245    set ans {}
3246    set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
3247    foreach e $eng {
3248        if {$e == 0.} {
3249            lappend ans 1000.
3250        } elseif {$e == 1000.} {
3251            lappend ans 0.
3252        } else {
3253            lappend ans [expr {$v/$e}]
3254        }
3255    }
3256    return $ans
3257}
3258
3259# convert x values to Q
3260proc toQ {xlist hst} {
3261    global expmap
3262    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
3263        return [toftoQ $xlist $hst]
3264    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
3265        return [tttoQ $xlist $hst]
3266    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
3267        return [engtoQ $xlist $hst]
3268    } else {
3269        return {}
3270    }
3271}
3272# convert tof to Q
3273proc toftoQ {toflist hst} {
3274    set difc [expr {[histinfo $hst difc]/1000.}]
3275    set difc2 [expr {$difc*$difc}]
3276    set difa [expr {[histinfo $hst difa]/1000.}]
3277    set zero [expr {[histinfo $hst zero]/1000.}]
3278    set 2pi [expr {4.*acos(0.)}]
3279    set ans {}
3280    foreach tof $toflist {
3281        if {$tof == 0.} {
3282            lappend ans 99999.
3283        } elseif {$tof == 1000.} {
3284            lappend ans 0.
3285        } else {
3286            set td [expr {$tof-$zero}]
3287            lappend ans [expr {$2pi * \
3288                    ($difc2*$difc+2.0*$difa*$td)/($td*($difc2+$difa*$td))}]
3289        }
3290    }
3291    return $ans
3292}
3293
3294# convert two-theta to Q
3295proc tttoQ {twotheta hst} {
3296    set lamo2 [expr {0.5 * [histinfo $hst lam1]}]
3297    set zero [expr [histinfo $hst zero]/100.]
3298    set ans {}
3299    set cnv [expr {acos(0.)/180.}]
3300    set 2pi [expr {4.*acos(0.)}]
3301    foreach tt $twotheta {
3302        if {$tt == 0.} {
3303            lappend ans 0.
3304        } elseif {$tt == 1000.} {
3305            lappend ans 1000.
3306        } else {
3307            lappend ans [expr {$2pi * sin($cnv*($tt-$zero)) / $lamo2}]
3308        }
3309    }
3310    return $ans
3311}
3312# convert energy (edx-ray) to Q
3313# (note that this ignores the zero correction)
3314proc engtoQ {eng hst} {
3315    set lam [histinfo $hst lam1]
3316    set zero [histinfo $hst zero]
3317    set ans {}
3318    set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
3319    set 2pi [expr {4.*acos(0.)}]
3320    foreach e $eng {
3321        if {$e == 0.} {
3322            lappend ans 0.
3323        } elseif {$e == 1000.} {
3324            lappend ans 1000.
3325        } else {
3326            lappend ans [expr {$2pi * $e / $v}]
3327        }
3328    }
3329    return $ans
3330}
3331proc sind {angle} {
3332    return [expr {sin($angle*acos(0.)/90.)}]
3333}
3334
3335# convert d-space values to 2theta, TOF or KeV
3336proc fromd {dlist hst} {
3337    global expmap
3338    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
3339        set difc [expr {[histinfo $hst difc]/1000.}]
3340        set difa [expr {[histinfo $hst difa]/1000.}]
3341        set zero [expr {[histinfo $hst zero]/1000.}]
3342        set ans {}
3343        foreach d $dlist {
3344            if {$d == 0.} {
3345                lappend ans 0.
3346            } elseif {$d == 1000.} {
3347                lappend ans 1000.
3348            } else {
3349                lappend ans [expr {$difc*$d + $difa*$d*$d + $zero}]
3350            }
3351        }
3352        return $ans
3353    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
3354        set lamo2 [expr {0.5 * [histinfo $hst lam1]}]
3355        set zero [expr [histinfo $hst zero]/100.]
3356        set ans {}
3357        set cnv [expr {180./acos(0.)}]
3358        foreach d $dlist {
3359            if {$d == 99999.} {
3360                lappend ans 0
3361            } elseif {$d == 0.} {
3362                lappend ans 1000.
3363            } else {
3364                lappend ans [expr {$cnv*asin($lamo2/$d) + $zero}]
3365            }
3366        }
3367        return $ans
3368    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
3369        set lam [histinfo $hst lam1]
3370        set zero [histinfo $hst zero]
3371        set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
3372        set ans {}
3373        foreach d $dlist {
3374            if {$d == 1000.} {
3375                lappend ans 0
3376            } elseif {$d == 0.} {
3377                lappend ans 1000.
3378            } else {
3379                lappend ans [expr {$v/$d}]
3380            }
3381        }
3382        return $ans
3383    } else {
3384        return {}
3385    }
3386}
3387
3388# convert Q values to 2theta, TOF or KeV
3389proc fromQ {Qlist hst} {
3390    global expmap
3391    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
3392        set difc [expr {[histinfo $hst difc]/1000.}]
3393        set difa [expr {[histinfo $hst difa]/1000.}]
3394        set zero [expr {[histinfo $hst zero]/1000.}]
3395        set ans {}
3396        foreach Q $Qlist {
3397            if {$Q == 0.} {
3398                lappend ans 1000.
3399            } elseif {$Q == 99999.} {
3400                lappend ans 1000.
3401            } else {
3402                set d [expr {4.*acos(0.)/$Q}]
3403                lappend ans [expr {$difc*$d + $difa*$d*$d + $zero}]
3404            }
3405        }
3406        return $ans
3407    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
3408        set lamo4pi [expr {[histinfo $hst lam1]/(8.*acos(0.))}]
3409        set zero [expr [histinfo $hst zero]/100.]
3410        set ans {}
3411        set cnv [expr {180./acos(0.)}]
3412        foreach Q $Qlist {
3413            if {$Q == 0.} {
3414                lappend ans 0
3415            } elseif {$Q == 1000.} {
3416                lappend ans 1000.
3417            } else {
3418                lappend ans [expr {$cnv*asin($Q*$lamo4pi) + $zero}]
3419            }
3420        }
3421        return $ans
3422    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
3423        set lam [histinfo $hst lam1]
3424        set zero [histinfo $hst zero]
3425        set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
3426        set ans {}
3427        set 2pi [expr {4.*acos(0.)}]
3428        foreach Q $Qlist {
3429            if {$Q == 1000.} {
3430                lappend ans 0
3431            } elseif {$Q == 0.} {
3432                lappend ans 1000.
3433            } else {
3434                lappend ans [expr {$Q * $v/$2pi}]
3435            }
3436        }
3437        return $ans
3438    } else {
3439        return {}
3440    }
3441}
Note: See TracBrowser for help on using the repository browser.