source: trunk/readexp.tcl @ 830

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

# on 2004/11/17 14:20:26, toby did:
fix unformatted date -- belt & suspenders

  • Property rcs:author set to toby
  • Property rcs:date set to 2004/11/17 14:20:26
  • Property rcs:lines set to +3 -3
  • Property rcs:rev set to 1.43
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 80.6 KB
Line 
1# $Id: readexp.tcl 830 2009-12-04 23:12:46Z toby $
2# Routines to deal with the .EXP "data structure"
3set expmap(Revision) {$Revision: 830 $ $Date: 2009-12-04 23:12:46 +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] -format "%Y-%m-%dT%T]"
67    expwrite $expfile
68}
69
70# get information out from an EXP file
71#   creates the following entries in global array expmap
72#     expmap(phaselist)     gives a list of defined phases
73#     expmap(phasetype)     gives the phase type for each defined phase
74#                           =1 nuclear; 2 mag+nuc; 3 mag; 4 macro
75#     expmap(atomlist_$p)   gives a list of defined atoms in phase $p
76#     expmap(htype_$n)      gives the GSAS histogram type for histogram (all)
77#     expmap(powderlist)    gives a list of powder histograms in use
78#     expmap(phaselist_$n)  gives a list of phases used in histogram $n
79#     expmap(nhst)          the number of GSAS histograms
80#
81proc mapexp {} {
82    global 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                set val [string trim [string range [readexp "${key} ICONS"] 55 64]]
1346                if {$val == ""} {set val 0}
1347                # N.B. this code is used w/CW, where Kratio may not be 0.0
1348                set lam2 [string trim [string range [readexp "${key} ICONS"] 10 19]]
1349                if {$lam2 == ""} {set lam2 0}
1350                # Change kratio & flag the change (this is rather kludged)
1351                if {$val == 0 && $lam2 != 0} {
1352                    set val 0.5
1353                    validreal val 10 5
1354                    setexp "${key} ICONS" $val 56 10
1355                    catch {incr ::expgui(changed)}
1356                }
1357                return $val
1358            }
1359            kratio-set {
1360                if ![validreal value 10 5] {return 0}
1361                setexp "${key} ICONS" $value 56 10
1362            }
1363
1364            wref-get {
1365            #------------------------------------------------------
1366            # col 33: refine flag for lambda, difc, ratio and theta
1367            #------------------------------------------------------
1368                if {[string toupper [string range \
1369                        [readexp "${key} ICONS"] 32 32]] == "L"} {
1370                    return 1
1371                }
1372                return 0
1373            }
1374            wref-set {
1375                if $value {
1376                    setexp "${key} ICONS" "L" 33 1
1377                } else {
1378                    setexp "${key} ICONS" " " 33 1
1379                }           
1380            }
1381            ratref-get {
1382                if {[string toupper [string range \
1383                        [readexp "${key} ICONS"] 32 32]] == "R"} {
1384                    return 1
1385                }
1386                return 0
1387            }
1388            ratref-set {
1389                if $value {
1390                    setexp "${key} ICONS" "R" 33 1
1391                } else {
1392                    setexp "${key} ICONS" " " 33 1
1393                }           
1394            }
1395            dcref-get {
1396                if {[string toupper [string range \
1397                        [readexp "${key} ICONS"] 32 32]] == "C"} {
1398                    return 1
1399                }
1400                return 0
1401            }
1402            dcref-set {
1403                if $value {
1404                    setexp "${key} ICONS" "C" 33 1
1405                } else {
1406                    setexp "${key} ICONS" " " 33 1
1407                }           
1408            }
1409            ttref-get {
1410                if {[string toupper [string range \
1411                        [readexp "${key} ICONS"] 32 32]] == "T"} {
1412                    return 1
1413                }
1414                return 0
1415            }
1416            ttref-set {
1417                if $value {
1418                    setexp "${key} ICONS" "T" 33 1
1419                } else {
1420                    setexp "${key} ICONS" " " 33 1
1421                }           
1422            }
1423
1424
1425            pref-get {
1426            #------------------------------------------------------
1427            # col 34: refine flag for POLA & DIFA
1428            #------------------------------------------------------
1429                if {[string toupper [string range \
1430                        [readexp "${key} ICONS"] 33 33]] == "P"} {
1431                    return 1
1432                }
1433                return 0
1434            }
1435            pref-set {
1436                if $value {
1437                    setexp "${key} ICONS" "P" 34 1
1438                } else {
1439                    setexp "${key} ICONS" " " 34 1
1440                }           
1441            }
1442            daref-get {
1443                if {[string toupper [string range \
1444                        [readexp "${key} ICONS"] 33 33]] == "A"} {
1445                    return 1
1446                }
1447                return 0
1448            }
1449            daref-set {
1450                if $value {
1451                    setexp "${key} ICONS" "A" 34 1
1452                } else {
1453                    setexp "${key} ICONS" " " 34 1
1454                }           
1455            }
1456
1457            zref-get {
1458            #------------------------------------------------------
1459            # col 34: refine flag for zero correction
1460            #------------------------------------------------------
1461                if {[string toupper [string range [readexp "${key} ICONS"] 34 34]] == "Z"} {
1462                    return 1
1463                }
1464                return 0
1465            }
1466            zref-set {
1467                if $value {
1468                    setexp "${key} ICONS" "Z" 35 1
1469                } else {
1470                    setexp "${key} ICONS" " " 35 1
1471                }           
1472            }
1473
1474            ddamp-get {
1475                set val [string range [readexp "${key} ICONS"] 39 39]
1476                if {$val == " "} {return 0}
1477                return $val
1478            }
1479            ddamp-set {
1480                setexp "${key} ICONS" $value 40 1
1481            }
1482
1483            backtype-get {
1484                set val [string trim [string range [readexp "${key}BAKGD "] 0 4]]
1485                if {$val == " "} {return 0}
1486                return $val
1487            }
1488            backtype-set {
1489                if ![validint value 5] {return 0}
1490                setexp "${key}BAKGD " $value 1 5
1491            }
1492            backterms-get {
1493                set val [string trim [string range [readexp "${key}BAKGD "] 5 9]]
1494                if {$val == " "} {return 0}
1495                return $val
1496            }
1497            backterms-set {
1498                # this takes a bit of work -- if terms are added, add lines as needed to the .EXP
1499                set oldval [string trim [string range [readexp "${key}BAKGD "] 5 9]]
1500                if ![validint value 5] {return 0}
1501                if {$oldval < $value} {
1502                    set line1  [expr {2 + ($oldval - 1) / 4}]
1503                    set line2  [expr {1 + ($value - 1) / 4}]
1504                    for {set i $line1} {$i <= $line2} {incr i} {
1505                        # create a blank entry if needed
1506                        makeexprec ${key}BAKGD$i
1507                    }
1508                    incr oldval
1509                    for {set num $oldval} {$num <= $value} {incr num} {
1510                        set f1 [expr {15*(($num - 1) % 4)}]
1511                        set f2 [expr {15*(1 + ($num - 1) % 4)-1}]
1512                        set line  [expr {1 + ($num - 1) / 4}]
1513                        if {[string trim [string range [readexp ${key}BAKGD$line] $f1 $f2]] == ""} {
1514                            set f1 [expr {15*(($num - 1) % 4)+1}]
1515                            setexp ${key}BAKGD$line 0.0 $f1 15                 
1516                        }
1517                    }
1518                }
1519                setexp "${key}BAKGD " $value 6 5
1520
1521            }
1522            bref-get {
1523                if {[string toupper [string range [readexp "${key}BAKGD"] 14 14]] == "Y"} {
1524                    return 1
1525                }
1526                return 0
1527            }
1528            bref-set {
1529                if $value {
1530                    setexp "${key}BAKGD "  "Y" 15 1
1531                } else {
1532                    setexp "${key}BAKGD "  "N" 15 1
1533                }
1534            }
1535            bdamp-get {
1536                set val [string range [readexp "${key}BAKGD "] 19 19]
1537                if {$val == " "} {return 0}
1538                return $val
1539            }
1540            bdamp-set {
1541                setexp "${key}BAKGD " $value 20 1
1542            }
1543            bterm*-get {
1544                regsub bterm $parm {} num
1545                set f1 [expr {15*(($num - 1) % 4)}]
1546                set f2 [expr {15*(1 + ($num - 1) % 4)-1}]
1547                set line  [expr {1 + ($num - 1) / 4}]
1548                return [string trim [string range [readexp ${key}BAKGD$line] $f1 $f2] ]
1549            }
1550            bterm*-set {
1551                regsub bterm $parm {} num
1552                if ![validreal value 15 6] {return 0}
1553                set f1 [expr {15*(($num - 1) % 4)+1}]
1554                set line  [expr {1 + ($num - 1) / 4}]
1555                setexp ${key}BAKGD$line $value $f1 15
1556            }
1557            bank-get {
1558                return [string trim [string range [readexp "${key} BANK"] 0 4]]
1559            }
1560            tofangle-get {
1561                return [string trim [string range [readexp "${key}BNKPAR"] 10 19]]
1562            }
1563            tmin-get {
1564                return [string trim [string range [readexp "${key} TRNGE"] 0 9]]
1565            }
1566            tmax-get {
1567                return [string trim [string range [readexp "${key} TRNGE"] 10 19]]
1568            }
1569            excl-get {
1570                set n [string trim [string range [readexp "${key} NEXC"] 0 4]]
1571                set exlist {}
1572                for {set i 1} {$i <= $n} {incr i} {
1573                    set line [readexp [format "${key}EXC%3d" $i]]
1574                    lappend exlist [list \
1575                            [string trim [string range $line  0  9]] \
1576                            [string trim [string range $line 10 19]]]
1577                }
1578                return $exlist
1579            }
1580            excl-set {
1581                set n [llength $value]
1582                if ![validint n 5] {return 0}
1583                setexp "${key} NEXC" $n 1 5
1584                set i 0
1585                foreach p $value {
1586                    incr i
1587                    foreach {r1 r2} $p {}
1588                    validreal r1 10 3
1589                    validreal r2 10 3
1590                    set k [format "${key}EXC%3d" $i]
1591                    if {![existsexp $k]} {
1592                        makeexprec $k
1593                    }
1594                    setexp $k ${r1}${r2} 1 20
1595                }
1596                # set the powpref warning (2 = required)
1597                catch {
1598                    global expgui
1599                    set expgui(needpowpref) 2
1600                    set msg "Excluded regions" 
1601                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1602                        append expgui(needpowpref_why) "\t$msg were changed\n"
1603                    }
1604                }
1605            }
1606            file-get {
1607                return [string trim [readexp "${key}  HFIL"] ]
1608            }
1609            file-set {
1610                setexp "${key}  HFIL" $value 3 65
1611            }
1612            bank-get {
1613                return [string trim [string range [readexp "${key} BANK"] 0 4]]
1614            }
1615            dmin-get {
1616                return [string trim [string range [readexp "${key} NREF"] 5 14]]
1617            }
1618            dmin-set {
1619                if ![validreal value 10 4] {return 0}
1620                setexp "${key} NREF" $value 6 10
1621                # set the powpref warning (2 = required)
1622                catch {
1623                    global expgui
1624                    set expgui(needpowpref) 2
1625                    set msg "Dmin (reflection range)" 
1626                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1627                        append expgui(needpowpref_why) "\t$msg was changed\n"
1628                    }
1629                }
1630            }
1631            use-get {
1632                set k [expr {($hist+11)/12}]
1633                set line [readexp " EXPR  HTYP$k"]
1634                set j [expr {((($hist-1) % 12)+1)*5}]
1635                if {[string range $line $j $j] == "*"} {return 0}
1636                return 1
1637            }
1638            use-set {
1639                set k [expr {($hist+11)/12}]
1640                set line [readexp " EXPR  HTYP$k"]
1641                set j [expr {((($hist-1) % 12)+1)*5+1}]
1642                if {$value} {
1643                    setexp " EXPR  HTYP$k" " " $j 1
1644                } else {
1645                    setexp " EXPR  HTYP$k" "*" $j 1
1646                }
1647                # set the powpref warning (2 = required)
1648                catch {
1649                    global expgui
1650                    set expgui(needpowpref) 2
1651                    set msg "Histogram use flags" 
1652                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1653                        append expgui(needpowpref_why) "\t$msg were changed\n"
1654                    }
1655                }
1656            }
1657            dstart-get {
1658                return [string trim [string range [readexp "${key} DUMMY"] 20 29]]
1659            }
1660            dstart-set {
1661                if ![validreal value 10 3] {return 0}
1662                setexp "${key} DUMMY" $value 21 10
1663                # set the powpref warning (1 = suggested)
1664                catch {
1665                    global expgui
1666                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1667                    set msg "Dummy histogram parameters" 
1668                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1669                        append expgui(needpowpref_why) "\t$msg were changed\n"
1670                    }
1671                }
1672            }
1673            dstep-get {
1674                return [string trim [string range [readexp "${key} DUMMY"] 30 39]]
1675            }
1676            dstep-set {
1677                if ![validreal value 10 3] {return 0}
1678                setexp "${key} DUMMY" $value 31 10
1679                catch {
1680                    global expgui
1681                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1682                    set msg "Dummy histogram parameters" 
1683                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1684                        append expgui(needpowpref_why) "\t$msg were changed\n"
1685                    }
1686                }
1687            }
1688            dpoints-get {
1689                return [string trim [string range [readexp "${key} DUMMY"] 0 9]]
1690            }
1691            dpoints-set {
1692                if ![validint value 10] {return 0}
1693                setexp "${key} DUMMY" $value 1 10
1694                catch {
1695                    global expgui
1696                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1697                    set msg "Dummy histogram parameters" 
1698                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1699                        append expgui(needpowpref_why) "\t$msg were changed\n"
1700                    }
1701                }
1702            }
1703            dtype-get {
1704                return [string trim [string range [readexp "${key} DUMMY"] 10 19]]
1705            }
1706            abscor1-get {
1707                return [string trim [string range [readexp "${key}ABSCOR"] 0 14]]
1708            }
1709            abscor1-set {
1710                if ![validreal value 15 7] {return 0}
1711                setexp "${key}ABSCOR" $value 1 15
1712            }
1713            abscor2-get {
1714                return [string trim [string range [readexp "${key}ABSCOR"] 15 29]]
1715            }
1716            abscor2-set {
1717                # can't use validreal as the decimal must be in col 20
1718                if {[catch {
1719                    if {abs($value) < 99.99 && abs($value) > 1.e-4} {
1720                        set tmp [format "%15.10f" $value]
1721                        # make a final check of decimal
1722                        if {[string range $tmp 4 4] != "."} {
1723                            set tmp [format "%15.6E" $value]
1724                        }
1725                    } else {
1726                        set tmp [format "%15.6E" $value]
1727                    }
1728                }]} {return 0}
1729                setexp "${key}ABSCOR" $tmp 16 15
1730            }
1731            abstype-get {
1732                set val [string trim [string range [readexp "${key}ABSCOR"] 40 44]]
1733                if {$val == ""} {set val 0}
1734                return $val
1735            }
1736            abstype-set {
1737                if ![validint value 5] {return 0}
1738                setexp "${key}ABSCOR" $value 41 5
1739            }
1740            absdamp-get {
1741                set val [string range [readexp "${key}ABSCOR"] 39 39]
1742                if {$val == " "} {return 0}
1743                return $val
1744            }
1745            absdamp-set {
1746                if ![validint value 5] {return 0}
1747                setexp "${key}ABSCOR" $value 36 5
1748            }
1749            absref-get {
1750                if {[string toupper \
1751                        [string range [readexp "${key}ABSCOR"] 34 34]] == "Y"} {
1752                    return 1
1753                }
1754                return 0
1755            }
1756            absref-set {
1757                if $value {
1758                    setexp "${key}ABSCOR" "    Y" 31 5
1759                } else {
1760                    setexp "${key}ABSCOR" "    N" 31 5
1761                }
1762            }
1763            ITYP-get {
1764                return [string trim [readexp "${key}I ITYP"]]
1765            }
1766            default {
1767                set msg "Unsupported histinfo access: parm=$parm action=$action"
1768                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
1769            }
1770        }
1771    }
1772    return 1
1773}
1774
1775# read the information that differs by both histogram and phase (profile & phase fraction)
1776# use: hapinfo hist phase parm action value
1777
1778#     frac -- phase fraction (*)
1779#     frref/frdamp -- refinement flag/damping value for the phase fraction (*)
1780#     proftype -- profile function number (*)
1781#     profterms -- number of profile terms (*)
1782#     pdamp -- damping value for the profile (*)
1783#     pcut -- cutoff value for the profile (*)
1784#     pterm$n -- profile term #n (*)
1785#     pref$n -- refinement flag value for profile term #n (*)
1786#     extmeth -- Fobs extraction method (*)
1787#     POnaxis -- number of defined M-D preferred axes
1788proc hapinfo {histlist phaselist parm "action get" "value {}"} {
1789    foreach phase $phaselist hist $histlist {
1790        if {$phase == ""} {set phase [lindex $phaselist end]}
1791        if {$hist == ""} {set hist [lindex $histlist end]}
1792        if {$hist < 10} {
1793            set hist " $hist"
1794        }
1795        set key "HAP${phase}${hist}"
1796        switch -glob ${parm}-$action {
1797            extmeth-get {
1798                set i1 [expr {($phase - 1)*5}]
1799                set i2 [expr {$i1 + 4}]
1800                return [string trim [string range [readexp "HST $hist EPHAS"] $i1 $i2]]
1801            }
1802            extmeth-set {
1803                set i1 [expr {($phase - 1)*5 + 1}]
1804                if ![validint value 5] {return 0}
1805                setexp "HST $hist EPHAS" $value $i1 5
1806            }
1807            frac-get {
1808                return [string trim [string range [readexp ${key}PHSFR] 0 14]]
1809            }
1810            frac-set {
1811                if ![validreal value 15 6] {return 0}
1812                setexp ${key}PHSFR $value 1 15
1813            }
1814            frref-get {
1815                if {[string toupper [string range [readexp ${key}PHSFR] 19 19]] == "Y"} {
1816                    return 1
1817                }
1818                return 0
1819            }
1820            frref-set {
1821                if $value {
1822                    setexp ${key}PHSFR "Y" 20 1
1823                } else {
1824                    setexp ${key}PHSFR "N" 20 1
1825                }           
1826            }
1827            frdamp-get {
1828                set val [string range [readexp ${key}PHSFR] 24 24]
1829                if {$val == " "} {return 0}
1830                return $val
1831            }
1832            frdamp-set {
1833                setexp ${key}PHSFR $value 25 1
1834            }
1835            proftype-get {
1836                set val [string range [readexp "${key}PRCF "] 0 4]
1837                if {$val == " "} {return 0}
1838                return $val
1839            }
1840            proftype-set {
1841                if ![validint value 5] {return 0}
1842                setexp "${key}PRCF " $value 1 5
1843                # set the powpref warning (1 = suggested)
1844                catch {
1845                    global expgui
1846                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1847                    set msg "Profile parameters" 
1848                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1849                        append expgui(needpowpref_why) "\t$msg were changed\n"
1850                    }
1851                }
1852            }
1853            profterms-get {
1854                set val [string range [readexp "${key}PRCF "] 5 9]
1855                if {$val == " "} {return 0}
1856                return $val
1857            }
1858            profterms-set {
1859                if ![validint value 5] {return 0}
1860                setexp "${key}PRCF " $value 6 5
1861                # now check that all needed entries exist
1862                set lines [expr {1 + ($value - 1) / 4}]
1863                for {set i 1} {$i <= $lines} {incr i} {
1864                    makeexprec "${key}PRCF $i"
1865                }
1866                # set the powpref warning (1 = suggested)
1867                catch {
1868                    global expgui
1869                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1870                    set msg "Profile parameters" 
1871                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1872                        append expgui(needpowpref_why) "\t$msg were changed\n"
1873                    }
1874                }
1875            }
1876            pcut-get {
1877                return [string trim [string range [readexp "${key}PRCF "] 10 19]]
1878            }
1879            pcut-set {
1880                if ![validreal value 10 5] {return 0}
1881                setexp "${key}PRCF " $value 11 10
1882                # set the powpref warning (1 = suggested)
1883                catch {
1884                    global expgui
1885                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1886                    set msg "Profile parameters" 
1887                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1888                        append expgui(needpowpref_why) "\t$msg were changed\n"
1889                    }
1890                }
1891            }
1892            pdamp-get {
1893                set val [string range [readexp "${key}PRCF "] 24 24]
1894                if {$val == " "} {return 0}
1895                return $val
1896            }
1897            pdamp-set {
1898                setexp "${key}PRCF   " $value 25 1
1899            }
1900            pterm*-get {
1901                regsub pterm $parm {} num
1902                set f1 [expr {15*(($num - 1) % 4)}]
1903                set f2 [expr {15*(1 + ($num - 1) % 4)-1}]
1904                set line  [expr {1 + ($num - 1) / 4}]
1905                return [string trim [string range [readexp "${key}PRCF $line"] $f1 $f2] ]
1906            }
1907            pterm*-set {
1908                if ![validreal value 15 6] {return 0}
1909                regsub pterm $parm {} num
1910                set f1 [expr {1+ 15*(($num - 1) % 4)}]
1911                set line  [expr {1 + ($num - 1) / 4}]
1912                setexp "${key}PRCF $line" $value $f1 15
1913                # set the powpref warning (1 = suggested)
1914                catch {
1915                    global expgui
1916                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1917                    set msg "Profile parameters" 
1918                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1919                        append expgui(needpowpref_why) "\t$msg were changed\n"
1920                    }
1921                }
1922            }
1923            pref*-get {
1924                regsub pref $parm {} num
1925                set f [expr {24+$num}]
1926                if {[string toupper [string range [readexp "${key}PRCF  "] $f $f]] == "Y"} {
1927                    return 1
1928                }
1929                return 0
1930            }
1931            pref*-set {
1932                regsub pref $parm {} num
1933                set f [expr {25+$num}]
1934                if $value {
1935                    setexp ${key}PRCF "Y" $f 1
1936                } else {
1937                    setexp ${key}PRCF "N" $f 1
1938                }           
1939            }
1940            POnaxis-get {
1941                set val [string trim \
1942                        [string range [readexp "${key}NAXIS"] 0 4]]
1943                if {$val == ""} {return 0}
1944                return $val
1945            }
1946            POnaxis-set {
1947                if ![validint value 5] {return 0}
1948                # there should be a NAXIS record, but if not make one
1949                if {![existsexp "${key}NAXIS"]} {
1950                    makeexprec "${key}NAXIS"
1951                }
1952                setexp "${key}NAXIS  " $value 1 5
1953            }
1954            default {
1955                set msg "Unsupported hapinfo access: parm=$parm action=$action"
1956                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
1957            }
1958        }
1959    }
1960    return 1
1961}
1962
1963#  get a logical constraint
1964#
1965#  type action
1966#  -----------
1967#  atom get  number        returns a list of constraints.
1968#   "   set  number value  replaces a list of constraints
1969#                          (value is a list of constraints)
1970#   "   add  number value  inserts a new list of constraints
1971#                          (number is ignored)
1972#   "   delete number      deletes a set of constraint entries
1973# Each item in the list of constraints is composed of 4 items:
1974#              phase, atom, variable, multiplier
1975# If variable=UISO atom can be ALL, otherwise atom is a number
1976# legal variable names: FRAC, X, Y, Z, UISO, U11, U22, U33, U12, U23, U13,
1977#                       MX, MY, MZ
1978#
1979#  type action
1980#  -----------
1981#  profileXX get number         returns a list of constraints for term XX=1-36
1982#                               use number=0 to get # of defined
1983#                                  constraints for term XX
1984#   "        set number value   replaces a list of constraints
1985#                               (value is a list of constraints)
1986#   "        add number value   inserts a new list of constraints
1987#                               (number is ignored)
1988#   "        delete number      deletes a set of constraint entries
1989# Each item in the list of constraints is composed of 3 items:
1990#              phase-list, histogram-list, multiplier
1991# Note that phase-list and/or histogram-list can be ALL
1992
1993proc constrinfo {type action number "value {}"} {
1994    global expmap
1995    if {[lindex $expmap(phasetype) 0] == 4} {
1996        set mm 1
1997    } else {
1998        set mm 0
1999    }
2000    switch -glob ${type}-$action {
2001        atom-get {
2002            # does this constraint exist?
2003            set key [format "LNCN%4d%4d" $number 1]
2004            if {![existsexp $key]} {return -1}
2005            set clist {}
2006            for {set i 1} {$i < 999} {incr i} {
2007                set key [format "LNCN%4d%4d" $number $i]
2008                if {![existsexp $key]} break
2009                set line [readexp $key]
2010                set j1 2
2011                set j2 17
2012                set seg [string range $line $j1 $j2]
2013                while {[string trim $seg] != ""} {
2014                    set p [string range $seg 0 0]
2015                    if {$p == 1 && $mm} {
2016                        set atom [string trim [string range $seg 1 4]]
2017                        set var [string trim [string range $seg 5 7]]
2018                        if {$atom == "ALL"} {
2019                            set var UIS
2020                        } else {
2021                            scan $atom %x atom
2022                        }
2023                        lappend clist [list $p $atom $var \
2024                                [string trim [string range $seg 8 end]]]
2025                    } else {
2026                        lappend clist [list $p \
2027                                [string trim [string range $seg 1 3]] \
2028                                [string trim [string range $seg 4 7]] \
2029                                [string trim [string range $seg 8 end]]]
2030                    }
2031                    incr j1 16
2032                    incr j2 16
2033                    set seg [string range $line $j1 $j2]
2034                }
2035            }
2036            return $clist
2037        }
2038        atom-set {
2039            # delete records for current constraint
2040            for {set i 1} {$i < 999} {incr i} {
2041                set key [format "LNCN%4d%4d" $number $i]
2042                if {![existsexp $key]} break
2043                delexp $key
2044            }
2045            set line {}
2046            set i 1
2047            foreach tuple $value {
2048                set p [lindex $tuple 0]
2049                if {$p == 1 && $mm && \
2050                        [string toupper [lindex $tuple 1]] == "ALL"} {
2051                    set seg [format %1dALL UIS%8.4f \
2052                            [lindex $tuple 0] \
2053                            [lindex $tuple 3]]
2054                } elseif {$p == 1 && $mm} {
2055                    set seg [eval format %1d%.4X%-3s%8.4f $tuple]
2056                } elseif {[string toupper [lindex $tuple 1]] == "ALL"} {
2057                    set seg [format %1dALL%-4s%8.4f \
2058                            [lindex $tuple 0] \
2059                            [lindex $tuple 2] \
2060                            [lindex $tuple 3]]
2061                } else {
2062                    set seg [eval format %1d%3d%-4s%8.4f $tuple]
2063                }
2064                append line $seg
2065                if {[string length $line] > 50} {
2066                    set key  [format "LNCN%4d%4d" $number $i]
2067                    makeexprec $key
2068                    setexp $key $line 3 68
2069                    set line {}
2070                    incr i
2071                }
2072            }
2073            if {$line != ""} {
2074                set key  [format "LNCN%4d%4d" $number $i]
2075                makeexprec $key
2076                setexp $key $line 3 68
2077            }
2078            return
2079        }
2080        atom-add {
2081            # loop over defined constraints
2082            for {set j 1} {$j < 9999} {incr j} {
2083                set key [format "LNCN%4d%4d" $j 1]
2084                if {![existsexp $key]} break
2085            }
2086            set number $j
2087            # save the constraint
2088            set line {}
2089            set i 1
2090            foreach tuple $value {
2091                set p [lindex $tuple 0]
2092                if {$p == 1 && $mm && \
2093                        [string toupper [lindex $tuple 1]] == "ALL"} {
2094                    set seg [format %1dALL UIS%8.4f \
2095                            [lindex $tuple 0] \
2096                            [lindex $tuple 3]]
2097                } elseif {$p == 1 && $mm} {
2098                    set seg [eval format %1d%.4X%-3s%8.4f $tuple]
2099                } elseif {[string toupper [lindex $tuple 1]] == "ALL"} {
2100                    set seg [format %1dALL%-4s%8.4f \
2101                            [lindex $tuple 0] \
2102                            [lindex $tuple 2] \
2103                            [lindex $tuple 3]]
2104                } else {
2105                    set seg [eval format %1d%3d%-4s%8.4f $tuple]
2106                }
2107                append line $seg
2108                if {[string length $line] > 50} {
2109                    set key  [format "LNCN%4d%4d" $number $i]
2110                    makeexprec $key
2111                    setexp $key $line 3 68
2112                    set line {}
2113                    incr i
2114                }
2115            }
2116            if {$line != ""} {
2117                set key  [format "LNCN%4d%4d" $number $i]
2118                makeexprec $key
2119                setexp $key $line 3 68
2120            }
2121            return
2122        }
2123        atom-delete {
2124            for {set j $number} {$j < 9999} {incr j} {
2125                # delete records for current constraint
2126                for {set i 1} {$i < 999} {incr i} {
2127                    set key [format "LNCN%4d%4d" $j $i]
2128                    if {![existsexp $key]} break
2129                    delexp $key
2130                }
2131                # now copy records, from the next entry, if any
2132                set j1 $j
2133                incr j1
2134                set key1 [format "LNCN%4d%4d" $j1 1]
2135                # if there is no record, there is nothing to copy -- done
2136                if {![existsexp $key1]} return
2137                for {set i 1} {$i < 999} {incr i} {
2138                    set key1 [format "LNCN%4d%4d" $j1 $i]
2139                    if {![existsexp $key1]} break
2140                    set key  [format "LNCN%4d%4d" $j  $i]
2141                    makeexprec $key
2142                    setexp $key [readexp $key1] 1 68
2143                }
2144            }
2145        }
2146        profile*-delete {
2147            regsub profile $type {} term
2148            if {$term < 10} {
2149                set term " $term"
2150            }
2151            set key "LEQV PF$term   "
2152            # return nothing if no term exists
2153            if {![existsexp $key]} {return 0}
2154
2155            # number of constraint terms
2156            set nterms [string trim [string range [readexp ${key}] 0 4] ]
2157            # don't delete a non-existing entry
2158            if {$number > $nterms} {return 0}
2159            set val [expr {$nterms - 1}]
2160            validint val 5
2161            setexp $key $val 1 5
2162            for {set i1 $number} {$i1 < $nterms} {incr i1} {
2163                set i2 [expr {1 + $i1}]
2164                # move the contents of constraint #i2 -> i1
2165                if {$i1 > 9} {
2166                    set k1 [expr {($i1+1)/10}]
2167                    set l1 $i1
2168                } else {
2169                    set k1 " "
2170                    set l1 " $i1"
2171                }
2172                set key1 "LEQV PF$term  $k1"
2173                # number of constraint lines for #i1
2174                set n1 [string trim [string range [readexp ${key1}] \
2175                        [expr {($i1%10)*5}] [expr {4+(($i1%10)*5)}]] ]
2176                if {$i2 > 9} {
2177                    set k2 [expr {($i2+1)/10}]
2178                    set l2 $i2
2179                } else {
2180                    set k2 " "
2181                    set l2 " $i2"
2182                }
2183                set key2 "LEQV PF$term  $k2"
2184                # number of constraint lines for #i2
2185                set n2 [string trim [string range [readexp ${key2}] \
2186                        [expr {($i2%10)*5}] [expr {4+(($i2%10)*5)}]] ]
2187                set val $n2
2188                validint val 5
2189                # move the # of terms
2190                setexp $key1 $val [expr {1+(($i1%10)*5)}] 5
2191                # move the terms
2192                for {set j 1} {$j <= $n2} {incr j 1} {
2193                    set key "LEQV PF${term}${l1}$j"
2194                    makeexprec $key
2195                    setexp $key [readexp "LEQV PF${term}${l2}$j"] 1 68
2196                }
2197                # delete any remaining lines
2198                for {set j [expr {$n2+1}]} {$j <= $n1} {incr j 1} {
2199                    delexp "LEQV PF${term}${l1}$j"
2200                }
2201            }
2202
2203            # clear the last term
2204            if {$nterms > 9} {
2205                set i [expr {($nterms+1)/10}]
2206            } else {
2207                set i " "
2208            }
2209            set key "LEQV PF$term  $i"
2210            set cb [expr {($nterms%10)*5}]
2211            set ce [expr {4+(($nterms%10)*5)}]
2212            set n2 [string trim [string range [readexp ${key}] $cb $ce] ]
2213            incr cb
2214            setexp $key "     " $cb 5
2215            # delete any remaining lines
2216            for {set j 1} {$j <= $n2} {incr j 1} {
2217                delexp "LEQV PF${term}${nterms}$j"
2218            }
2219        }
2220        profile*-set {
2221            regsub profile $type {} term
2222            if {$term < 10} {
2223                set term " $term"
2224            }
2225            set key "LEQV PF$term   "
2226            # get number of constraint terms
2227            set nterms [string trim [string range [readexp ${key}] 0 4] ]
2228            # don't change a non-existing entry
2229            if {$number > $nterms} {return 0}
2230            if {$number > 9} {
2231                set k1 [expr {($number+1)/10}]
2232                set l1 $number
2233            } else {
2234                set k1 " "
2235                set l1 " $number"
2236            }
2237            set key1 "LEQV PF$term  $k1"
2238            # old number of constraint lines
2239            set n1 [string trim [string range [readexp ${key1}] \
2240                    [expr {($number%10)*5}] [expr {4+(($number%10)*5)}]] ]
2241            # number of new constraints
2242            set j2 [llength $value]
2243            # number of new constraint lines
2244            set val [set n2 [expr {($j2 + 2)/3}]]
2245            # store the new # of lines
2246            validint val 5
2247            setexp $key1 $val [expr {1+(($number%10)*5)}] 5
2248
2249            # loop over the # of lines in the old or new, whichever is greater
2250            set v0 0
2251            for {set j 1} {$j <= [expr {($n1 > $n2) ? $n1 : $n2}]} {incr j 1} {
2252                set key "LEQV PF${term}${l1}$j"
2253                # were there more lines in the old?
2254                if {$j > $n2} {
2255                    # this line is not needed
2256                    if {$j % 3 == 1} {
2257                        delexp %key
2258                    }
2259                    continue
2260                }
2261                # are we adding new lines?
2262                if {$j > $n1} {
2263                    makeexprec $key
2264                }
2265                # add the three constraints to the line
2266                foreach s {3 23 43} \
2267                        item [lrange $value $v0 [expr {2+$v0}]] {
2268                    if {$item != ""} {
2269                        set val [format %-10s%9.3f \
2270                                [lindex $item 0],[lindex $item 1] \
2271                                [lindex $item 2]]
2272                        setexp $key $val $s 19
2273                    } else {
2274                        setexp $key " " $s 19
2275                    }
2276                }
2277                incr v0 3
2278            }
2279        }
2280        profile*-add {
2281            regsub profile $type {} term
2282            if {$term < 10} {
2283                set term " $term"
2284            }
2285            set key "LEQV PF$term   "
2286            if {![existsexp $key]} {makeexprec $key}
2287            set nterms [string trim [string range [readexp ${key}] 0 4] ]
2288            if {$nterms == ""} {
2289                set nterms 1
2290            } elseif {$nterms >= 99} {
2291                return 0
2292            } else {
2293                incr nterms
2294            }
2295            # store the new # of constraints
2296            set val $nterms
2297            validint val 5
2298            setexp $key $val 1 5
2299
2300            if {$nterms > 9} {
2301                set k1 [expr {($nterms+1)/10}]
2302                set l1 $nterms
2303            } else {
2304                set k1 " "
2305                set l1 " $nterms"
2306            }
2307            set key1 "LEQV PF$term  $k1"
2308
2309            # number of new constraints
2310            set j2 [llength $value]
2311            # number of new constraint lines
2312            set val [set n2 [expr {($j2 + 2)/3}]]
2313            # store the new # of lines
2314            validint val 5
2315            setexp $key1 $val [expr {1+(($nterms%10)*5)}] 5
2316
2317            # loop over the # of lines to be added
2318            set v0 0
2319            for {set j 1} {$j <= $n2} {incr j 1} {
2320                set key "LEQV PF${term}${l1}$j"
2321                makeexprec $key
2322                # add the three constraints to the line
2323                foreach s {3 23 43} \
2324                        item [lrange $value $v0 [expr {2+$v0}]] {
2325                    if {$item != ""} {
2326                        set val [format %-10s%9.3f \
2327                                [lindex $item 0],[lindex $item 1] \
2328                                [lindex $item 2]]
2329                        setexp $key $val $s 19
2330                    } else {
2331                        setexp $key " " $s 19
2332                    }
2333                }
2334                incr v0 3
2335            }
2336        }
2337        profile*-get {
2338            regsub profile $type {} term
2339            if {$term < 10} {
2340                set term " $term"
2341            }
2342            if {$number > 9} {
2343                set i [expr {($number+1)/10}]
2344            } else {
2345                set i " "
2346            }
2347            set key "LEQV PF$term  $i"
2348            # return nothing if no term exists
2349            if {![existsexp $key]} {return 0}
2350            # number of constraint lines
2351           
2352            set numline [string trim [string range [readexp ${key}] \
2353                    [expr {($number%10)*5}] [expr {4+(($number%10)*5)}]] ]
2354            if {$number == 0} {return $numline}
2355            set clist {}
2356            if {$number < 10} {
2357                set number " $number"
2358            }
2359            for {set i 1} {$i <= $numline} {incr i} {
2360                set key "LEQV PF${term}${number}$i"
2361                set line [readexp ${key}]
2362                foreach s {1 21 41} e {20 40 60} {
2363                    set seg [string range $line $s $e]
2364                    if {[string trim $seg] == ""} continue
2365                    # parse the string segment
2366                    set parse [regexp { *([0-9AL]+),([0-9AL]+) +([0-9.]+)} \
2367                            $seg junk phase hist mult]
2368                    # was parse successful
2369                    if {!$parse} {continue}
2370                    lappend clist [list $phase $hist $mult]
2371                }
2372            }
2373            return $clist
2374        }
2375        default {
2376            set msg "Unsupported constrinfo access: type=$type action=$action"
2377            tk_dialog .badexp "Error in readexp access" $msg error 0 OK
2378        }
2379
2380    }
2381}
2382
2383# read the default profile information for a histogram
2384# use: profdefinfo hist set# parm action
2385
2386#     proftype -- profile function number
2387#     profterms -- number of profile terms
2388#     pdamp -- damping value for the profile (*)
2389#     pcut -- cutoff value for the profile (*)
2390#     pterm$n -- profile term #n
2391#     pref$n -- refinement flag value for profile term #n (*)
2392
2393proc profdefinfo {hist set parm "action get"} {
2394    global expgui
2395    if {$hist < 10} {
2396        set key "HST  $hist"
2397    } else {
2398        set key "HST $hist"
2399    }
2400    switch -glob ${parm}-$action {
2401        proftype-get {
2402            set val [string range [readexp "${key}PRCF$set"] 0 4]
2403            if {$val == " "} {return 0}
2404            return $val
2405        }
2406        profterms-get {
2407            set val [string range [readexp "${key}PRCF$set"] 5 9]
2408            if {$val == " "} {return 0}
2409            return $val
2410        }
2411        pcut-get {
2412            return [string trim [string range [readexp "${key}PRCF$set"] 10 19]]
2413        }
2414        pdamp-get {
2415                set val [string range [readexp "${key}PRCF$set"] 24 24]
2416            if {$val == " "} {return 0}
2417            return $val
2418        }
2419        pterm*-get {
2420            regsub pterm $parm {} num
2421            set f1 [expr {15*(($num - 1) % 4)}]
2422            set f2 [expr {15*(1 + ($num - 1) % 4)-1}]
2423            set line  [expr {1 + ($num - 1) / 4}]
2424            return [string trim [string range [\
2425                        readexp "${key}PRCF${set}$line"] $f1 $f2] ]
2426        }
2427        pref*-get {
2428            regsub pref $parm {} num
2429            set f [expr {24+$num}]
2430            if {[string toupper [string range [readexp "${key}PRCF$set"] $f $f]] == "Y"} {
2431                return 1
2432            }
2433            return 0
2434        }
2435        default {
2436            set msg "Unsupported profdefinfo access: parm=$parm action=$action"
2437            tk_dialog .badexp "Code Error" $msg error 0 Exit
2438        }
2439    }
2440}
2441
2442# get March-Dollase preferred orientation information
2443# use MDprefinfo hist phase axis-number parm action value
2444#    ratio    -- ratio of xtallites in PO direction vs random (>1 for more)
2445#    fraction -- fraction in this direction, when more than one axis is used
2446#    h k & l  -- indices of P.O. axis
2447#    ratioref -- flag to vary ratio
2448#    fracref  -- flag to vary fraction
2449#    damp     -- damping value
2450#    type     -- model type (0 = P.O. _|_ to beam, 1 = || to beam)
2451#    new      -- creates a new record with default values (set only)
2452proc MDprefinfo {histlist phaselist axislist parm "action get" "value {}"} {
2453    foreach phase $phaselist hist $histlist axis $axislist {
2454        if {$phase == ""} {set phase [lindex $phaselist end]}
2455        if {$hist == ""} {set hist [lindex $histlist end]}
2456        if {$axis == ""} {set axis [lindex $axislist end]}
2457        if {$hist < 10} {
2458            set hist " $hist"
2459        }
2460        if {$axis > 9} {
2461            set axis "0"
2462        }
2463        set key "HAP${phase}${hist}PREFO${axis}"
2464        switch -glob ${parm}-$action {
2465            ratio-get {
2466                return [string trim [string range [readexp $key] 0 9]]
2467            }
2468            ratio-set {
2469                if ![validreal value 10 6] {return 0}
2470                setexp $key $value 1 10
2471            }
2472            fraction-get {
2473                return [string trim [string range [readexp $key] 10 19]]
2474            }
2475            fraction-set {
2476                if ![validreal value 10 6] {return 0}
2477                setexp $key $value 11 10
2478            }
2479            h-get {
2480                set h [string trim [string range [readexp $key] 20 29]]
2481                # why not allow negative h values?
2482                #               if {$h < 1} {return 0}
2483                return $h
2484            }
2485            h-set {
2486                if ![validreal value 10 2] {return 0}
2487                setexp $key $value 21 10
2488            }
2489            k-get {
2490                set k [string trim [string range [readexp $key] 30 39]]
2491                #               if {$k < 1} {return 0}
2492                return $k
2493            }
2494            k-set {
2495                if ![validreal value 10 2] {return 0}
2496                setexp $key $value 31 10
2497            }
2498            l-get {
2499                set l [string trim [string range [readexp $key] 40 49]]
2500                #if {$l < 1} {return 0}
2501                return $l
2502            }
2503            l-set {
2504                if ![validreal value 10 2] {return 0}
2505                setexp $key $value 41 10
2506            }
2507            ratioref-get {
2508                if {[string toupper \
2509                        [string range [readexp $key] 53 53]] == "Y"} {
2510                    return 1
2511                }
2512                return 0
2513            }
2514            ratioref-set {
2515                if $value {
2516                    setexp $key "Y" 54 1
2517                } else {
2518                    setexp $key "N" 54 1
2519                }
2520            }
2521            fracref-get {
2522                if {[string toupper \
2523                        [string range [readexp $key] 54 54]] == "Y"} {
2524                    return 1
2525                }
2526                return 0
2527            }
2528            fracref-set {
2529                if $value {
2530                    setexp $key "Y" 55 1
2531                } else {
2532                    setexp $key "N" 55 1
2533              }
2534            }
2535            damp-get {
2536                set val [string trim [string range [readexp $key] 59 59]]
2537                if {$val == " "} {return 0}
2538                return $val
2539            }
2540            damp-set {
2541                setexp $key $value 60 1
2542            }
2543            type-get {
2544                set val [string trim [string range [readexp $key] 64 64]]
2545                if {$val == " "} {return 0}
2546                return $val
2547            }
2548            type-set {
2549                # only valid settings are 0 & 1
2550                if {$value != "0" && $value != "1"} {set value "0"}
2551                setexp $key $value 65 1
2552            }
2553            new-set {
2554                makeexprec $key
2555                setexp $key \
2556                        {  1.000000  1.000000  0.000000  0.000000  1.000000   NN    0    0} \
2557                        1 68
2558            }
2559            default {
2560                set msg "Unsupported MDprefinfo access: parm=$parm action=$action"
2561                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
2562            }
2563
2564        }
2565
2566    }
2567}
2568
2569# write the .EXP file
2570proc expwrite {expfile} {
2571    global exparray
2572    set blankline \
2573     "                                                                        "
2574    set fp [open ${expfile} w]
2575    fconfigure $fp -translation crlf -encoding ascii
2576    set keylist [lsort [array names exparray]]
2577    # reorder the keys so that VERSION comes 1st
2578    set pos [lsearch -exact $keylist {     VERSION}]
2579    set keylist "{     VERSION} [lreplace $keylist $pos $pos]"
2580    foreach key $keylist {
2581        puts $fp [string range \
2582                "$key$exparray($key)$blankline" 0 79]
2583    }
2584    close $fp
2585}
2586
2587# history commands -- delete all but last $keep history records,
2588# renumber if $renumber is true
2589proc DeleteHistory {keep renumber} {
2590    global exparray
2591    foreach y [lrange [lsort -decreasing \
2592            [array names exparray {    HSTRY*}]] $keep end] {
2593        unset exparray($y)
2594    }
2595    if !$renumber return
2596    # renumber
2597    set i 0
2598    foreach y [lsort -increasing \
2599            [array names exparray {    HSTRY*}]] {
2600        set key [format "    HSTRY%3d" [incr i]]
2601        set exparray($key) $exparray($y)
2602        unset exparray($y)
2603    }
2604    # list all history
2605    #    foreach y [lsort -decreasing [array names exparray {    HSTRY*}]] {puts "$y $exparray($y)"}
2606}
2607
2608proc CountHistory {} {
2609    global exparray
2610    return [llength [array names exparray {    HSTRY*}]]
2611}
2612
2613# set the phase flags for histogram $hist to $plist
2614proc SetPhaseFlag {hist plist} {
2615    # make a 2 digit key -- hh
2616    if {$hist < 10} {
2617        set hh " $hist"
2618    } else {
2619        set hh $hist
2620    }
2621    set key "HST $hh NPHAS"
2622    set str {}
2623    foreach iph {1 2 3 4 5 6 7 8 9} {
2624        if {[lsearch $plist $iph] != -1} {
2625            append str {    1}
2626        } else {
2627            append str {    0}     
2628        }
2629    }
2630    setexp $key $str 1 68
2631}
2632
2633# erase atom $atom from phase $phase
2634# update the list of atom types, erasing the record if not needed.
2635proc EraseAtom {atom phase} {
2636    set type [atominfo $phase $atom type]
2637    if {$type == ""} return
2638    if {$atom < 10} {
2639        set key "CRS$phase  AT  $atom"
2640    } elseif {$atom < 100} {
2641        set key "CRS$phase  AT $atom"
2642    } else {
2643        set key "CRS$phase  AT$atom"
2644    }
2645    # delete the records for the atom
2646    global exparray
2647    foreach k [array names exparray ${key}*] {
2648        delexp $k
2649    }
2650    # change the number of atoms in the phase
2651    phaseinfo $phase natoms set [expr {[phaseinfo $phase natoms] -1}]
2652
2653    # now adjust numbers in "EXPR ATYP" records and delete, if needed.
2654    set natypes [readexp " EXPR  NATYP"]
2655    if {$natypes == ""} return
2656    set j 0
2657    for {set i 1} {$i <= $natypes} {incr i} {
2658        incr j
2659        if {$j <10} {
2660            set key " EXPR ATYP $j"
2661        } else {
2662            set key " EXPR ATYP$j"
2663        }
2664        while {![existsexp $key]} {
2665            incr j
2666            if {$j > 99} {
2667                return
2668            } elseif {$j <10} {
2669                set key " EXPR ATYP $j"
2670            } else {
2671                set key " EXPR ATYP$j"
2672            }
2673        }
2674        set keytype [string trim [string range $exparray($key) 2 9]]
2675        if {$type == $keytype} {
2676            # found the type record
2677            set val [string trim [string range $exparray($key) 10 14]]
2678            incr val -1
2679            # if this is the last reference, remove the record,
2680            # otherwise, decrement the counter
2681            if {$val <= 0} {
2682                incr natypes -1 
2683                validint natypes 5
2684                setexp " EXPR  NATYP" $natypes 1 5
2685                delexp $key
2686            } else {
2687                validint val 5
2688                setexp $key $val 11 5
2689            }
2690            return
2691        }
2692    }
2693}
2694
2695# compute equivalent anisotropic temperature factor for Uequiv
2696proc CalcAniso {phase Uequiv} {
2697    foreach var {a b c alpha beta gamma} {
2698        set $var [phaseinfo $phase $var]
2699    }
2700
2701    set G(1,1) [expr {$a * $a}]
2702    set G(2,2) [expr {$b * $b}]
2703    set G(3,3) [expr {$c * $c}]
2704    set G(1,2) [expr {$a * $b * cos($gamma*0.017453292519943)}]
2705    set G(2,1) $G(1,2)
2706    set G(1,3) [expr {$a * $c * cos($beta *0.017453292519943)}]
2707    set G(3,1) $G(1,3)
2708    set G(2,3) [expr {$b * $c * cos($alpha*0.017453292519943)}]
2709    set G(3,2) $G(2,3)
2710
2711    # Calculate the volume**2
2712    set v2 0.0
2713    foreach i {1 2 3} {
2714        set J [expr {($i%3) + 1}]
2715        set K [expr {(($i+1)%3) + 1}]
2716        set v2 [expr {$v2+ $G(1,$i)*($G(2,$J)*$G(3,$K)-$G(3,$J)*$G(2,$K))}]
2717    }
2718    if {$v2 > 0} {
2719        set v [expr {sqrt($v2)}]
2720        foreach i {1 2 3} {
2721            set i1 [expr {($i%3) + 1}]
2722            set i2 [expr {(($i+1)%3) + 1}]
2723            foreach j {1 2 3} {
2724                set j1 [expr {($j%3) + 1}]
2725                set j2 [expr {(($j+1)%3) + 1}]
2726                set C($j,$i) [expr {(\
2727                        $G($i1,$j1) * $G($i2,$j2) - \
2728                        $G($i1,$j2)  * $G($i2,$j1)\
2729                        )/ $v}]
2730            }
2731        }
2732        set A(1,2) [expr {0.5 * ($C(1,2)+$C(2,1)) / sqrt( $C(1,1)* $C(2,2) )}]
2733        set A(1,3) [expr {0.5 * ($C(1,3)+$C(3,1)) / sqrt( $C(1,1)* $C(3,3) )}]
2734        set A(2,3) [expr {0.5 * ($C(2,3)+$C(3,2)) / sqrt( $C(2,2)* $C(3,3) )}]
2735        foreach i {1 1 2} j {2 3 3} {
2736            set A($i,$j) [expr {0.5 * ($C($i,$j) + $C($j,$i)) / \
2737                    sqrt( $C($i,$i)* $C($j,$j) )}]
2738            # clean up roundoff
2739            if {abs($A($i,$j)) < 1e-5} {set A($i,$j) 0.0}
2740        }
2741    } else {
2742        set A(1,2) 0.0
2743        set A(1,3) 0.0
2744        set A(2,3) 0.0
2745    }
2746    return "$Uequiv $Uequiv $Uequiv \
2747            [expr {$Uequiv * $A(1,2)}] \
2748            [expr {$Uequiv * $A(1,3)}] \
2749            [expr {$Uequiv * $A(2,3)}]"
2750}
2751
2752#======================================================================
2753# conversion routines
2754#======================================================================
2755
2756# convert x values to d-space
2757proc tod {xlist hst} {
2758    global expmap
2759    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
2760        return [toftod $xlist $hst]
2761    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
2762        return [tttod $xlist $hst]
2763    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
2764        return [engtod $xlist $hst]
2765    } else {
2766        return {}
2767    }
2768}
2769
2770# convert tof to d-space
2771proc toftod {toflist hst} {
2772    set difc [expr {[histinfo $hst difc]/1000.}]
2773    set difc2 [expr {$difc*$difc}]
2774    set difa [expr {[histinfo $hst difa]/1000.}]
2775    set zero [expr {[histinfo $hst zero]/1000.}]
2776    set ans {}
2777    foreach tof $toflist {
2778        if {$tof == 0.} {
2779            lappend ans 0.
2780        } elseif {$tof == 1000.} {
2781            lappend ans 1000.
2782        } else {
2783            set td [expr {$tof-$zero}]
2784            lappend ans [expr {$td*($difc2+$difa*$td)/ \
2785                    ($difc2*$difc+2.0*$difa*$td)}]
2786        }
2787    }
2788    return $ans
2789}
2790
2791# convert two-theta to d-space
2792proc tttod {twotheta hst} {
2793    set lamo2 [expr {0.5 * [histinfo $hst lam1]}]
2794    set zero [expr [histinfo $hst zero]/100.]
2795    set ans {}
2796    set cnv [expr {acos(0.)/180.}]
2797    foreach tt $twotheta {
2798        if {$tt == 0.} {
2799            lappend ans 99999.
2800        } elseif {$tt == 1000.} {
2801            lappend ans 0.
2802        } else {
2803            lappend ans [expr {$lamo2 / sin($cnv*($tt-$zero))}]
2804        }
2805    }
2806    return $ans
2807}
2808
2809# convert energy (edx-ray) to d-space
2810# (note that this ignores the zero correction)
2811proc engtod {eng hst} {
2812    set lam [histinfo $hst lam1]
2813    set zero [histinfo $hst zero]
2814    set ans {}
2815    set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
2816    foreach e $eng {
2817        if {$e == 0.} {
2818            lappend ans 1000.
2819        } elseif {$e == 1000.} {
2820            lappend ans 0.
2821        } else {
2822            lappend ans [expr {$v/$e}]
2823        }
2824    }
2825    return $ans
2826}
2827
2828# convert x values to Q
2829proc toQ {xlist hst} {
2830    global expmap
2831    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
2832        return [toftoQ $xlist $hst]
2833    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
2834        return [tttoQ $xlist $hst]
2835    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
2836        return [engtoQ $xlist $hst]
2837    } else {
2838        return {}
2839    }
2840}
2841# convert tof to Q
2842proc toftoQ {toflist hst} {
2843    set difc [expr {[histinfo $hst difc]/1000.}]
2844    set difc2 [expr {$difc*$difc}]
2845    set difa [expr {[histinfo $hst difa]/1000.}]
2846    set zero [expr {[histinfo $hst zero]/1000.}]
2847    set 2pi [expr {4.*acos(0.)}]
2848    set ans {}
2849    foreach tof $toflist {
2850        if {$tof == 0.} {
2851            lappend ans 99999.
2852        } elseif {$tof == 1000.} {
2853            lappend ans 0.
2854        } else {
2855            set td [expr {$tof-$zero}]
2856            lappend ans [expr {$2pi * \
2857                    ($difc2*$difc+2.0*$difa*$td)/($td*($difc2+$difa*$td))}]
2858        }
2859    }
2860    return $ans
2861}
2862
2863# convert two-theta to Q
2864proc tttoQ {twotheta hst} {
2865    set lamo2 [expr {0.5 * [histinfo $hst lam1]}]
2866    set zero [expr [histinfo $hst zero]/100.]
2867    set ans {}
2868    set cnv [expr {acos(0.)/180.}]
2869    set 2pi [expr {4.*acos(0.)}]
2870    foreach tt $twotheta {
2871        if {$tt == 0.} {
2872            lappend ans 0.
2873        } elseif {$tt == 1000.} {
2874            lappend ans 1000.
2875        } else {
2876            lappend ans [expr {$2pi * sin($cnv*($tt-$zero)) / $lamo2}]
2877        }
2878    }
2879    return $ans
2880}
2881# convert energy (edx-ray) to Q
2882# (note that this ignores the zero correction)
2883proc engtoQ {eng hst} {
2884    set lam [histinfo $hst lam1]
2885    set zero [histinfo $hst zero]
2886    set ans {}
2887    set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
2888    set 2pi [expr {4.*acos(0.)}]
2889    foreach e $eng {
2890        if {$e == 0.} {
2891            lappend ans 0.
2892        } elseif {$e == 1000.} {
2893            lappend ans 1000.
2894        } else {
2895            lappend ans [expr {$2pi * $e / $v}]
2896        }
2897    }
2898    return $ans
2899}
2900proc sind {angle} {
2901    return [expr {sin($angle*acos(0.)/90.)}]
2902}
2903
2904# convert d-space values to 2theta, TOF or KeV
2905proc fromd {dlist hst} {
2906    global expmap
2907    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
2908        set difc [expr {[histinfo $hst difc]/1000.}]
2909        set difa [expr {[histinfo $hst difa]/1000.}]
2910        set zero [expr {[histinfo $hst zero]/1000.}]
2911        set ans {}
2912        foreach d $dlist {
2913            if {$d == 0.} {
2914                lappend ans 0.
2915            } elseif {$d == 1000.} {
2916                lappend ans 1000.
2917            } else {
2918                lappend ans [expr {$difc*$d + $difa*$d*$d + $zero}]
2919            }
2920        }
2921        return $ans
2922    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
2923        set lamo2 [expr {0.5 * [histinfo $hst lam1]}]
2924        set zero [expr [histinfo $hst zero]/100.]
2925        set ans {}
2926        set cnv [expr {180./acos(0.)}]
2927        foreach d $dlist {
2928            if {$d == 99999.} {
2929                lappend ans 0
2930            } elseif {$d == 0.} {
2931                lappend ans 1000.
2932            } else {
2933                lappend ans [expr {$cnv*asin($lamo2/$d) + $zero}]
2934            }
2935        }
2936        return $ans
2937    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
2938        set lam [histinfo $hst lam1]
2939        set zero [histinfo $hst zero]
2940        set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
2941        set ans {}
2942        foreach d $dlist {
2943            if {$d == 1000.} {
2944                lappend ans 0
2945            } elseif {$d == 0.} {
2946                lappend ans 1000.
2947            } else {
2948                lappend ans [expr {$v/$d}]
2949            }
2950        }
2951        return $ans
2952    } else {
2953        return {}
2954    }
2955}
2956
2957# convert Q values to 2theta, TOF or KeV
2958proc fromQ {Qlist hst} {
2959    global expmap
2960    if {[string range $expmap(htype_$hst) 2 2] == "T"} {
2961        set difc [expr {[histinfo $hst difc]/1000.}]
2962        set difa [expr {[histinfo $hst difa]/1000.}]
2963        set zero [expr {[histinfo $hst zero]/1000.}]
2964        set ans {}
2965        foreach Q $Qlist {
2966            if {$Q == 0.} {
2967                lappend ans 1000.
2968            } elseif {$Q == 99999.} {
2969                lappend ans 1000.
2970            } else {
2971                set d [expr {4.*acos(0.)/$Q}]
2972                lappend ans [expr {$difc*$d + $difa*$d*$d + $zero}]
2973            }
2974        }
2975        return $ans
2976    } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} {
2977        set lamo4pi [expr {[histinfo $hst lam1]/(8.*acos(0.))}]
2978        set zero [expr [histinfo $hst zero]/100.]
2979        set ans {}
2980        set cnv [expr {180./acos(0.)}]
2981        foreach Q $Qlist {
2982            if {$Q == 0.} {
2983                lappend ans 0
2984            } elseif {$Q == 1000.} {
2985                lappend ans 1000.
2986            } else {
2987                lappend ans [expr {$cnv*asin($Q*$lamo4pi) + $zero}]
2988            }
2989        }
2990        return $ans
2991    } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} {
2992        set lam [histinfo $hst lam1]
2993        set zero [histinfo $hst zero]
2994        set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}]
2995        set ans {}
2996        set 2pi [expr {4.*acos(0.)}]
2997        foreach Q $Qlist {
2998            if {$Q == 1000.} {
2999                lappend ans 0
3000            } elseif {$Q == 0.} {
3001                lappend ans 1000.
3002            } else {
3003                lappend ans [expr {$Q * $v/$2pi}]
3004            }
3005        }
3006        return $ans
3007    } else {
3008        return {}
3009    }
3010}
Note: See TracBrowser for help on using the repository browser.