source: trunk/readexp.tcl @ 53

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

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