source: trunk/readexp.tcl @ 11

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

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