source: trunk/readexp.tcl @ 634

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

# on 2002/07/18 20:52:41, toby did:
fix excluded region read error (in EXCLEDT)

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