source: trunk/readexp.tcl @ 1033

Last change on this file since 1033 was 1033, checked in by toby, 15 years ago

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