source: trunk/readexp.tcl @ 88

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

# on 1999/04/08 20:44:22, toby did:
Add Id to header
  • Property rcs:author set to toby
  • Property rcs:date set to 1999/04/08 20:44:22
  • Property rcs:lines set to +2 -1
  • Property rcs:rev set to 1.9
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 30.4 KB
Line 
1# $Id: readexp.tcl 85 2009-12-04 23:00:09Z toby $
2# Routines to deal with the .EXP "data structure"
3set expmap(Revision) {$Revision: 85 $ $Date: 2009-12-04 23:00:09 +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    foreach hist $histlist {
688        if {$hist < 10} {
689            set key "HST  $hist"
690        } else {
691            set key "HST $hist"
692        }
693        switch -glob ${parm}-$action {
694            foextract-get {
695                if {[string toupper [string range [readexp "${key} EPHAS" ] 49 49]] == "T"} {
696                    return 1
697                }
698                return 0
699            }
700            foextract-set {
701                if $value {
702                    setexp "${key} EPHAS" "T" 50 1
703                } else {
704                    setexp "${key} EPHAS" "F" 50 1
705                }           
706            }
707            title-get {
708                return [string trim [readexp "${key}  HNAM"] ]
709            }
710            scale-get {
711                return [string trim [string range [readexp ${key}HSCALE] 0 14]]
712            }
713            scale-set {
714                if ![validreal value 15 6] {return 0}
715                setexp ${key}HSCALE $value 1 15
716            }
717            sref-get {
718                if {[string toupper [string range [readexp ${key}HSCALE] 19 19]] == "Y"} {
719                    return 1
720                }
721                return 0
722            }
723            sref-set {
724                if $value {
725                    setexp ${key}HSCALE "Y" 20 1
726                } else {
727                    setexp ${key}HSCALE "N" 20 1
728                }           
729            }
730            sdamp-get {
731                set val [string range [readexp ${key}HSCALE] 24 24]
732                if {$val == " "} {return 0}
733                return $val
734            }
735            sdamp-set {
736                setexp ${key}HSCALE $value 25 1
737            }
738
739            difc-get -
740            lam1-get {
741                return [string trim [string range [readexp "${key} ICONS"] 0 9]]
742            }
743            difc-set -
744            lam1-set {
745                if ![validreal value 10 7] {return 0}
746                setexp "${key} ICONS" $value 1 10
747            }
748            difa-get -
749            lam2-get {
750                return [string trim [string range [readexp "${key} ICONS"] 10 19]]
751            }
752            difa-set -
753            lam2-set {
754                if ![validreal value 10 7] {return 0}
755                setexp "${key} ICONS" $value 11 10
756            }
757            zero-get {
758                return [string trim [string range [readexp "${key} ICONS"] 20 29]]
759            }
760            zero-set {
761                if ![validreal value 10 5] {return 0}
762                setexp "${key} ICONS" $value 21 10
763            }
764            ipola-get {
765                return [string trim [string range [readexp "${key} ICONS"] 54 54]]
766            }
767            ipola-set {
768                if ![validint value 1] {return 0}
769                setexp "${key} ICONS" $value 55 1
770            }
771            pola-get {
772                return [string trim [string range [readexp "${key} ICONS"] 40 49]]
773            }
774            pola-set {
775                if ![validreal value 10 5] {return 0}
776                setexp "${key} ICONS" $value 41 10
777            }
778            kratio-get {
779                return [string trim [string range [readexp "${key} ICONS"] 55 64]]
780            }
781            kratio-set {
782                if ![validreal value 10 5] {return 0}
783                setexp "${key} ICONS" $value 56 10
784            }
785
786            wref-get {
787            #------------------------------------------------------
788            # col 33: refine flag for lambda, difc, ratio and theta
789            #------------------------------------------------------
790                if {[string toupper [string range \
791                        [readexp "${key} ICONS"] 32 32]] == "L"} {
792                    return 1
793                }
794                return 0
795            }
796            wref-set {
797                if $value {
798                    setexp "${key} ICONS" "L" 33 1
799                } else {
800                    setexp "${key} ICONS" " " 33 1
801                }           
802            }
803            ratref-get {
804                if {[string toupper [string range \
805                        [readexp "${key} ICONS"] 32 32]] == "R"} {
806                    return 1
807                }
808                return 0
809            }
810            ratref-set {
811                if $value {
812                    setexp "${key} ICONS" "R" 33 1
813                } else {
814                    setexp "${key} ICONS" " " 33 1
815                }           
816            }
817            dcref-get {
818                if {[string toupper [string range \
819                        [readexp "${key} ICONS"] 32 32]] == "C"} {
820                    return 1
821                }
822                return 0
823            }
824            dcref-set {
825                if $value {
826                    setexp "${key} ICONS" "C" 33 1
827                } else {
828                    setexp "${key} ICONS" " " 33 1
829                }           
830            }
831            ttref-get {
832                if {[string toupper [string range \
833                        [readexp "${key} ICONS"] 32 32]] == "T"} {
834                    return 1
835                }
836                return 0
837            }
838            ttref-set {
839                if $value {
840                    setexp "${key} ICONS" "T" 33 1
841                } else {
842                    setexp "${key} ICONS" " " 33 1
843                }           
844            }
845
846
847            pref-get {
848            #------------------------------------------------------
849            # col 34: refine flag for POLA & DIFA
850            #------------------------------------------------------
851                if {[string toupper [string range \
852                        [readexp "${key} ICONS"] 33 33]] == "P"} {
853                    return 1
854                }
855                return 0
856            }
857            pref-set {
858                if $value {
859                    setexp "${key} ICONS" "P" 34 1
860                } else {
861                    setexp "${key} ICONS" " " 34 1
862                }           
863            }
864            daref-get {
865                if {[string toupper [string range \
866                        [readexp "${key} ICONS"] 33 33]] == "A"} {
867                    return 1
868                }
869                return 0
870            }
871            daref-set {
872                if $value {
873                    setexp "${key} ICONS" "A" 34 1
874                } else {
875                    setexp "${key} ICONS" " " 34 1
876                }           
877            }
878
879            zref-get {
880            #------------------------------------------------------
881            # col 34: refine flag for zero correction
882            #------------------------------------------------------
883                if {[string toupper [string range [readexp "${key} ICONS"] 34 34]] == "Z"} {
884                    return 1
885                }
886                return 0
887            }
888            zref-set {
889                if $value {
890                    setexp "${key} ICONS" "Z" 35 1
891                } else {
892                    setexp "${key} ICONS" " " 35 1
893                }           
894            }
895
896            ddamp-get {
897                set val [string range [readexp "${key} ICONS"] 39 39]
898                if {$val == " "} {return 0}
899                return $val
900            }
901            ddamp-set {
902                setexp "${key} ICONS" $value 40 1
903            }
904
905            backtype-get {
906                set val [string trim [string range [readexp "${key}BAKGD "] 0 4]]
907                if {$val == " "} {return 0}
908                return $val
909            }
910            backtype-set {
911                if ![validint value 5] {return 0}
912                setexp "${key}BAKGD " $value 1 5
913            }
914            backterms-get {
915                set val [string trim [string range [readexp "${key}BAKGD "] 5 9]]
916                if {$val == " "} {return 0}
917                return $val
918            }
919            backterms-set {
920                # this takes a bit of work -- if terms are added, add lines as needed to the .EXP
921                set oldval [string trim [string range [readexp "${key}BAKGD "] 5 9]]
922                if ![validint value 5] {return 0}
923                if {$oldval < $value} {
924                    set line1  [expr 2 + ($oldval - 1) / 4]
925                    set line2  [expr 1 + ($value - 1) / 4]
926                    for {set i $line1} {$i <= $line2} {incr i} {
927                        # create a blank entry if needed
928                        makeexprec ${key}BAKGD$i
929                    }
930                    incr oldval
931                    for {set num $oldval} {$num <= $value} {incr num} {
932                        set f1 [expr 15*(($num - 1) % 4)]
933                        set f2 [expr 15*(1 + ($num - 1) % 4)-1]
934                        set line  [expr 1 + ($num - 1) / 4]
935                        if {[string trim [string range [readexp ${key}BAKGD$line] $f1 $f2]] == ""} {
936                            set f1 [expr 15*(($num - 1) % 4)+1]
937                            setexp ${key}BAKGD$line 0.0 $f1 15                 
938                        }
939                    }
940                }
941                setexp "${key}BAKGD " $value 6 5
942
943            }
944            bref-get {
945                if {[string toupper [string range [readexp "${key}BAKGD"] 14 14]] == "Y"} {
946                    return 1
947                }
948                return 0
949            }
950            bref-set {
951                if $value {
952                    setexp "${key}BAKGD "  "Y" 15 1
953                } else {
954                    setexp "${key}BAKGD "  "N" 15 1
955                }           
956            }
957            bdamp-get {
958                set val [string range [readexp "${key}BAKGD "] 19 19]
959                if {$val == " "} {return 0}
960                return $val
961            }
962            bdamp-set {
963                setexp "${key}BAKGD " $value 20 1
964            }
965            bterm*-get {
966                regsub bterm $parm {} num
967                set f1 [expr 15*(($num - 1) % 4)]
968                set f2 [expr 15*(1 + ($num - 1) % 4)-1]
969                set line  [expr 1 + ($num - 1) / 4]
970                return [string trim [string range [readexp ${key}BAKGD$line] $f1 $f2] ]
971            }
972            bterm*-set {
973                regsub bterm $parm {} num
974                if ![validreal value 15 6] {return 0}
975                set f1 [expr 15*(($num - 1) % 4)+1]
976                set line  [expr 1 + ($num - 1) / 4]
977                setexp ${key}BAKGD$line $value $f1 15
978            }
979            bank-get {
980                return [string trim [string range [readexp "${key} BANK"] 0 4]]
981            }
982            tofangle-get {
983                return [string trim [string range [readexp "${key}BNKPAR"] 10 19]]
984            }
985            default {
986                set msg "Unsupported histinfo access: parm=$parm action=$action"
987                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
988                destroy .
989            }
990        }
991    }
992    return 1
993}
994
995# read the information that differs by both histogram and phase (profile & phase fraction)
996# use: hapinfo hist phase parm action value
997# 
998#     frac -- phase fraction (*)
999#     frref/frdamp -- refinement flag/damping value for the phase fraction (*)
1000#     proftype -- profile function number
1001#     profterms -- number of profile terms
1002#     pdamp -- damping value for the profile (*)
1003#     pcut -- cutoff value for the profile (*)
1004#     pterm$n -- profile term #n
1005#     pref$n -- refinement flag value for profile term #n (*)
1006#     extmeth -- Fobs extraction method (*)
1007proc hapinfo {histlist phaselist parm "action get" "value {}"} {
1008    foreach phase $phaselist hist $histlist {
1009        if {$phase == ""} {set phase [lindex $phaselist end]}
1010        if {$hist == ""} {set hist [lindex $histlist end]}
1011        if {$hist < 10} {
1012            set hist " $hist"
1013        }
1014        set key "HAP${phase}${hist}"
1015        switch -glob ${parm}-$action {
1016            extmeth-get {
1017                set i1 [expr ($phase - 1)*5]
1018                set i2 [expr $i1 + 4]
1019                return [string trim [string range [readexp "HST $hist EPHAS"] $i1 $i2]]
1020            }
1021            extmeth-set {
1022                set i1 [expr ($phase - 1)*5 + 1]
1023                if ![validint value 5] {return 0}
1024                setexp "HST $hist EPHAS" $value $i1 5
1025            }
1026            frac-get {
1027                return [string trim [string range [readexp ${key}PHSFR] 0 14]]
1028            }
1029            frac-set {
1030                if ![validreal value 15 6] {return 0}
1031                setexp ${key}PHSFR $value 1 15
1032            }
1033            frref-get {
1034                if {[string toupper [string range [readexp ${key}PHSFR] 19 19]] == "Y"} {
1035                    return 1
1036                }
1037                return 0
1038            }
1039            frref-set {
1040                if $value {
1041                    setexp ${key}PHSFR "Y" 20 1
1042                } else {
1043                    setexp ${key}PHSFR "N" 20 1
1044                }           
1045            }
1046            frdamp-get {
1047                set val [string range [readexp ${key}PHSFR] 24 24]
1048                if {$val == " "} {return 0}
1049                return $val
1050            }
1051            frdamp-set {
1052                setexp ${key}PHSFR $value 25 1
1053            }
1054            proftype-get {
1055                set val [string range [readexp "${key}PRCF "] 0 4]
1056                if {$val == " "} {return 0}
1057                return $val
1058            }
1059            profterms-get {
1060                set val [string range [readexp "${key}PRCF "] 5 9]
1061                if {$val == " "} {return 0}
1062                return $val
1063            }
1064            pcut-get {
1065                return [string trim [string range [readexp "${key}PRCF "] 10 19]]
1066            }
1067            pcut-set {
1068                if ![validreal value 10 5] {return 0}
1069                setexp "${key}PRCF " $value 11 10
1070            }
1071            pdamp-get {
1072                set val [string range [readexp "${key}PRCF "] 24 24]
1073                if {$val == " "} {return 0}
1074                return $val
1075            }
1076            pdamp-set {
1077                setexp "${key}PRCF   " $value 25 1
1078            }
1079            pterm*-get {
1080                regsub pterm $parm {} num
1081                set f1 [expr 15*(($num - 1) % 4)]
1082                set f2 [expr 15*(1 + ($num - 1) % 4)-1]
1083                set line  [expr 1 + ($num - 1) / 4]
1084                return [string trim [string range [readexp "${key}PRCF $line"] $f1 $f2] ]
1085            }
1086            pterm*-set {
1087                if ![validreal value 15 6] {return 0}
1088                regsub pterm $parm {} num
1089                set f1 [expr 1+ 15*(($num - 1) % 4)]
1090                set line  [expr 1 + ($num - 1) / 4]
1091                setexp "${key}PRCF $line" $value $f1 15
1092            }
1093            pref*-get {
1094                regsub pref $parm {} num
1095                set f [expr 24+$num]
1096                if {[string toupper [string range [readexp "${key}PRCF  "] $f $f]] == "Y"} {
1097                    return 1
1098                }
1099                return 0
1100            }
1101            pref*-set {
1102                regsub pref $parm {} num
1103                set f [expr 25+$num]
1104                if $value {
1105                    setexp ${key}PRCF "Y" $f 1
1106                } else {
1107                    setexp ${key}PRCF "N" $f 1
1108                }           
1109            }
1110            default {
1111                set msg "Unsupported hapinfo access: parm=$parm action=$action"
1112                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
1113                destroy .
1114            }
1115        }
1116    }
1117    return 1
1118}
1119
1120# write the .EXP file
1121proc expwrite {expfile} {
1122    global tcl_platform exparray
1123    set blankline "                                                                   "
1124    set fp [open ${expfile} w]
1125    set keylist [lsort [array names exparray]]
1126    # reorder the keys so that VERSION comes 1st
1127    set pos [lsearch -exact $keylist {     VERSION}]
1128    set keylist "{     VERSION} [lreplace $keylist $pos $pos]"
1129    if {$tcl_platform(platform) == "windows"} { 
1130        foreach key $keylist {
1131            puts $fp [string range \
1132                    "$key$exparray($key)$blankline" 0 79]
1133        }
1134    } else {
1135        foreach key $keylist {
1136            puts -nonewline $fp [string range \
1137                    "$key$exparray($key)$blankline" 0 79]
1138        }
1139    }
1140    close $fp
1141}
Note: See TracBrowser for help on using the repository browser.