source: trunk/readexp.tcl @ 843

Last change on this file since 843 was 843, checked in by toby, 13 years ago

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