source: trunk/readexp.tcl @ 997

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

fix awful bug introduced with prev. code rearangement that should not have been checked in; add ability to read archived files from command line; Add routines to read and write soft constrain records

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