source: trunk/readexp.tcl @ 124

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

# on 2000/02/02 17:42:20, toby did:
create HST xx EPHAS records if missing

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