source: trunk/readexp.tcl @ 662

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

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