source: trunk/readexp.tcl @ 15

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

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