source: trunk/readexp.tcl @ 252

Last change on this file since 252 was 252, checked in by toby, 14 years ago

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