source: branches/sandbox/readexp.tcl @ 1109

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

recent changes: fix coordinates, rb start

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