source: trunk/readexp.tcl @ 453

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

# on 2001/09/25 23:35:54, toby did:
Add "D" to all dummy histogram type, save number of histograms
document histinfo x file
support changing dummy ranges, eventually
support histogram flag

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