source: trunk/readexp.tcl @ 850

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

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