source: branches/sandbox/readexp.tcl @ 1115

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

scan .EXP files for GENLES blowups; update web pages

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