source: trunk/readexp.tcl @ 471

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

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