source: trunk/readexp.tcl @ 992

Last change on this file since 992 was 992, checked in by toby, 10 years ago

changes for POWGEN: profile #<0; use data limits from prm file for TOF

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