source: trunk/readexp.tcl @ 719

Last change on this file since 719 was 712, checked in by toby, 16 years ago

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