source: trunk/readexp.tcl @ 490

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

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