source: trunk/readexp.tcl @ 444

Last change on this file since 444 was 429, checked in by toby, 16 years ago

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