source: trunk/readexp.tcl @ 129

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

# on 2000/05/16 21:53:20, toby did:
add constrinfo for atom constraint processing
  • Property rcs:author set to toby
  • Property rcs:date set to 2000/05/16 21:53:20
  • Property rcs:lines set to +140 -0
  • Property rcs:rev set to 1.14
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 35.4 KB
Line 
1# $Id: readexp.tcl 129 2009-12-04 23:00:53Z toby $
2# Routines to deal with the .EXP "data structure"
3set expmap(Revision) {$Revision: 129 $ $Date: 2009-12-04 23:00:53 +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    # get the defined phases
75    set line [readexp " EXPR NPHAS"]
76#    if {$line == ""} {
77#       set msg "No EXPR NPHAS entry. This is an invalid .EXP file"
78#       tk_dialog .badexp "Error in EXP" $msg error 0 Exit
79#       destroy .
80#    }
81    set expmap(phaselist) {}
82    set expmap(phasetype) {}
83    # loop over phases
84    foreach iph {1 2 3 4 5 6 7 8 9} {
85        set i5s [expr ($iph - 1)*5]
86        set i5e [expr $i5s + 4]
87        set flag [string trim [string range $line $i5s $i5e]]
88        if {$flag == ""} {set flag 0}
89        if $flag {
90            lappend expmap(phaselist) $iph
91            lappend expmap(phasetype) $flag
92        }
93    }
94    # get the list of defined atoms for each phase
95    foreach iph $expmap(phaselist) {
96        set expmap(atomlist_$iph) {}
97        foreach key [array names exparray "CRS$iph  AT*A"] {
98            regexp { AT *([0-9]+)A} $key a num
99            lappend expmap(atomlist_$iph) $num
100        }
101        # note that sometimes an .EXP file contains more atoms than are actually defined
102        # drop the extra ones
103        set expmap(atomlist_$iph) [lsort -integer $expmap(atomlist_$iph)]
104        set natom [phaseinfo $iph natoms]
105        if {$natom != [llength $expmap(atomlist_$iph)]} {
106            set expmap(atomlist_$iph) [lrange $expmap(atomlist_$iph) 0 [expr $natom-1]]
107        }
108    }
109    # now get the histogram types
110    set nhist [string trim [readexp { EXPR  NHST }]]
111    set n 0
112    set expmap(powderlist) {}
113    for {set i 0} {$i < $nhist} {incr i} {
114        set ihist [expr $i + 1]
115        if {[expr $i % 12] == 0} {
116            incr n
117            set line [readexp " EXPR  HTYP$n"]
118            if {$line == ""} {
119                set msg "No HTYP$n entry for Histogram $ihist. This is an invalid .EXP file"
120                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
121                destroy .
122            }
123            set j 0
124        } else {
125            incr j
126        }
127        set expmap(htype_$ihist) [lindex $line $j]
128        # at least for now, ignore non-powder histograms
129        if {[string range $expmap(htype_$ihist) 0 0] == "P" && \
130                [string range $expmap(htype_$ihist) 3 3] != "*"} {
131            lappend expmap(powderlist) $ihist
132        }
133    }
134
135    # now process powder histograms
136    foreach ihist $expmap(powderlist) {
137        # make a 2 digit key -- hh
138        if {$ihist < 10} {
139            set hh " $ihist"
140        } else {
141            set hh $ihist
142        }
143        set line [readexp "HST $hh NPHAS"]
144        if {$line == ""} {
145            set msg "No NPHAS entry for Histogram $ihist. This is an invalid .EXP file"
146            tk_dialog .badexp "Error in EXP" $msg error 0 Exit
147            destroy .
148        }
149        set expmap(phaselist_$ihist) {}
150        # loop over phases
151        foreach iph {1 2 3 4 5 6 7 8 9} {
152            set i5s [expr ($iph - 1)*5]
153            set i5e [expr $i5s + 4]
154            set flag [string trim [string range $line $i5s $i5e]]
155            if {$flag == ""} {set flag 0}
156            if $flag {lappend expmap(phaselist_$ihist) $iph}
157        }
158    }
159}
160
161# return the value for a ISAM key
162proc readexp {key} {
163    global exparray
164    # truncate long keys & pad short ones
165    set key [string range "$key        " 0 11]
166    if [catch {set val $exparray($key)}] {
167        global expgui
168        if $expgui(debug) {puts "Error accessing record $key"}
169        return ""
170    }
171    return $val
172}
173
174# return the number of records matching ISAM key (may contain wildcards)
175proc existsexp {key} {
176    global exparray
177    # key can contain wild cards so don't pad
178    return [llength [array names exparray  $key]]
179}
180
181
182# replace a section of the exparray with $value
183#   replace $char characters starting at character $start (numbered from 1)
184proc setexp {key value start chars} {
185    global exparray
186    # truncate long keys & pad short ones
187    set key [string range "$key        " 0 11]
188    if [catch {set exparray($key)}] {
189        global expgui
190        if $expgui(debug) {puts "Error accessing record $key"}
191        return ""
192    }
193
194    # pad value to $chars
195    set l0 [expr $chars - 1]
196    set value [string range "$value                                           " 0 $l0]
197
198    if {$start == 1} {
199        set ret {}
200        set l1 $chars
201    } else {
202        set l0 [expr $start - 2]
203        set l1 [expr $start + $chars - 1]
204        set ret [string range $exparray($key) 0 $l0]
205    }
206    append ret $value [string range $exparray($key) $l1 end]
207    set exparray($key) $ret
208}
209
210proc makeexprec {key} {
211    global exparray
212    # truncate long keys & pad short ones
213    set key [string range "$key        " 0 11]
214    if [catch {set exparray($key)}] {
215        # set to 68 blanks
216        set exparray($key) [format %68s " "]
217    }
218}
219
220# delete an exp record
221# returns 1 if OK; 0 if not found
222proc delexp {key} {
223    global exparray
224    # truncate long keys & pad short ones
225    set key [string range "$key        " 0 11]
226    if [catch {unset exparray($key)}] {
227        return 0
228    }
229    return 1
230}
231# test an argument if it is a valid number; reform the number to fit
232proc validreal {val length decimal} {
233    upvar $val value
234    if [catch {expr $value}] {return 0}
235    if [catch {
236        set tmp [format "%${length}.${decimal}f" $value]
237        while {[string length $tmp] > $length} {
238            set tmp [format "%${length}.${decimal}E" $value]
239            incr decimal -1
240        }
241        set value $tmp
242    }] {return 0}
243    return 1
244}
245
246# test an argument if it is a valid integer; reform the number into
247# an integer, if appropriate -- be sure to pass the name of the variable not the value
248proc validint {val length} {
249    upvar $val value
250    # FORTRAN type assumption: blank is 0
251    if {$value == ""} {set value 0}
252    set tmp [expr round($value)]
253    if {$tmp != $value} {return 0}
254    if [catch {
255        set value [format "%${length}d" $tmp]
256    }] {return 0}
257    return 1
258}
259
260# process history information
261#    action == last
262#       returns number and value of last record
263#    action == add
264#
265proc exphistory {action "value 0"} {
266    global exparray
267    if {$action == "last"} {
268        set key [lindex [lsort -decreasing [array names exparray *HSTRY*]] 0]
269        if {$key == ""} {return ""}
270        return [list [string trim [string range $key 9 end]] $exparray($key)]
271    } elseif {$action == "add"} {
272        set key [lindex [lsort -decreasing [array names exparray *HSTRY*]] 0]
273        if {$key == ""} {
274            set index 1
275        } else {
276            set index [string trim [string range $key 9 end]]
277            if {$index != "***"} {
278                if {$index < 999} {incr index}
279                set key [format "    HSTRY%3d" $index]
280                set exparray($key) $value
281            }
282        }
283        set key [format "    HSTRY%3d" $index]
284        set exparray($key) $value
285    }
286}
287# get overall info
288#   parm:
289#     print     -- GENLES print option (*)
290#     cycles    -- number of GENLES cycles (*)
291#     title     -- the overall title (*)
292proc expinfo {parm "action get" "value {}"} {
293    switch ${parm}-$action {
294        title-get {
295            return [string trim [readexp "      DESCR"]]
296        }
297        title-set {
298            setexp "      DESCR" " $value" 2 68
299        }
300
301        cycles-get {
302            return [string trim [cdatget MXCY]]
303        }
304        cycles-set {
305            if ![validint value 1] {return 0}
306            cdatset MXCY [format %4d $value]
307        }
308        print-get {
309            set print [string trim [cdatget PRNT]]
310            if {$print != ""} {return $print}
311            return 0
312        }
313        print-set {
314            if ![validint value 1] {return 0}
315            cdatset PRNT [format %3d $value]
316        }
317        default {
318            set msg "Unsupported expinfo access: parm=$parm action=$action"
319            tk_dialog .badexp "Error in EXP" $msg error 0 Exit
320            destroy .
321        }
322    }
323    return 1
324}
325
326proc cdatget {key} {
327    foreach i {1 2 3 4 5 6 7 8 9} {
328        if {[existsexp "  GNLS CDAT$i"] == 0} break
329        set line [readexp "  GNLS CDAT$i"]
330        if {$line == {}} break
331        foreach i1 {2 10 18 26 34 42 50 58 66} \
332                i2 {9 17 25 33 41 49 57 65 73} {
333            set item [string range $line $i1 $i2]
334            if {[string trim $item] == {}} continue
335            if [regexp "${key}(.*)" $item a b] {return $b}
336        }
337    }
338    return {}
339}
340
341proc cdatset {key value} {
342    # round 1 see if we can find the string
343    foreach i {1 2 3 4 5 6 7 8 9} {
344        set line [readexp "  GNLS CDAT$i"]
345        if {$line == {}} break
346        foreach i1 {2 10 18 26 34 42 50 58 66} \
347                i2 {9 17 25 33 41 49 57 65 73} {
348            set item [string range $line $i1 $i2]
349            if {[string trim $item] == {}} continue
350            if [regexp "${key}(.*)" $item a b] {
351                # found it now replace it
352                incr i1
353                setexp "  GNLS CDAT$i" "${key}${value}" $i1 8
354                return
355            }
356        }
357    }
358    # not found, take the 1st blank space, creating a card if needed
359    foreach i {1 2 3 4 5 6 7 8 9} {
360        set line [readexp "  GNLS CDAT$i"]
361        if {$line == {}} {makeexprec "  GNLS CDAT$i"}
362        foreach i1 {2 10 18 26 34 42 50 58 66} \
363                i2 {9 17 25 33 41 49 57 65 73} {
364            set item [string range $line $i1 $i2]
365            if {[string trim $item] == {}} {
366                # found a blank space: now replace it
367                incr i1
368                setexp "  GNLS CDAT$i" "${key}${value}" $i1 8
369                return
370            }
371        }
372    }
373    return {}
374}
375
376# get phase information: phaseinfo phase parm action value
377#   phase: 1 to 9 (as defined)
378#   parm:
379#     name -- phase name
380#     natoms -- number of atoms
381#     a b c alpha beta gamma -- cell parameters (*)
382#     cellref -- refinement flag for the unit cell(*)
383#     celldamp  -- damping for the unit cell refinement (*)
384#     spacegroup -- space group symbol
385#  action: get (default) or set
386#  value: used only with set
387#  * =>  read+write supported
388proc phaseinfo {phase parm "action get" "value {}"} {
389    switch ${parm}-$action {
390
391        name-get {
392            return [string trim [readexp "CRS$phase    PNAM"]]
393        }
394
395        spacegroup-get {
396            return [string trim [readexp "CRS$phase  SG SYM"]]
397        }
398
399        name-set {
400            setexp "CRS$phase    PNAM" " $value" 2 68
401        }
402
403        natoms-get {
404            return [string trim [readexp "CRS$phase   NATOM"]]     
405        }
406
407        a-get {
408           return [string trim [string range [readexp "CRS$phase  ABC"] 0 9]]
409        }
410        b-get {
411           return [string trim [string range [readexp "CRS$phase  ABC"] 10 19]]
412        }
413        c-get {
414           return [string trim [string range [readexp "CRS$phase  ABC"] 20 29]]
415        }
416        alpha-get {
417           return [string trim [string range [readexp "CRS$phase  ANGLES"] 0 9]]
418        }
419        beta-get {
420           return [string trim [string range [readexp "CRS$phase  ANGLES"] 10 19]]
421        }
422        gamma-get {
423           return [string trim [string range [readexp "CRS$phase  ANGLES"] 20 29]]
424        }
425
426        a-set {
427            if ![validreal value 10 6] {return 0}
428            setexp "CRS$phase  ABC" $value 1 10             
429        }
430        b-set {
431            if ![validreal value 10 6] {return 0}
432            setexp "CRS$phase  ABC" $value 11 10           
433        }
434        c-set {
435            if ![validreal value 10 6] {return 0}
436            setexp "CRS$phase  ABC" $value 21 10           
437        }
438        alpha-set {
439            if ![validreal value 10 4] {return 0}
440            setexp "CRS$phase  ANGLES" $value 1 10         
441        }
442        beta-set {
443            if ![validreal value 10 4] {return 0}
444            setexp "CRS$phase  ANGLES" $value 11 10         
445        }
446        gamma-set {
447            if ![validreal value10 4] {return 0}
448            setexp "CRS$phase  ANGLES" $value 21 10         
449        }
450        cellref-get {
451            if {[string toupper [string range [readexp "CRS$phase  ABC"] 34 34]] == "Y"} {
452                return 1
453            }
454            return 0
455        }
456        cellref-set {
457            if $value {
458                setexp "CRS$phase  ABC" "Y" 35 1
459            } else {
460                setexp "CRS$phase  ABC" "N" 35 1
461            }       
462        }
463        celldamp-get {
464            set val [string range [readexp "CRS$phase  ABC"] 39 39]
465            if {$val == " "} {return 0}
466            return $val
467        }
468        celldamp-set {
469            setexp "CRS$phase  ABC" $value 40 1
470        }
471
472        default {
473            set msg "Unsupported phaseinfo access: parm=$parm action=$action"
474            tk_dialog .badexp "Error in EXP" $msg error 0 Exit
475            destroy .
476        }
477    }
478    return 1
479}
480
481# get atom information: atominfo phase atom parm action value
482#   phase: 1 to 9 (as defined)
483#   atom: a valid atom number [see expmap(atomlist_$phase)]
484#      Note that atom and phase can be paired lists, but if there are extra
485#      entries in the atoms list, the last phase will be repeated.
486#      so that atominfo 1 {1 2 3} xset 1
487#               will set the xflag for atoms 1-3 in phase 1
488#      but atominfo {1 2 3} {1 1 1} xset 1
489#               will set the xflag for atoms 1 in phase 1-3
490#   parm:
491#     type -- element code
492#     mult -- atom multiplicity
493#     label -- atom label (*)
494#     x y z -- coordinates (*)
495#     frac --  occupancy (*)
496#     temptype -- I or A for Isotropic/Anisotropic
497#     Uiso  -- Isotropic temperature factor (*)
498#     U11  -- Anisotropic temperature factor (*)
499#     U22  -- Anisotropic temperature factor (*)
500#     U33  -- Anisotropic temperature factor (*)
501#     U12  -- Anisotropic temperature factor (*)
502#     U13  -- Anisotropic temperature factor (*)
503#     U23  -- Anisotropic temperature factor (*)
504#     xref/xdamp -- refinement flag/damping value for the coordinates (*)
505#     uref/udamp -- refinement flag/damping value for the temperature factor(s)  (*)
506#     fref/fdamp -- refinement flag/damping value for the occupancy (*)
507#  action: get (default) or set
508#  value: used only with set
509#  * =>  read+write supported
510
511proc atominfo {phaselist atomlist parm "action get" "value {}"} {
512    foreach phase $phaselist atom $atomlist {
513        if {$phase == ""} {set phase [lindex $phaselist end]}
514        if {$atom < 10} {
515            set key "CRS$phase  AT  $atom"
516        } elseif {$atom < 100} {
517            set key "CRS$phase  AT $atom"
518        } else {
519            set key "CRS$phase  AT$atom"
520        }
521        switch -glob ${parm}-$action {
522            type-get {
523                return [string trim [string range [readexp ${key}A] 2 9] ]
524            }
525            mult-get {
526                return [string trim [string range [readexp ${key}A] 58 61] ]
527            }
528            label-get {
529                return [string trim [string range [readexp ${key}A] 50 57] ]
530            }
531            label-set {
532                setexp ${key}A $value 51 8
533            }
534            temptype-get {
535                return [string trim [string range [readexp ${key}B] 62 62] ]
536            }
537            x-get {
538                return [string trim [string range [readexp ${key}A] 10 19] ]
539            }
540            x-set {
541                if ![validreal value 10 6] {return 0}
542                setexp ${key}A $value 11 10
543            }
544            y-get {
545                return [string trim [string range [readexp ${key}A] 20 29] ]
546            }
547            y-set {
548                if ![validreal value 10 6] {return 0}
549                setexp ${key}A $value 21 10
550            }
551            z-get {
552                return [string trim [string range [readexp ${key}A] 30 39] ]
553            }
554            z-set {
555                if ![validreal value 10 6] {return 0}
556                setexp ${key}A $value 31 10
557            }
558            frac-get {
559                return [string trim [string range [readexp ${key}A] 40 49] ]
560            }
561            frac-set {
562                if ![validreal value 10 6] {return 0}
563                setexp ${key}A $value 41 10
564            }
565            U*-get {
566                regsub U $parm {} type
567                if {$type == "iso" || $type == "11"} {
568                    return [string trim [string range [readexp ${key}B] 0 9] ]
569                } elseif {$type == "22"} {
570                    return [string trim [string range [readexp ${key}B] 10 19] ]
571                } elseif {$type == "33"} {
572                    return [string trim [string range [readexp ${key}B] 20 29] ]
573                } elseif {$type == "12"} {
574                    return [string trim [string range [readexp ${key}B] 30 39] ]
575                } elseif {$type == "13"} {
576                    return [string trim [string range [readexp ${key}B] 40 49] ]
577                } elseif {$type == "23"} {
578                    return [string trim [string range [readexp ${key}B] 50 59] ]
579                }
580            }
581            U*-set {
582                if ![validreal value 10 6] {return 0}
583                regsub U $parm {} type
584                if {$type == "iso" || $type == "11"} {
585                    setexp ${key}B $value 1 10
586                } elseif {$type == "22"} {
587                    setexp ${key}B $value 11 10
588                } elseif {$type == "33"} {
589                    setexp ${key}B $value 21 10
590                } elseif {$type == "12"} {
591                    setexp ${key}B $value 31 10
592                } elseif {$type == "13"} {
593                    setexp ${key}B $value 41 10
594                } elseif {$type == "23"} {
595                    setexp ${key}B $value 51 10
596                }
597            }
598            xref-get {
599                if {[string toupper [string range [readexp ${key}B] 64 64]] == "X"} {
600                    return 1
601                }
602                return 0
603            }
604            xref-set {
605                if $value {
606                    setexp ${key}B "X" 65 1
607                } else {
608                    setexp ${key}B " " 65 1
609                }           
610            }
611            xdamp-get {
612                set val [string range [readexp ${key}A] 64 64]
613                if {$val == " "} {return 0}
614                return $val
615            }
616            xdamp-set {
617                setexp ${key}A $value 65 1
618            }
619            fref-get {
620                if {[string toupper [string range [readexp ${key}B] 63 63]] == "F"} {
621                    return 1
622                }
623                return 0
624            }
625            fref-set {
626                if $value {
627                    setexp ${key}B "F" 64 1
628                } else {
629                    setexp ${key}B " " 64 1
630                }           
631            }
632            fdamp-get {
633                set val [string range [readexp ${key}A] 63 63]
634                if {$val == " "} {return 0}
635                return $val
636            }
637            fdamp-set {
638                setexp ${key}A $value 64 1
639            }
640
641            uref-get {
642                if {[string toupper [string range [readexp ${key}B] 65 65]] == "U"} {
643                    return 1
644                }
645                return 0
646            }
647            uref-set {
648                if $value {
649                    setexp ${key}B "U" 66 1
650                } else {
651                    setexp ${key}B " " 66 1
652                }           
653            }
654            udamp-get {
655                set val [string range [readexp ${key}A] 65 65]
656                if {$val == " "} {return 0}
657                return $val
658            }
659            udamp-set {
660                setexp ${key}A $value 66 1
661            }
662            default {
663                set msg "Unsupported atominfo access: parm=$parm action=$action"
664                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
665                destroy .
666            }
667        }
668    }
669    return 1
670}
671
672# get histogram information: histinfo histlist parm action value
673# histlist is a list of histogram numbers
674# parm:
675#     title
676#     scale (*)
677#     sref/sdamp -- refinement flag/damping value for the scale factor (*)
678#     lam1, lam2 (*)
679#     ttref refinement flag for the 2theta (ED Xray) (*)
680#     wref refinement flag for the wavelength (*)
681#     ratref refinement flag for the wavelength ratio (*)
682#     difc, difa -- TOF calibration constants (*)
683#     dcref,daref -- refinement flag for difc, difa (*)
684#     zero (*)
685#     zref refinement flag for the zero correction (*)
686#     ipola (*)
687#     pola (*)
688#     pref refinement flag for the polarization (*)
689#     kratio (*)
690#     ddamp -- damping value for the diffractometer constants (*)
691#     backtype -- background function number *
692#     backterms -- number of background terms *
693#     bref/bdamp -- refinement flag/damping value for the background (*)
694#     bterm$n -- background term #n (*)
695#     bank -- Bank number
696#     tofangle -- detector angle (TOF only)
697#     foextract  -- Fobs extraction flag (*)
698proc histinfo {histlist parm "action get" "value {}"} {
699    global expgui
700    foreach hist $histlist {
701        if {$hist < 10} {
702            set key "HST  $hist"
703        } else {
704            set key "HST $hist"
705        }
706        switch -glob ${parm}-$action {
707            foextract-get {
708                set line [readexp "${key} EPHAS"]
709                # add a EPHAS if not exists
710                if {$line == {}} {
711                    makeexprec "${key} EPHAS"
712                    # expedt defaults this to "F", but I think "T" is better
713                    setexp "${key} EPHAS" "T" 50 1
714                    if $expgui(debug) {puts "Warning: creating a ${key} EPHAS record"}
715                }
716                if {[string toupper [string range $line 49 49]] == "T"} {
717                    return 1
718                }
719                return 0
720            }
721            foextract-set {
722                if $value {
723                    setexp "${key} EPHAS" "T" 50 1
724                } else {
725                    setexp "${key} EPHAS" "F" 50 1
726                }           
727            }
728            title-get {
729                return [string trim [readexp "${key}  HNAM"] ]
730            }
731            scale-get {
732                return [string trim [string range [readexp ${key}HSCALE] 0 14]]
733            }
734            scale-set {
735                if ![validreal value 15 6] {return 0}
736                setexp ${key}HSCALE $value 1 15
737            }
738            sref-get {
739                if {[string toupper [string range [readexp ${key}HSCALE] 19 19]] == "Y"} {
740                    return 1
741                }
742                return 0
743            }
744            sref-set {
745                if $value {
746                    setexp ${key}HSCALE "Y" 20 1
747                } else {
748                    setexp ${key}HSCALE "N" 20 1
749                }           
750            }
751            sdamp-get {
752                set val [string range [readexp ${key}HSCALE] 24 24]
753                if {$val == " "} {return 0}
754                return $val
755            }
756            sdamp-set {
757                setexp ${key}HSCALE $value 25 1
758            }
759
760            difc-get -
761            lam1-get {
762                return [string trim [string range [readexp "${key} ICONS"] 0 9]]
763            }
764            difc-set -
765            lam1-set {
766                if ![validreal value 10 7] {return 0}
767                setexp "${key} ICONS" $value 1 10
768            }
769            difa-get -
770            lam2-get {
771                return [string trim [string range [readexp "${key} ICONS"] 10 19]]
772            }
773            difa-set -
774            lam2-set {
775                if ![validreal value 10 7] {return 0}
776                setexp "${key} ICONS" $value 11 10
777            }
778            zero-get {
779                return [string trim [string range [readexp "${key} ICONS"] 20 29]]
780            }
781            zero-set {
782                if ![validreal value 10 5] {return 0}
783                setexp "${key} ICONS" $value 21 10
784            }
785            ipola-get {
786                return [string trim [string range [readexp "${key} ICONS"] 54 54]]
787            }
788            ipola-set {
789                if ![validint value 1] {return 0}
790                setexp "${key} ICONS" $value 55 1
791            }
792            pola-get {
793                return [string trim [string range [readexp "${key} ICONS"] 40 49]]
794            }
795            pola-set {
796                if ![validreal value 10 5] {return 0}
797                setexp "${key} ICONS" $value 41 10
798            }
799            kratio-get {
800                return [string trim [string range [readexp "${key} ICONS"] 55 64]]
801            }
802            kratio-set {
803                if ![validreal value 10 5] {return 0}
804                setexp "${key} ICONS" $value 56 10
805            }
806
807            wref-get {
808            #------------------------------------------------------
809            # col 33: refine flag for lambda, difc, ratio and theta
810            #------------------------------------------------------
811                if {[string toupper [string range \
812                        [readexp "${key} ICONS"] 32 32]] == "L"} {
813                    return 1
814                }
815                return 0
816            }
817            wref-set {
818                if $value {
819                    setexp "${key} ICONS" "L" 33 1
820                } else {
821                    setexp "${key} ICONS" " " 33 1
822                }           
823            }
824            ratref-get {
825                if {[string toupper [string range \
826                        [readexp "${key} ICONS"] 32 32]] == "R"} {
827                    return 1
828                }
829                return 0
830            }
831            ratref-set {
832                if $value {
833                    setexp "${key} ICONS" "R" 33 1
834                } else {
835                    setexp "${key} ICONS" " " 33 1
836                }           
837            }
838            dcref-get {
839                if {[string toupper [string range \
840                        [readexp "${key} ICONS"] 32 32]] == "C"} {
841                    return 1
842                }
843                return 0
844            }
845            dcref-set {
846                if $value {
847                    setexp "${key} ICONS" "C" 33 1
848                } else {
849                    setexp "${key} ICONS" " " 33 1
850                }           
851            }
852            ttref-get {
853                if {[string toupper [string range \
854                        [readexp "${key} ICONS"] 32 32]] == "T"} {
855                    return 1
856                }
857                return 0
858            }
859            ttref-set {
860                if $value {
861                    setexp "${key} ICONS" "T" 33 1
862                } else {
863                    setexp "${key} ICONS" " " 33 1
864                }           
865            }
866
867
868            pref-get {
869            #------------------------------------------------------
870            # col 34: refine flag for POLA & DIFA
871            #------------------------------------------------------
872                if {[string toupper [string range \
873                        [readexp "${key} ICONS"] 33 33]] == "P"} {
874                    return 1
875                }
876                return 0
877            }
878            pref-set {
879                if $value {
880                    setexp "${key} ICONS" "P" 34 1
881                } else {
882                    setexp "${key} ICONS" " " 34 1
883                }           
884            }
885            daref-get {
886                if {[string toupper [string range \
887                        [readexp "${key} ICONS"] 33 33]] == "A"} {
888                    return 1
889                }
890                return 0
891            }
892            daref-set {
893                if $value {
894                    setexp "${key} ICONS" "A" 34 1
895                } else {
896                    setexp "${key} ICONS" " " 34 1
897                }           
898            }
899
900            zref-get {
901            #------------------------------------------------------
902            # col 34: refine flag for zero correction
903            #------------------------------------------------------
904                if {[string toupper [string range [readexp "${key} ICONS"] 34 34]] == "Z"} {
905                    return 1
906                }
907                return 0
908            }
909            zref-set {
910                if $value {
911                    setexp "${key} ICONS" "Z" 35 1
912                } else {
913                    setexp "${key} ICONS" " " 35 1
914                }           
915            }
916
917            ddamp-get {
918                set val [string range [readexp "${key} ICONS"] 39 39]
919                if {$val == " "} {return 0}
920                return $val
921            }
922            ddamp-set {
923                setexp "${key} ICONS" $value 40 1
924            }
925
926            backtype-get {
927                set val [string trim [string range [readexp "${key}BAKGD "] 0 4]]
928                if {$val == " "} {return 0}
929                return $val
930            }
931            backtype-set {
932                if ![validint value 5] {return 0}
933                setexp "${key}BAKGD " $value 1 5
934            }
935            backterms-get {
936                set val [string trim [string range [readexp "${key}BAKGD "] 5 9]]
937                if {$val == " "} {return 0}
938                return $val
939            }
940            backterms-set {
941                # this takes a bit of work -- if terms are added, add lines as needed to the .EXP
942                set oldval [string trim [string range [readexp "${key}BAKGD "] 5 9]]
943                if ![validint value 5] {return 0}
944                if {$oldval < $value} {
945                    set line1  [expr 2 + ($oldval - 1) / 4]
946                    set line2  [expr 1 + ($value - 1) / 4]
947                    for {set i $line1} {$i <= $line2} {incr i} {
948                        # create a blank entry if needed
949                        makeexprec ${key}BAKGD$i
950                    }
951                    incr oldval
952                    for {set num $oldval} {$num <= $value} {incr num} {
953                        set f1 [expr 15*(($num - 1) % 4)]
954                        set f2 [expr 15*(1 + ($num - 1) % 4)-1]
955                        set line  [expr 1 + ($num - 1) / 4]
956                        if {[string trim [string range [readexp ${key}BAKGD$line] $f1 $f2]] == ""} {
957                            set f1 [expr 15*(($num - 1) % 4)+1]
958                            setexp ${key}BAKGD$line 0.0 $f1 15                 
959                        }
960                    }
961                }
962                setexp "${key}BAKGD " $value 6 5
963
964            }
965            bref-get {
966                if {[string toupper [string range [readexp "${key}BAKGD"] 14 14]] == "Y"} {
967                    return 1
968                }
969                return 0
970            }
971            bref-set {
972                if $value {
973                    setexp "${key}BAKGD "  "Y" 15 1
974                } else {
975                    setexp "${key}BAKGD "  "N" 15 1
976                }           
977            }
978            bdamp-get {
979                set val [string range [readexp "${key}BAKGD "] 19 19]
980                if {$val == " "} {return 0}
981                return $val
982            }
983            bdamp-set {
984                setexp "${key}BAKGD " $value 20 1
985            }
986            bterm*-get {
987                regsub bterm $parm {} num
988                set f1 [expr 15*(($num - 1) % 4)]
989                set f2 [expr 15*(1 + ($num - 1) % 4)-1]
990                set line  [expr 1 + ($num - 1) / 4]
991                return [string trim [string range [readexp ${key}BAKGD$line] $f1 $f2] ]
992            }
993            bterm*-set {
994                regsub bterm $parm {} num
995                if ![validreal value 15 6] {return 0}
996                set f1 [expr 15*(($num - 1) % 4)+1]
997                set line  [expr 1 + ($num - 1) / 4]
998                setexp ${key}BAKGD$line $value $f1 15
999            }
1000            bank-get {
1001                return [string trim [string range [readexp "${key} BANK"] 0 4]]
1002            }
1003            tofangle-get {
1004                return [string trim [string range [readexp "${key}BNKPAR"] 10 19]]
1005            }
1006            default {
1007                set msg "Unsupported histinfo access: parm=$parm action=$action"
1008                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
1009                destroy .
1010            }
1011        }
1012    }
1013    return 1
1014}
1015
1016# read the information that differs by both histogram and phase (profile & phase fraction)
1017# use: hapinfo hist phase parm action value
1018# 
1019#     frac -- phase fraction (*)
1020#     frref/frdamp -- refinement flag/damping value for the phase fraction (*)
1021#     proftype -- profile function number
1022#     profterms -- number of profile terms
1023#     pdamp -- damping value for the profile (*)
1024#     pcut -- cutoff value for the profile (*)
1025#     pterm$n -- profile term #n
1026#     pref$n -- refinement flag value for profile term #n (*)
1027#     extmeth -- Fobs extraction method (*)
1028proc hapinfo {histlist phaselist parm "action get" "value {}"} {
1029    foreach phase $phaselist hist $histlist {
1030        if {$phase == ""} {set phase [lindex $phaselist end]}
1031        if {$hist == ""} {set hist [lindex $histlist end]}
1032        if {$hist < 10} {
1033            set hist " $hist"
1034        }
1035        set key "HAP${phase}${hist}"
1036        switch -glob ${parm}-$action {
1037            extmeth-get {
1038                set i1 [expr ($phase - 1)*5]
1039                set i2 [expr $i1 + 4]
1040                return [string trim [string range [readexp "HST $hist EPHAS"] $i1 $i2]]
1041            }
1042            extmeth-set {
1043                set i1 [expr ($phase - 1)*5 + 1]
1044                if ![validint value 5] {return 0}
1045                setexp "HST $hist EPHAS" $value $i1 5
1046            }
1047            frac-get {
1048                return [string trim [string range [readexp ${key}PHSFR] 0 14]]
1049            }
1050            frac-set {
1051                if ![validreal value 15 6] {return 0}
1052                setexp ${key}PHSFR $value 1 15
1053            }
1054            frref-get {
1055                if {[string toupper [string range [readexp ${key}PHSFR] 19 19]] == "Y"} {
1056                    return 1
1057                }
1058                return 0
1059            }
1060            frref-set {
1061                if $value {
1062                    setexp ${key}PHSFR "Y" 20 1
1063                } else {
1064                    setexp ${key}PHSFR "N" 20 1
1065                }           
1066            }
1067            frdamp-get {
1068                set val [string range [readexp ${key}PHSFR] 24 24]
1069                if {$val == " "} {return 0}
1070                return $val
1071            }
1072            frdamp-set {
1073                setexp ${key}PHSFR $value 25 1
1074            }
1075            proftype-get {
1076                set val [string range [readexp "${key}PRCF "] 0 4]
1077                if {$val == " "} {return 0}
1078                return $val
1079            }
1080            profterms-get {
1081                set val [string range [readexp "${key}PRCF "] 5 9]
1082                if {$val == " "} {return 0}
1083                return $val
1084            }
1085            pcut-get {
1086                return [string trim [string range [readexp "${key}PRCF "] 10 19]]
1087            }
1088            pcut-set {
1089                if ![validreal value 10 5] {return 0}
1090                setexp "${key}PRCF " $value 11 10
1091            }
1092            pdamp-get {
1093                set val [string range [readexp "${key}PRCF "] 24 24]
1094                if {$val == " "} {return 0}
1095                return $val
1096            }
1097            pdamp-set {
1098                setexp "${key}PRCF   " $value 25 1
1099            }
1100            pterm*-get {
1101                regsub pterm $parm {} num
1102                set f1 [expr 15*(($num - 1) % 4)]
1103                set f2 [expr 15*(1 + ($num - 1) % 4)-1]
1104                set line  [expr 1 + ($num - 1) / 4]
1105                return [string trim [string range [readexp "${key}PRCF $line"] $f1 $f2] ]
1106            }
1107            pterm*-set {
1108                if ![validreal value 15 6] {return 0}
1109                regsub pterm $parm {} num
1110                set f1 [expr 1+ 15*(($num - 1) % 4)]
1111                set line  [expr 1 + ($num - 1) / 4]
1112                setexp "${key}PRCF $line" $value $f1 15
1113            }
1114            pref*-get {
1115                regsub pref $parm {} num
1116                set f [expr 24+$num]
1117                if {[string toupper [string range [readexp "${key}PRCF  "] $f $f]] == "Y"} {
1118                    return 1
1119                }
1120                return 0
1121            }
1122            pref*-set {
1123                regsub pref $parm {} num
1124                set f [expr 25+$num]
1125                if $value {
1126                    setexp ${key}PRCF "Y" $f 1
1127                } else {
1128                    setexp ${key}PRCF "N" $f 1
1129                }           
1130            }
1131            default {
1132                set msg "Unsupported hapinfo access: parm=$parm action=$action"
1133                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
1134                destroy .
1135            }
1136        }
1137    }
1138    return 1
1139}
1140
1141#  get a logical constraint
1142#  type action
1143#  -----------
1144#  atom get    returns a list of constraints.
1145#       set    replaces a list of constraints.
1146#       add    inserts a new list of constraints
1147#       delete deletes a set of constraint entries
1148# Each item in the list of constraints is composed of 4 items:
1149#   phase, atom, variable, multiplier
1150#      if variable=UISO atom can be ALL, otherwise atom is a number
1151# legal variable names: FRAC, X, Y, Z, UISO, U11, U22, U33, U12, U23, U13,
1152#                       MX, MY, MZ
1153proc constrinfo {type action number "value {}"} {
1154    switch -glob ${type}-$action {
1155        atom-get {
1156            # does this constraint exist?
1157            set key [format "LNCN%4d%4d" $number 1]
1158            if {![existsexp $key]} {return -1}
1159            set clist {}
1160            for {set i 1} {$i < 999} {incr i} {
1161                set key [format "LNCN%4d%4d" $number $i]
1162                if {![existsexp $key]} break
1163                set line [readexp $key]
1164                set j1 2
1165                set j2 17
1166                set seg [string range $line $j1 $j2]
1167                while {[string trim $seg] != ""} {
1168                    lappend clist [list \
1169                            [string range $seg 0 0] \
1170                            [string trim [string range $seg 1 3]] \
1171                            [string trim [string range $seg 4 7]] \
1172                            [string trim [string range $seg 8 end]]]
1173                    incr j1 16
1174                    incr j2 16
1175                    set seg [string range $line $j1 $j2]
1176                }
1177            }
1178            return $clist
1179        }
1180        atom-set {
1181            # delete records for current constraint
1182            for {set i 1} {$i < 999} {incr i} {
1183                set key [format "LNCN%4d%4d" $number $i]
1184                if {![existsexp $key]} break
1185                delexp $key
1186            }
1187            set line {}
1188            set i 1
1189            foreach tuple $value {
1190                if {[string toupper [lindex $tuple 1]] == "ALL"} {
1191                    set seg [format %1dALL%-4s%8.4f \
1192                            [lindex $tuple 0] \
1193                            [lindex $tuple 2] \
1194                            [lindex $tuple 3]]
1195                } else {
1196                    set seg [eval format %1d%3d%-4s%8.4f $tuple]
1197                }
1198                append line $seg
1199                if {[string length $line] > 50} {
1200                    set key  [format "LNCN%4d%4d" $number $i]
1201                    makeexprec $key
1202                    setexp $key $line 3 68
1203                    set line {}
1204                    incr i
1205                }
1206            }
1207            if {$line != ""} {
1208                set key  [format "LNCN%4d%4d" $number $i]
1209                makeexprec $key
1210                setexp $key $line 3 68
1211            }
1212            return
1213        }
1214        atom-add {
1215            # loop over defined constraints
1216            for {set j 1} {$j < 9999} {incr j} {
1217                set key [format "LNCN%4d%4d" $j 1]
1218                if {![existsexp $key]} break
1219            }
1220            set number $j
1221            # save the constraint
1222            set line {}
1223            set i 1
1224            foreach tuple $value {
1225                if {[string toupper [lindex $tuple 1]] == "ALL"} {
1226                    set seg [format %1dALL%-4s%8.4f \
1227                            [lindex $tuple 0] \
1228                            [lindex $tuple 2] \
1229                            [lindex $tuple 3]]
1230                } else {
1231                    set seg [eval format %1d%3d%-4s%8.4f $tuple]
1232                }
1233                append line $seg
1234                if {[string length $line] > 50} {
1235                    set key  [format "LNCN%4d%4d" $number $i]
1236                    makeexprec $key
1237                    setexp $key $line 3 68
1238                    set line {}
1239                    incr i
1240                }
1241            }
1242            if {$line != ""} {
1243                set key  [format "LNCN%4d%4d" $number $i]
1244                makeexprec $key
1245                setexp $key $line 3 68
1246            }
1247            return
1248        }
1249        atom-delete {
1250            for {set j $number} {$j < 9999} {incr j} {
1251                # delete records for current constraint
1252                for {set i 1} {$i < 999} {incr i} {
1253                    set key [format "LNCN%4d%4d" $j $i]
1254                    if {![existsexp $key]} break
1255                    delexp $key
1256                }
1257                # now copy records, from the next entry, if any
1258                set j1 $j
1259                incr j1
1260                set key1 [format "LNCN%4d%4d" $j1 1]
1261                # if there is no record, there is nothing to copy -- done
1262                if {![existsexp $key1]} return
1263                for {set i 1} {$i < 999} {incr i} {
1264                    set key1 [format "LNCN%4d%4d" $j1 $i]
1265                    if {![existsexp $key1]} break
1266                    set key  [format "LNCN%4d%4d" $j  $i]
1267                    makeexprec $key
1268                    setexp $key [readexp $key1] 1 68
1269                }
1270            }
1271        }
1272        default {
1273            set msg "Unsupported constrinfo access: type=$type action=$action"
1274#           tk_dialog .badexp "Error in EXP" $msg error 0 Exit
1275#           destroy .
1276        }
1277
1278    }
1279}
1280
1281# write the .EXP file
1282proc expwrite {expfile} {
1283    global tcl_platform exparray
1284    set blankline \
1285     "                                                                        "
1286    set fp [open ${expfile} w]
1287    set keylist [lsort [array names exparray]]
1288    # reorder the keys so that VERSION comes 1st
1289    set pos [lsearch -exact $keylist {     VERSION}]
1290    set keylist "{     VERSION} [lreplace $keylist $pos $pos]"
1291    if {$tcl_platform(platform) == "windows"} { 
1292        foreach key $keylist {
1293            puts $fp [string range \
1294                    "$key$exparray($key)$blankline" 0 79]
1295        }
1296    } else {
1297        foreach key $keylist {
1298            puts -nonewline $fp [string range \
1299                    "$key$exparray($key)$blankline" 0 79]
1300        }
1301    }
1302    close $fp
1303}
1304
1305# history commands -- delete all but last $keep history records,
1306# renumber if $renumber is true
1307proc DeleteHistory {keep renumber} {
1308    global exparray
1309    foreach y [lrange [lsort -decreasing \
1310            [array names exparray {    HSTRY*}]] $keep end] {
1311        unset exparray($y)
1312    }
1313    if !$renumber return
1314    # renumber
1315    set i 0
1316    foreach y [lsort -increasing \
1317            [array names exparray {    HSTRY*}]] {
1318        set key [format "    HSTRY%3d" [incr i]]
1319        set exparray($key) $exparray($y)
1320        unset exparray($y)
1321    }
1322    # list all history
1323    #    foreach y [lsort -decreasing [array names exparray {    HSTRY*}]] {puts "$y $exparray($y)"}
1324}
1325
1326proc CountHistory {} {
1327    global exparray
1328    return [llength [array names exparray {    HSTRY*}]]
1329}
Note: See TracBrowser for help on using the repository browser.