source: branches/sandbox/readexp.tcl @ 1015

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

mapexp: set expgui(mapstat) to trigger trace; move tab disable from sethistlist to StageTabUse?; trigger StageTabUse? when mapexp is used; StageTabUse?: disable tabs w/o phase or hist; simplify upgrade menu; addcmds: select a histogram after adding if none selected; revise SVN update code

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