source: trunk/readexp.tcl @ 707

Last change on this file since 707 was 702, checked in by toby, 16 years ago

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