source: trunk/readexp.tcl @ 681

Last change on this file since 681 was 674, checked in by toby, 16 years ago

# on 2003/04/10 22:14:21, toby did:
more sig figs on small numbers (switch to scientific notation earlier)
implement powpref warning
update absorption correction to blank spaces
add data conversion routines (from excledt)
  • Property rcs:author set to toby
  • Property rcs:date set to 2003/04/10 22:14:21
  • Property rcs:lines set to +387 -8
  • Property rcs:rev set to 1.38
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 79.8 KB
Line 
1# $Id: readexp.tcl 674 2009-12-04 23:10:07Z toby $
2# Routines to deal with the .EXP "data structure"
3set expmap(Revision) {$Revision: 674 $ $Date: 2009-12-04 23:10:07 +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                return [string trim [string range [readexp "${key}ABSCOR"] 40 44]]
1710            }
1711            abstype-set {
1712                if ![validint value 5] {return 0}
1713                setexp "${key}ABSCOR" $value 41 5
1714            }
1715            absdamp-get {
1716                set val [string range [readexp "${key}ABSCOR"] 39 39]
1717                if {$val == " "} {return 0}
1718                return $val
1719            }
1720            absdamp-set {
1721                if ![validint value 5] {return 0}
1722                setexp "${key}ABSCOR" $value 36 5
1723            }
1724            absref-get {
1725                if {[string toupper \
1726                        [string range [readexp "${key}ABSCOR"] 34 34]] == "Y"} {
1727                    return 1
1728                }
1729                return 0
1730            }
1731            absref-set {
1732                if $value {
1733                    setexp "${key}ABSCOR" "    Y" 31 5
1734                } else {
1735                    setexp "${key}ABSCOR" "    N" 31 5
1736                }
1737            }
1738            ITYP-get {
1739                return [string trim [readexp "${key}I ITYP"]]
1740            }
1741            default {
1742                set msg "Unsupported histinfo access: parm=$parm action=$action"
1743                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
1744            }
1745        }
1746    }
1747    return 1
1748}
1749
1750# read the information that differs by both histogram and phase (profile & phase fraction)
1751# use: hapinfo hist phase parm action value
1752# 
1753#     frac -- phase fraction (*)
1754#     frref/frdamp -- refinement flag/damping value for the phase fraction (*)
1755#     proftype -- profile function number (*)
1756#     profterms -- number of profile terms (*)
1757#     pdamp -- damping value for the profile (*)
1758#     pcut -- cutoff value for the profile (*)
1759#     pterm$n -- profile term #n (*)
1760#     pref$n -- refinement flag value for profile term #n (*)
1761#     extmeth -- Fobs extraction method (*)
1762#     POnaxis -- number of defined M-D preferred axes
1763proc hapinfo {histlist phaselist parm "action get" "value {}"} {
1764    foreach phase $phaselist hist $histlist {
1765        if {$phase == ""} {set phase [lindex $phaselist end]}
1766        if {$hist == ""} {set hist [lindex $histlist end]}
1767        if {$hist < 10} {
1768            set hist " $hist"
1769        }
1770        set key "HAP${phase}${hist}"
1771        switch -glob ${parm}-$action {
1772            extmeth-get {
1773                set i1 [expr {($phase - 1)*5}]
1774                set i2 [expr {$i1 + 4}]
1775                return [string trim [string range [readexp "HST $hist EPHAS"] $i1 $i2]]
1776            }
1777            extmeth-set {
1778                set i1 [expr {($phase - 1)*5 + 1}]
1779                if ![validint value 5] {return 0}
1780                setexp "HST $hist EPHAS" $value $i1 5
1781            }
1782            frac-get {
1783                return [string trim [string range [readexp ${key}PHSFR] 0 14]]
1784            }
1785            frac-set {
1786                if ![validreal value 15 6] {return 0}
1787                setexp ${key}PHSFR $value 1 15
1788            }
1789            frref-get {
1790                if {[string toupper [string range [readexp ${key}PHSFR] 19 19]] == "Y"} {
1791                    return 1
1792                }
1793                return 0
1794            }
1795            frref-set {
1796                if $value {
1797                    setexp ${key}PHSFR "Y" 20 1
1798                } else {
1799                    setexp ${key}PHSFR "N" 20 1
1800                }           
1801            }
1802            frdamp-get {
1803                set val [string range [readexp ${key}PHSFR] 24 24]
1804                if {$val == " "} {return 0}
1805                return $val
1806            }
1807            frdamp-set {
1808                setexp ${key}PHSFR $value 25 1
1809            }
1810            proftype-get {
1811                set val [string range [readexp "${key}PRCF "] 0 4]
1812                if {$val == " "} {return 0}
1813                return $val
1814            }
1815            proftype-set {
1816                if ![validint value 5] {return 0}
1817                setexp "${key}PRCF " $value 1 5
1818                # set the powpref warning (1 = suggested)
1819                catch {
1820                    global expgui
1821                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1822                    set msg "Profile parameters" 
1823                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1824                        append expgui(needpowpref_why) "\t$msg were changed\n"
1825                    }
1826                }
1827            }
1828            profterms-get {
1829                set val [string range [readexp "${key}PRCF "] 5 9]
1830                if {$val == " "} {return 0}
1831                return $val
1832            }
1833            profterms-set {
1834                if ![validint value 5] {return 0}
1835                setexp "${key}PRCF " $value 6 5
1836                # now check that all needed entries exist
1837                set lines [expr {1 + ($value - 1) / 4}]
1838                for {set i 1} {$i <= $lines} {incr i} {
1839                    makeexprec "${key}PRCF $i"
1840                }
1841                # set the powpref warning (1 = suggested)
1842                catch {
1843                    global expgui
1844                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1845                    set msg "Profile parameters" 
1846                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1847                        append expgui(needpowpref_why) "\t$msg were changed\n"
1848                    }
1849                }
1850            }
1851            pcut-get {
1852                return [string trim [string range [readexp "${key}PRCF "] 10 19]]
1853            }
1854            pcut-set {
1855                if ![validreal value 10 5] {return 0}
1856                setexp "${key}PRCF " $value 11 10
1857                # set the powpref warning (1 = suggested)
1858                catch {
1859                    global expgui
1860                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1861                    set msg "Profile parameters" 
1862                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1863                        append expgui(needpowpref_why) "\t$msg were changed\n"
1864                    }
1865                }
1866            }
1867            pdamp-get {
1868                set val [string range [readexp "${key}PRCF "] 24 24]
1869                if {$val == " "} {return 0}
1870                return $val
1871            }
1872            pdamp-set {
1873                setexp "${key}PRCF   " $value 25 1
1874            }
1875            pterm*-get {
1876                regsub pterm $parm {} num
1877                set f1 [expr {15*(($num - 1) % 4)}]
1878                set f2 [expr {15*(1 + ($num - 1) % 4)-1}]
1879                set line  [expr {1 + ($num - 1) / 4}]
1880                return [string trim [string range [readexp "${key}PRCF $line"] $f1 $f2] ]
1881            }
1882            pterm*-set {
1883                if ![validreal value 15 6] {return 0}
1884                regsub pterm $parm {} num
1885                set f1 [expr {1+ 15*(($num - 1) % 4)}]
1886                set line  [expr {1 + ($num - 1) / 4}]
1887                setexp "${key}PRCF $line" $value $f1 15
1888                # set the powpref warning (1 = suggested)
1889                catch {
1890                    global expgui
1891                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1892                    set msg "Profile parameters" 
1893                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1894                        append expgui(needpowpref_why) "\t$msg were changed\n"
1895                    }
1896                }
1897            }
1898            pref*-get {
1899                regsub pref $parm {} num
1900                set f [expr {24+$num}]
1901                if {[string toupper [string range [readexp "${key}PRCF  "] $f $f]] == "Y"} {
1902                    return 1
1903                }
1904                return 0
1905            }
1906            pref*-set {
1907                regsub pref $parm {} num
1908                set f [expr {25+$num}]
1909                if $value {
1910                    setexp ${key}PRCF "Y" $f 1
1911                } else {
1912                    setexp ${key}PRCF "N" $f 1
1913                }           
1914            }
1915            POnaxis-get {
1916                set val [string trim \
1917                        [string range [readexp "${key}NAXIS"] 0 4]]
1918                if {$val == ""} {return 0}
1919                return $val
1920            }
1921            POnaxis-set {
1922                if ![validint value 5] {return 0}
1923                # there should be a NAXIS record, but if not make one
1924                if {![existsexp "${key}NAXIS"]} {
1925                    makeexprec "${key}NAXIS"
1926                }
1927                setexp "${key}NAXIS  " $value 1 5
1928            }
1929            default {
1930                set msg "Unsupported hapinfo access: parm=$parm action=$action"
1931                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
1932            }
1933        }
1934    }
1935    return 1
1936}
1937
1938#  get a logical constraint
1939#
1940#  type action
1941#  -----------
1942#  atom get  number        returns a list of constraints.
1943#   "   set  number value  replaces a list of constraints
1944#                          (value is a list of constraints)
1945#   "   add  number value  inserts a new list of constraints
1946#                          (number is ignored)
1947#   "   delete number      deletes a set of constraint entries
1948# Each item in the list of constraints is composed of 4 items:
1949#              phase, atom, variable, multiplier
1950# If variable=UISO atom can be ALL, otherwise atom is a number
1951# legal variable names: FRAC, X, Y, Z, UISO, U11, U22, U33, U12, U23, U13,
1952#                       MX, MY, MZ
1953#
1954#  type action
1955#  -----------
1956#  profileXX get number         returns a list of constraints for term XX=1-36
1957#                               use number=0 to get # of defined
1958#                                  constraints for term XX
1959#   "        set number value   replaces a list of constraints
1960#                               (value is a list of constraints)
1961#   "        add number value   inserts a new list of constraints
1962#                               (number is ignored)
1963#   "        delete number      deletes a set of constraint entries
1964# Each item in the list of constraints is composed of 3 items:
1965#              phase-list, histogram-list, multiplier
1966# Note that phase-list and/or histogram-list can be ALL
1967
1968proc constrinfo {type action number "value {}"} {
1969    global expmap
1970    if {[lindex $expmap(phasetype) 0] == 4} {
1971        set mm 1
1972    } else {
1973        set mm 0
1974    }
1975    switch -glob ${type}-$action {
1976        atom-get {
1977            # does this constraint exist?
1978            set key [format "LNCN%4d%4d" $number 1]
1979            if {![existsexp $key]} {return -1}
1980            set clist {}
1981            for {set i 1} {$i < 999} {incr i} {
1982                set key [format "LNCN%4d%4d" $number $i]
1983                if {![existsexp $key]} break
1984                set line [readexp $key]
1985                set j1 2
1986                set j2 17
1987                set seg [string range $line $j1 $j2]
1988                while {[string trim $seg] != ""} {
1989                    set p [string range $seg 0 0]
1990                    if {$p == 1 && $mm} {
1991                        set atom [string trim [string range $seg 1 4]]
1992                        set var [string trim [string range $seg 5 7]]
1993                        if {$atom == "ALL"} {
1994                            set var UIS
1995                        } else {
1996                            scan $atom %x atom
1997                        }
1998                        lappend clist [list $p $atom $var \
1999                                [string trim [string range $seg 8 end]]]
2000                    } else {
2001                        lappend clist [list $p \
2002                                [string trim [string range $seg 1 3]] \
2003                                [string trim [string range $seg 4 7]] \
2004                                [string trim [string range $seg 8 end]]]
2005                    }
2006                    incr j1 16
2007                    incr j2 16
2008                    set seg [string range $line $j1 $j2]
2009                }
2010            }
2011            return $clist
2012        }
2013        atom-set {
2014            # delete records for current constraint
2015            for {set i 1} {$i < 999} {incr i} {
2016                set key [format "LNCN%4d%4d" $number $i]
2017                if {![existsexp $key]} break
2018                delexp $key
2019            }
2020            set line {}
2021            set i 1
2022            foreach tuple $value {
2023                set p [lindex $tuple 0]
2024                if {$p == 1 && $mm && \
2025                        [string toupper [lindex $tuple 1]] == "ALL"} {
2026                    set seg [format %1dALL UIS%8.4f \
2027                            [lindex $tuple 0] \
2028                            [lindex $tuple 3]]
2029                } elseif {$p == 1 && $mm} {
2030                    set seg [eval format %1d%.4X%-3s%8.4f $tuple]
2031                } elseif {[string toupper [lindex $tuple 1]] == "ALL"} {
2032                    set seg [format %1dALL%-4s%8.4f \
2033                            [lindex $tuple 0] \
2034                            [lindex $tuple 2] \
2035                            [lindex $tuple 3]]
2036                } else {
2037                    set seg [eval format %1d%3d%-4s%8.4f $tuple]
2038                }
2039                append line $seg
2040                if {[string length $line] > 50} {
2041                    set key  [format "LNCN%4d%4d" $number $i]
2042                    makeexprec $key
2043                    setexp $key $line 3 68
2044                    set line {}
2045                    incr i
2046                }
2047            }
2048            if {$line != ""} {
2049                set key  [format "LNCN%4d%4d" $number $i]
2050                makeexprec $key
2051                setexp $key $line 3 68
2052            }
2053            return
2054        }
2055        atom-add {
2056            # loop over defined constraints
2057            for {set j 1} {$j < 9999} {incr j} {
2058                set key [format "LNCN%4d%4d" $j 1]
2059                if {![existsexp $key]} break
2060            }
2061            set number $j
2062            # save the constraint
2063            set line {}
2064            set i 1
2065            foreach tuple $value {
2066                set p [lindex $tuple 0]
2067                if {$p == 1 && $mm && \
2068                        [string toupper [lindex $tuple 1]] == "ALL"} {
2069                    set seg [format %1dALL UIS%8.4f \
2070                            [lindex $tuple 0] \
2071                            [lindex $tuple 3]]
2072                } elseif {$p == 1 && $mm} {
2073                    set seg [eval format %1d%.4X%-3s%8.4f $tuple]
2074                } elseif {[string toupper [lindex $tuple 1]] == "ALL"} {
2075                    set seg [format %1dALL%-4s%8.4f \
2076                            [lindex $tuple 0] \
2077                            [lindex $tuple 2] \
2078                            [lindex $tuple 3]]
2079                } else {
2080                    set seg [eval format %1d%3d%-4s%8.4f $tuple]
2081                }
2082                append line $seg
2083                if {[string length $line] > 50} {
2084                    set key  [format "LNCN%4d%4d" $number $i]
2085                    makeexprec $key
2086                    setexp $key $line 3 68
2087                    set line {}
2088                    incr i
2089                }
2090            }
2091            if {$line != ""} {
2092                set key  [format "LNCN%4d%4d" $number $i]
2093                makeexprec $key
2094                setexp $key $line 3 68
2095            }
2096            return
2097        }
2098        atom-delete {
2099            for {set j $number} {$j < 9999} {incr j} {
2100                # delete records for current constraint
2101                for {set i 1} {$i < 999} {incr i} {
2102                    set key [format "LNCN%4d%4d" $j $i]
2103                    if {![existsexp $key]} break
2104                    delexp $key
2105                }
2106                # now copy records, from the next entry, if any
2107                set j1 $j
2108                incr j1
2109                set key1 [format "LNCN%4d%4d" $j1 1]
2110                # if there is no record, there is nothing to copy -- done
2111                if {![existsexp $key1]} return
2112                for {set i 1} {$i < 999} {incr i} {
2113                    set key1 [format "LNCN%4d%4d" $j1 $i]
2114                    if {![existsexp $key1]} break
2115                    set key  [format "LNCN%4d%4d" $j  $i]
2116                    makeexprec $key
2117                    setexp $key [readexp $key1] 1 68
2118                }
2119            }
2120        }
2121        profile*-delete {
2122            regsub profile $type {} term
2123            if {$term < 10} {
2124                set term " $term"
2125            }
2126            set key "LEQV PF$term   "
2127            # return nothing if no term exists
2128            if {![existsexp $key]} {return 0}
2129
2130            # number of constraint terms
2131            set nterms [string trim [string range [readexp ${key}] 0 4] ]
2132            # don't delete a non-existing entry
2133            if {$number > $nterms} {return 0}
2134            set val [expr {$nterms - 1}]
2135            validint val 5
2136            setexp $key $val 1 5
2137            for {set i1 $number} {$i1 < $nterms} {incr i1} {
2138                set i2 [expr {1 + $i1}]
2139                # move the contents of constraint #i2 -> i1
2140                if {$i1 > 9} {
2141                    set k1 [expr {($i1+1)/10}]
2142                    set l1 $i1
2143                } else {
2144                    set k1 " "
2145                    set l1 " $i1"
2146                }
2147                set key1 "LEQV PF$term  $k1"
2148                # number of constraint lines for #i1
2149                set n1 [string trim [string range [readexp ${key1}] \
2150                        [expr {($i1%10)*5}] [expr {4+(($i1%10)*5)}]] ]
2151                if {$i2 > 9} {
2152                    set k2 [expr {($i2+1)/10}]
2153                    set l2 $i2
2154                } else {
2155                    set k2 " "
2156                    set l2 " $i2"
2157                }
2158                set key2 "LEQV PF$term  $k2"
2159                # number of constraint lines for #i2
2160                set n2 [string trim [string range [readexp ${key2}] \
2161                        [expr {($i2%10)*5}] [expr {4+(($i2%10)*5)}]] ]
2162                set val $n2
2163                validint val 5
2164                # move the # of terms
2165                setexp $key1 $val [expr {1+(($i1%10)*5)}] 5
2166                # move the terms
2167                for {set j 1} {$j <= $n2} {incr j 1} {
2168                    set key "LEQV PF${term}${l1}$j"
2169                    makeexprec $key
2170                    setexp $key [readexp "LEQV PF${term}${l2}$j"] 1 68
2171                }
2172                # delete any remaining lines
2173                for {set j [expr {$n2+1}]} {$j <= $n1} {incr j 1} {
2174                    delexp "LEQV PF${term}${l1}$j"
2175                }
2176            }
2177
2178            # clear the last term
2179            if {$nterms > 9} {
2180                set i [expr {($nterms+1)/10}]
2181            } else {
2182                set i " "
2183            }
2184            set key "LEQV PF$term  $i"
2185            set cb [expr {($nterms%10)*5}]
2186            set ce [expr {4+(($nterms%10)*5)}]
2187            set n2 [string trim [string range [readexp ${key}] $cb $ce] ]
2188            incr cb
2189            setexp $key "     " $cb 5
2190            # delete any remaining lines
2191            for {set j 1} {$j <= $n2} {incr j 1} {
2192                delexp "LEQV PF${term}${nterms}$j"
2193            }
2194        }
2195        profile*-set {
2196            regsub profile $type {} term
2197            if {$term < 10} {
2198                set term " $term"
2199            }
2200            set key "LEQV PF$term   "
2201            # get number of constraint terms
2202            set nterms [string trim [string range [readexp ${key}] 0 4] ]
2203            # don't change a non-existing entry
2204            if {$number > $nterms} {return 0}
2205            if {$number > 9} {
2206                set k1 [expr {($number+1)/10}]
2207                set l1 $number
2208            } else {
2209                set k1 " "
2210                set l1 " $number"
2211            }
2212            set key1 "LEQV PF$term  $k1"
2213            # old number of constraint lines
2214            set n1 [string trim [string range [readexp ${key1}] \
2215                    [expr {($number%10)*5}] [expr {4+(($number%10)*5)}]] ]
2216            # number of new constraints
2217            set j2 [llength $value]
2218            # number of new constraint lines
2219            set val [set n2 [expr {($j2 + 2)/3}]]
2220            # store the new # of lines
2221            validint val 5
2222            setexp $key1 $val [expr {1+(($number%10)*5)}] 5
2223
2224            # loop over the # of lines in the old or new, whichever is greater
2225            set v0 0
2226            for {set j 1} {$j <= [expr {($n1 > $n2) ? $n1 : $n2}]} {incr j 1} {
2227                set key "LEQV PF${term}${l1}$j"
2228                # were there more lines in the old?
2229                if {$j > $n2} {
2230                    # this line is not needed
2231                    if {$j % 3 == 1} {
2232                        delexp %key
2233                    }
2234                    continue
2235                }
2236                # are we adding new lines?
2237                if {$j > $n1} {
2238                    makeexprec $key
2239                }
2240                # add the three constraints to the line
2241                foreach s {3 23 43} \
2242                        item [lrange $value $v0 [expr {2+$v0}]] {
2243                    if {$item != ""} {
2244                        set val [format %-10s%9.3f \
2245                                [lindex $item 0],[lindex $item 1] \
2246                                [lindex $item 2]]
2247                        setexp $key $val $s 19
2248                    } else {
2249                        setexp $key " " $s 19
2250                    }
2251                }
2252                incr v0 3
2253            }
2254        }
2255        profile*-add {
2256            regsub profile $type {} term
2257            if {$term < 10} {
2258                set term " $term"
2259            }
2260            set key "LEQV PF$term   "
2261            if {![existsexp $key]} {makeexprec $key}
2262            set nterms [string trim [string range [readexp ${key}] 0 4] ]
2263            if {$nterms == ""} {
2264                set nterms 1
2265            } elseif {$nterms >= 99} {
2266                return 0
2267            } else {
2268                incr nterms
2269            }
2270            # store the new # of constraints
2271            set val $nterms
2272            validint val 5
2273            setexp $key $val 1 5
2274
2275            if {$nterms > 9} {
2276                set k1 [expr {($nterms+1)/10}]
2277                set l1 $nterms
2278            } else {
2279                set k1 " "
2280                set l1 " $nterms"
2281            }
2282            set key1 "LEQV PF$term  $k1"
2283
2284            # number of new constraints
2285            set j2 [llength $value]
2286            # number of new constraint lines
2287            set val [set n2 [expr {($j2 + 2)/3}]]
2288            # store the new # of lines
2289            validint val 5
2290            setexp $key1 $val [expr {1+(($nterms%10)*5)}] 5
2291
2292            # loop over the # of lines to be added
2293            set v0 0
2294            for {set j 1} {$j <= $n2} {incr j 1} {
2295                set key "LEQV PF${term}${l1}$j"
2296                makeexprec $key
2297                # add the three constraints to the line
2298                foreach s {3 23 43} \
2299                        item [lrange $value $v0 [expr {2+$v0}]] {
2300                    if {$item != ""} {
2301                        set val [format %-10s%9.3f \
2302                                [lindex $item 0],[lindex $item 1] \
2303                                [lindex $item 2]]
2304                        setexp $key $val $s 19
2305                    } else {
2306                        setexp $key " " $s 19
2307                    }
2308                }
2309                incr v0 3
2310            }
2311        }
2312        profile*-get {
2313            regsub profile $type {} term
2314            if {$term < 10} {
2315                set term " $term"
2316            }
2317            if {$number > 9} {
2318                set i [expr {($number+1)/10}]
2319            } else {
2320                set i " "
2321            }
2322            set key "LEQV PF$term  $i"
2323            # return nothing if no term exists
2324            if {![existsexp $key]} {return 0}
2325            # number of constraint lines
2326           
2327            set numline [string trim [string range [readexp ${key}] \
2328                    [expr {($number%10)*5}] [expr {4+(($number%10)*5)}]] ]
2329            if {$number == 0} {return $numline}
2330            set clist {}
2331            if {$number < 10} {
2332                set number " $number"
2333            }
2334            for {set i 1} {$i <= $numline} {incr i} {
2335                set key "LEQV PF${term}${number}$i"
2336                set line [readexp ${key}]
2337                foreach s {1 21 41} e {20 40 60} {
2338                    set seg [string range $line $s $e]
2339                    if {[string trim $seg] == ""} continue
2340                    # parse the string segment
2341                    set parse [regexp { *([0-9AL]+),([0-9AL]+) +([0-9.]+)} \
2342                            $seg junk phase hist mult]
2343                    # was parse successful
2344                    if {!$parse} {continue}
2345                    lappend clist [list $phase $hist $mult]
2346                }
2347            }
2348            return $clist
2349        }
2350        default {
2351            set msg "Unsupported constrinfo access: type=$type action=$action"
2352            tk_dialog .badexp "Error in readexp access" $msg error 0 OK
2353        }
2354
2355    }
2356}
2357
2358# read the default profile information for a histogram
2359# use: profdefinfo hist set# parm action
2360# 
2361#     proftype -- profile function number
2362#     profterms -- number of profile terms
2363#     pdamp -- damping value for the profile (*)
2364#     pcut -- cutoff value for the profile (*)
2365#     pterm$n -- profile term #n
2366#     pref$n -- refinement flag value for profile term #n (*)
2367
2368proc profdefinfo {hist set parm "action get"} {
2369    global expgui
2370    if {$hist < 10} {
2371        set key "HST  $hist"
2372    } else {
2373        set key "HST $hist"
2374    }
2375    switch -glob ${parm}-$action {
2376        proftype-get {
2377            set val [string range [readexp "${key}PRCF$set"] 0 4]
2378            if {$val == " "} {return 0}
2379            return $val
2380        }
2381        profterms-get {
2382            set val [string range [readexp "${key}PRCF$set"] 5 9]
2383            if {$val == " "} {return 0}
2384            return $val
2385        }
2386        pcut-get {
2387            return [string trim [string range [readexp "${key}PRCF$set"] 10 19]]
2388        }
2389        pdamp-get {
2390                set val [string range [readexp "${key}PRCF$set"] 24 24]
2391            if {$val == " "} {return 0}
2392            return $val
2393        }
2394        pterm*-get {
2395            regsub pterm $parm {} num
2396            set f1 [expr {15*(($num - 1) % 4)}]
2397            set f2 [expr {15*(1 + ($num - 1) % 4)-1}]
2398            set line  [expr {1 + ($num - 1) / 4}]
2399            return [string trim [string range [\
2400                        readexp "${key}PRCF${set}$line"] $f1 $f2] ]
2401        }
2402        pref*-get {
2403            regsub pref $parm {} num
2404            set f [expr {24+$num}]
2405            if {[string toupper [string range [readexp "${key}PRCF$set"] $f $f]] == "Y"} {
2406                return 1
2407            }
2408            return 0
2409        }
2410        default {
2411            set msg "Unsupported profdefinfo access: parm=$parm action=$action"
2412            tk_dialog .badexp "Code Error" $msg error 0 Exit
2413        }
2414    }
2415}
2416
2417# get March-Dollase preferred orientation information
2418# use MDprefinfo hist phase axis-number parm action value
2419#    ratio    -- ratio of xtallites in PO direction vs random (>1 for more)
2420#    fraction -- fraction in this direction, when more than one axis is used
2421#    h k & l  -- indices of P.O. axis
2422#    ratioref -- flag to vary ratio
2423#    fracref  -- flag to vary fraction
2424#    damp     -- damping value
2425#    type     -- model type (0 = P.O. _|_ to beam, 1 = || to beam)
2426#    new      -- creates a new record with default values (set only)
2427proc MDprefinfo {histlist phaselist axislist parm "action get" "value {}"} {
2428    foreach phase $phaselist hist $histlist axis $axislist {
2429        if {$phase == ""} {set phase [lindex $phaselist end]}
2430        if {$hist == ""} {set hist [lindex $histlist end]}
2431        if {$axis == ""} {set axis [lindex $axislist end]}
2432        if {$hist < 10} {
2433            set hist " $hist"
2434        }
2435        if {$axis > 9} {
2436            set axis "0"
2437        }
2438        set key "HAP${phase}${hist}PREFO${axis}"
2439        switch -glob ${parm}-$action {
2440            ratio-get {
2441                return [string trim [string range [readexp $key] 0 9]]
2442            }
2443            ratio-set {
2444                if ![validreal value 10 6] {return 0}
2445                setexp $key $value 1 10
2446            }
2447            fraction-get {
2448                return [string trim [string range [readexp $key] 10 19]]
2449            }
2450            fraction-set {
2451                if ![validreal value 10 6] {return 0}
2452                setexp $key $value 11 10
2453            }
2454            h-get {
2455                set h [string trim [string range [readexp $key] 20 29]]
2456                # why not allow negative h values?
2457                #               if {$h < 1} {return 0}
2458                return $h
2459            }
2460            h-set {
2461                if ![validreal value 10 2] {return 0}
2462                setexp $key $value 21 10
2463            }
2464            k-get {
2465                set k [string trim [string range [readexp $key] 30 39]]
2466                #               if {$k < 1} {return 0}
2467                return $k
2468            }
2469            k-set {
2470                if ![validreal value 10 2] {return 0}
2471                setexp $key $value 31 10
2472            }
2473            l-get {
2474                set l [string trim [string range [readexp $key] 40 49]]
2475                #if {$l < 1} {return 0}
2476                return $l
2477            }
2478            l-set {
2479                if ![validreal value 10 2] {return 0}
2480                setexp $key $value 41 10
2481            }
2482            ratioref-get {
2483                if {[string toupper \
2484                        [string range [readexp $key] 53 53]] == "Y"} {
2485                    return 1
2486                }
2487                return 0
2488            }
2489            ratioref-set {
2490                if $value {
2491                    setexp $key "Y" 54 1
2492                } else {
2493                    setexp $key "N" 54 1
2494                }
2495            }
2496            fracref-get {
2497                if {[string toupper \
2498                        [string range [readexp $key] 54 54]] == "Y"} {
2499                    return 1
2500                }
2501                return 0
2502            }
2503            fracref-set {
2504                if $value {
2505                    setexp $key "Y" 55 1
2506                } else {
2507                    setexp $key "N" 55 1
2508              }
2509            }
2510            damp-get {
2511                set val [string trim [string range [readexp $key] 59 59]]
2512                if {$val == " "} {return 0}
2513                return $val
2514            }
2515            damp-set {
2516                setexp $key $value 60 1
2517            }
2518            type-get {
2519                set val [string trim [string range [readexp $key] 64 64]]
2520                if {$val == " "} {return 0}
2521                return $val
2522            }
2523            type-set {
2524                # only valid settings are 0 & 1
2525                if {$value != "0" && $value != "1"} {set value "0"}
2526                setexp $key $value 65 1
2527            }
2528            new-set {
2529                makeexprec $key
2530                setexp $key \
2531                        {  1.000000  1.000000  0.000000  0.000000  1.000000   NN    0    0} \
2532                        1 68
2533            }
2534            default {
2535                set msg "Unsupported MDprefinfo access: parm=$parm action=$action"
2536                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
2537            }
2538
2539        }
2540
2541    }
2542}
2543
2544# write the .EXP file
2545proc expwrite {expfile} {
2546    global exparray
2547    set blankline \
2548     "                                                                        "
2549    set fp [open ${expfile} w]
2550    fconfigure $fp -translation crlf
2551    set keylist [lsort [array names exparray]]
2552    # reorder the keys so that VERSION comes 1st
2553    set pos [lsearch -exact $keylist {     VERSION}]
2554    set keylist "{     VERSION} [lreplace $keylist $pos $pos]"
2555    foreach key $keylist {
2556        puts $fp [string range \
2557                "$key$exparray($key)$blankline" 0 79]
2558    }
2559    close $fp
2560}
2561
2562# history commands -- delete all but last $keep history records,
2563# renumber if $renumber is true
2564proc DeleteHistory {keep renumber} {
2565    global exparray
2566    foreach y [lrange [lsort -decreasing \
2567            [array names exparray {    HSTRY*}]] $keep end] {
2568        unset exparray($y)
2569    }
2570    if !$renumber return
2571    # renumber
2572    set i 0
2573    foreach y [lsort -increasing \
2574            [array names exparray {    HSTRY*}]] {
2575        set key [format "    HSTRY%3d" [incr i]]
2576        set exparray($key) $exparray($y)
2577        unset exparray($y)
2578    }
2579    # list all history
2580    #    foreach y [lsort -decreasing [array names exparray {    HSTRY*}]] {puts "$y $exparray($y)"}
2581}
2582
2583proc CountHistory {} {
2584    global exparray
2585    return [llength [array names exparray {    HSTRY*}]]
2586}
2587
2588# set the phase flags for histogram $hist to $plist
2589proc SetPhaseFlag {hist plist} {
2590    # make a 2 digit key -- hh
2591    if {$hist < 10} {
2592        set hh " $hist"
2593    } else {
2594        set hh $hist
2595    }
2596    set key "HST $hh NPHAS"
2597    set str {}
2598    foreach iph {1 2 3 4 5 6 7 8 9} {
2599        if {[lsearch $plist $iph] != -1} {
2600            append str {    1}
2601        } else {
2602            append str {    0}     
2603        }
2604    }
2605    setexp $key $str 1 68
2606}
2607
2608# erase atom $atom from phase $phase
2609# update the list of atom types, erasing the record if not needed.
2610proc EraseAtom {atom phase} {
2611    set type [atominfo $phase $atom type]
2612    if {$type == ""} return
2613    if {$atom < 10} {
2614        set key "CRS$phase  AT  $atom"
2615    } elseif {$atom < 100} {
2616        set key "CRS$phase  AT $atom"
2617    } else {
2618        set key "CRS$phase  AT$atom"
2619    }
2620    # delete the records for the atom
2621    global exparray
2622    foreach k [array names exparray ${key}*] {
2623        delexp $k
2624    }
2625    # change the number of atoms in the phase
2626    phaseinfo $phase natoms set [expr {[phaseinfo $phase natoms] -1}]
2627
2628    # now adjust numbers in "EXPR ATYP" records and delete, if needed.
2629    set natypes [readexp " EXPR  NATYP"]
2630    if {$natypes == ""} return
2631    set j 0
2632    for {set i 1} {$i <= $natypes} {incr i} {
2633        incr j
2634        if {$j <10} {
2635            set key " EXPR ATYP $j"
2636        } else {
2637            set key " EXPR ATYP$j"
2638        }
2639        while {![existsexp $key]} {
2640            incr j
2641            if {$j > 99} {
2642                return
2643            } elseif {$j <10} {
2644                set key " EXPR ATYP $j"
2645            } else {
2646                set key " EXPR ATYP$j"
2647            }
2648        }
2649        set keytype [string trim [string range $exparray($key) 2 9]]
2650        if {$type == $keytype} {
2651            # found the type record
2652            set val [string trim [string range $exparray($key) 10 14]]
2653            incr val -1
2654            # if this is the last reference, remove the record,
2655            # otherwise, decrement the counter
2656            if {$val <= 0} {
2657                incr natypes -1 
2658                validint natypes 5
2659                setexp " EXPR  NATYP" $natypes 1 5
2660                delexp $key
2661            } else {
2662                validint val 5
2663                setexp $key $val 11 5
2664            }
2665            return
2666        }
2667    }
2668}
2669
2670# compute equivalent anisotropic temperature factor for Uequiv
2671proc CalcAniso {phase Uequiv} {
2672    foreach var {a b c alpha beta gamma} {
2673        set $var [phaseinfo $phase $var]
2674    }
2675
2676    set G(1,1) [expr {$a * $a}]
2677    set G(2,2) [expr {$b * $b}]
2678    set G(3,3) [expr {$c * $c}]
2679    set G(1,2) [expr {$a * $b * cos($gamma*0.017453292519943)}]
2680    set G(2,1) $G(1,2)
2681    set G(1,3) [expr {$a * $c * cos($beta *0.017453292519943)}]
2682    set G(3,1) $G(1,3)
2683    set G(2,3) [expr {$b * $c * cos($alpha*0.017453292519943)}]
2684    set G(3,2) $G(2,3)
2685
2686    # Calculate the volume**2
2687    set v2 0.0
2688    foreach i {1 2 3} {
2689        set J [expr {($i%3) + 1}]
2690        set K [expr {(($i+1)%3) + 1}]
2691        set v2 [expr {$v2+ $G(1,$i)*($G(2,$J)*$G(3,$K)-$G(3,$J)*$G(2,$K))}]
2692    }
2693    if {$v2 > 0} {
2694        set v [expr {sqrt($v2)}]
2695        foreach i {1 2 3} {
2696            set i1 [expr {($i%3) + 1}]
2697            set i2 [expr {(($i+1)%3) + 1}]
2698            foreach j {1 2 3} {
2699                set j1 [expr {($j%3) + 1}]
2700                set j2 [expr {(($j+1)%3) + 1}]
2701                set C($j,$i) [expr {(\
2702                        $G($i1,$j1) * $G($i2,$j2) - \
2703                        $G($i1,$j2)  * $G($i2,$j1)\
2704                        )/ $v}]
2705            }
2706        }
2707        set A(1,2) [expr {0.5 * ($C(1,2)+$C(2,1)) / sqrt( $C(1,1)* $C(2,2) )}]
2708        set A(1,3) [expr {0.5 * ($C(1,3)+$C(3,1)) / sqrt( $C(1,1)* $C(3,3) )}]
2709        set A(2,3) [expr {0.5 * ($C(2,3)+$C(3,2)) / sqrt( $C(2,2)* $C(3,3) )}]
2710        foreach i {1 1 2} j {2 3 3} {
2711            set A($i,$j) [expr {0.5 * ($C($i,$j) + $C($j,$i)) / \
2712                    sqrt( $C($i,$i)* $C($j,$j) )}]
2713            # clean up roundoff
2714            if {abs($A($i,$j)) < 1e-5} {set A($i,$j) 0.0}
2715        }
2716    } else {
2717        set A(1,2) 0.0
2718        set A(1,3) 0.0
2719        set A(2,3) 0.0
2720    }
2721    return "$Uequiv $Uequiv $Uequiv \
2722            [expr {$Uequiv * $A(1,2)}] \
2723            [expr {$Uequiv * $A(1,3)}] \
2724            [expr {$Uequiv * $A(2,3)}]"
2725}
2726
2727#======================================================================
2728# conversion routines
2729#======================================================================
2730
2731# convert x values to d-space
2732proc tod {xlist hst} {
2733    global expmap
2734    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
2735        return [toftod $xlist $hst]
2736    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
2737        return [tttod $xlist $hst]
2738    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
2739        return [engtod $xlist $hst]
2740    } else {
2741        return {}
2742    }
2743}
2744
2745# convert tof to d-space
2746proc toftod {toflist hst} {
2747    set difc [expr {[histinfo $hst difc]/1000.}]
2748    set difc2 [expr {$difc*$difc}]
2749    set difa [expr {[histinfo $hst difa]/1000.}]
2750    set zero [expr {[histinfo $hst zero]/1000.}]
2751    set ans {}
2752    foreach tof $toflist {
2753        if {$tof == 0.} {
2754            lappend ans 0.
2755        } elseif {$tof == 1000.} {
2756            lappend ans 1000.
2757        } else {
2758            set td [expr {$tof-$zero}]
2759            lappend ans [expr {$td*($difc2+$difa*$td)/ \
2760                    ($difc2*$difc+2.0*$difa*$td)}]
2761        }
2762    }
2763    return $ans
2764}
2765
2766# convert two-theta to d-space
2767proc tttod {twotheta hst} {
2768    set lamo2 [expr {0.5 * [histinfo $hst lam1]}]
2769    set zero [expr [histinfo $hst zero]/100.]
2770    set ans {}
2771    set cnv [expr {acos(0.)/180.}]
2772    foreach tt $twotheta {
2773        if {$tt == 0.} {
2774            lappend ans 99999.
2775        } elseif {$tt == 1000.} {
2776            lappend ans 0.
2777        } else {
2778            lappend ans [expr {$lamo2 / sin($cnv*($tt-$zero))}]
2779        }
2780    }
2781    return $ans
2782}
2783
2784# convert energy (edx-ray) to d-space
2785# (note that this ignores the zero correction)
2786proc engtod {eng hst} {
2787    set lam [histinfo $hst lam1]
2788    set zero [histinfo $hst zero]
2789    set ans {}
2790    set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
2791    foreach e $eng {
2792        if {$e == 0.} {
2793            lappend ans 1000.
2794        } elseif {$e == 1000.} {
2795            lappend ans 0.
2796        } else {
2797            lappend ans [expr {$v/$e}]
2798        }
2799    }
2800    return $ans
2801}
2802
2803# convert x values to Q
2804proc toQ {xlist hst} {
2805    global expmap
2806    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
2807        return [toftoQ $xlist $hst]
2808    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
2809        return [tttoQ $xlist $hst]
2810    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
2811        return [engtoQ $xlist $hst]
2812    } else {
2813        return {}
2814    }
2815}
2816# convert tof to Q
2817proc toftoQ {toflist hst} {
2818    set difc [expr {[histinfo $hst difc]/1000.}]
2819    set difc2 [expr {$difc*$difc}]
2820    set difa [expr {[histinfo $hst difa]/1000.}]
2821    set zero [expr {[histinfo $hst zero]/1000.}]
2822    set 2pi [expr {4.*acos(0.)}]
2823    set ans {}
2824    foreach tof $toflist {
2825        if {$tof == 0.} {
2826            lappend ans 99999.
2827        } elseif {$tof == 1000.} {
2828            lappend ans 0.
2829        } else {
2830            set td [expr {$tof-$zero}]
2831            lappend ans [expr {$2pi * \
2832                    ($difc2*$difc+2.0*$difa*$td)/($td*($difc2+$difa*$td))}]
2833        }
2834    }
2835    return $ans
2836}
2837
2838# convert two-theta to Q
2839proc tttoQ {twotheta hst} {
2840    set lamo2 [expr {0.5 * [histinfo $hst lam1]}]
2841    set zero [expr [histinfo $hst zero]/100.]
2842    set ans {}
2843    set cnv [expr {acos(0.)/180.}]
2844    set 2pi [expr {4.*acos(0.)}]
2845    foreach tt $twotheta {
2846        if {$tt == 0.} {
2847            lappend ans 0.
2848        } elseif {$tt == 1000.} {
2849            lappend ans 1000.
2850        } else {
2851            lappend ans [expr {$2pi * sin($cnv*($tt-$zero)) / $lamo2}]
2852        }
2853    }
2854    return $ans
2855}
2856# convert energy (edx-ray) to Q
2857# (note that this ignores the zero correction)
2858proc engtoQ {eng hst} {
2859    set lam [histinfo $hst lam1]
2860    set zero [histinfo $hst zero]
2861    set ans {}
2862    set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
2863    set 2pi [expr {4.*acos(0.)}]
2864    foreach e $eng {
2865        if {$e == 0.} {
2866            lappend ans 0.
2867        } elseif {$e == 1000.} {
2868            lappend ans 1000.
2869        } else {
2870            lappend ans [expr {$2pi * $e / $v}]
2871        }
2872    }
2873    return $ans
2874}
2875proc sind {angle} {
2876    return [expr {sin($angle*acos(0.)/90.)}]
2877}
2878
2879# convert d-space values to 2theta, TOF or KeV
2880proc fromd {dlist hst} {
2881    global expmap
2882    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
2883        set difc [expr {[histinfo $hst difc]/1000.}]
2884        set difa [expr {[histinfo $hst difa]/1000.}]
2885        set zero [expr {[histinfo $hst zero]/1000.}]
2886        set ans {}
2887        foreach d $dlist {
2888            if {$d == 0.} {
2889                lappend ans 0.
2890            } elseif {$d == 1000.} {
2891                lappend ans 1000.
2892            } else {
2893                lappend ans [expr {$difc*$d + $difa*$d*$d + $zero}]
2894            }
2895        }
2896        return $ans
2897    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
2898        set lamo2 [expr {0.5 * [histinfo $hst lam1]}]
2899        set zero [expr [histinfo $hst zero]/100.]
2900        set ans {}
2901        set cnv [expr {180./acos(0.)}]
2902        foreach d $dlist {
2903            if {$d == 99999.} {
2904                lappend ans 0
2905            } elseif {$d == 0.} {
2906                lappend ans 1000.
2907            } else {
2908                lappend ans [expr {$cnv*asin($lamo2/$d) + $zero}]
2909            }
2910        }
2911        return $ans
2912    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
2913        set lam [histinfo $hst lam1]
2914        set zero [histinfo $hst zero]
2915        set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
2916        set ans {}
2917        foreach d $dlist {
2918            if {$d == 1000.} {
2919                lappend ans 0
2920            } elseif {$d == 0.} {
2921                lappend ans 1000.
2922            } else {
2923                lappend ans [expr {$v/$d}]
2924            }
2925        }
2926        return $ans
2927    } else {
2928        return {}
2929    }
2930}
2931
2932# convert Q values to 2theta, TOF or KeV
2933proc fromQ {Qlist hst} {
2934    global expmap
2935    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
2936        set difc [expr {[histinfo $hst difc]/1000.}]
2937        set difa [expr {[histinfo $hst difa]/1000.}]
2938        set zero [expr {[histinfo $hst zero]/1000.}]
2939        set ans {}
2940        foreach Q $Qlist {
2941            if {$Q == 0.} {
2942                lappend ans 1000.
2943            } elseif {$Q == 99999.} {
2944                lappend ans 1000.
2945            } else {
2946                set d [expr {4.*acos(0.)/$Q}]
2947                lappend ans [expr {$difc*$d + $difa*$d*$d + $zero}]
2948            }
2949        }
2950        return $ans
2951    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
2952        set lamo4pi [expr {[histinfo $hst lam1]/(8.*acos(0.))}]
2953        set zero [expr [histinfo $hst zero]/100.]
2954        set ans {}
2955        set cnv [expr {180./acos(0.)}]
2956        foreach Q $Qlist {
2957            if {$Q == 0.} {
2958                lappend ans 0
2959            } elseif {$Q == 1000.} {
2960                lappend ans 1000.
2961            } else {
2962                lappend ans [expr {$cnv*asin($Q*$lamo4pi) + $zero}]
2963            }
2964        }
2965        return $ans
2966    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
2967        set lam [histinfo $hst lam1]
2968        set zero [histinfo $hst zero]
2969        set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
2970        set ans {}
2971        set 2pi [expr {4.*acos(0.)}]
2972        foreach Q $Qlist {
2973            if {$Q == 1000.} {
2974                lappend ans 0
2975            } elseif {$Q == 0.} {
2976                lappend ans 1000.
2977            } else {
2978                lappend ans [expr {$Q * $v/$2pi}]
2979            }
2980        }
2981        return $ans
2982    } else {
2983        return {}
2984    }
2985}
Note: See TracBrowser for help on using the repository browser.