source: trunk/readexp.tcl @ 55

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

# on 1999/02/18 21:07:19, toby did:
Add support for atom multiplicity
  • Property rcs:author set to toby
  • Property rcs:date set to 1999/02/18 21:07:19
  • Property rcs:lines set to +5 -1
  • Property rcs:rev set to 1.6
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 30.2 KB
Line 
1# Routines to deal with the .EXP "data structure"
2set expmap(Revision) {$Revision: 55 $ $Date: 2009-12-04 22:59:39 +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#     mult -- atom multiplicity
475#     label -- atom label (*)
476#     x y z -- coordinates (*)
477#     frac --  occupancy (*)
478#     temptype -- I or A for Isotropic/Anisotropic
479#     Uiso  -- Isotropic temperature factor (*)
480#     U11  -- Anisotropic temperature factor (*)
481#     U22  -- Anisotropic temperature factor (*)
482#     U33  -- Anisotropic temperature factor (*)
483#     U12  -- Anisotropic temperature factor (*)
484#     U23  -- Anisotropic temperature factor (*)
485#     U13  -- Anisotropic temperature factor (*)
486#     xref/xdamp -- refinement flag/damping value for the coordinates (*)
487#     uref/udamp -- refinement flag/damping value for the temperature factor(s)  (*)
488#     fref/fdamp -- refinement flag/damping value for the occupancy (*)
489#  action: get (default) or set
490#  value: used only with set
491#  * =>  read+write supported
492
493proc atominfo {phaselist atomlist parm "action get" "value {}"} {
494    foreach phase $phaselist atom $atomlist {
495        if {$phase == ""} {set phase [lindex $phaselist end]}
496        if {$atom < 10} {
497            set key "CRS$phase  AT  $atom"
498        } elseif {$atom < 100} {
499            set key "CRS$phase  AT $atom"
500        } else {
501            set key "CRS$phase  AT$atom"
502        }
503        switch -glob ${parm}-$action {
504            type-get {
505                return [string trim [string range [readexp ${key}A] 2 9] ]
506            }
507            mult-get {
508                return [string trim [string range [readexp ${key}A] 58 61] ]
509            }
510            label-get {
511                return [string trim [string range [readexp ${key}A] 50 57] ]
512            }
513            label-set {
514                setexp ${key}A $value 51 8
515            }
516            temptype-get {
517                return [string trim [string range [readexp ${key}B] 62 62] ]
518            }
519            x-get {
520                return [string trim [string range [readexp ${key}A] 10 19] ]
521            }
522            x-set {
523                if ![validreal value 10 6] {return 0}
524                setexp ${key}A $value 11 10
525            }
526            y-get {
527                return [string trim [string range [readexp ${key}A] 20 29] ]
528            }
529            y-set {
530                if ![validreal value 10 6] {return 0}
531                setexp ${key}A $value 21 10
532            }
533            z-get {
534                return [string trim [string range [readexp ${key}A] 30 39] ]
535            }
536            z-set {
537                if ![validreal value 10 6] {return 0}
538                setexp ${key}A $value 31 10
539            }
540            frac-get {
541                return [string trim [string range [readexp ${key}A] 40 49] ]
542            }
543            frac-set {
544                if ![validreal value 10 6] {return 0}
545                setexp ${key}A $value 41 10
546            }
547            U*-get {
548                regsub U $parm {} type
549                if {$type == "iso" || $type == "11"} {
550                    return [string trim [string range [readexp ${key}B] 0 9] ]
551                } elseif {$type == "22"} {
552                    return [string trim [string range [readexp ${key}B] 10 19] ]
553                } elseif {$type == "33"} {
554                    return [string trim [string range [readexp ${key}B] 20 29] ]
555                } elseif {$type == "12"} {
556                    return [string trim [string range [readexp ${key}B] 30 39] ]
557                } elseif {$type == "23"} {
558                    return [string trim [string range [readexp ${key}B] 40 49] ]
559                } elseif {$type == "13"} {
560                    return [string trim [string range [readexp ${key}B] 50 59] ]
561                }
562            }
563            U*-set {
564                if ![validreal value 10 6] {return 0}
565                regsub U $parm {} type
566                if {$type == "iso" || $type == "11"} {
567                    setexp ${key}B $value 1 10
568                } elseif {$type == "22"} {
569                    setexp ${key}B $value 11 10
570                } elseif {$type == "33"} {
571                    setexp ${key}B $value 21 10
572                } elseif {$type == "12"} {
573                    setexp ${key}B $value 31 10
574                } elseif {$type == "23"} {
575                    setexp ${key}B $value 41 10
576                } elseif {$type == "13"} {
577                    setexp ${key}B $value 51 10
578                }
579            }
580            xref-get {
581                if {[string toupper [string range [readexp ${key}B] 64 64]] == "X"} {
582                    return 1
583                }
584                return 0
585            }
586            xref-set {
587                if $value {
588                    setexp ${key}B "X" 65 1
589                } else {
590                    setexp ${key}B " " 65 1
591                }           
592            }
593            xdamp-get {
594                set val [string range [readexp ${key}A] 64 64]
595                if {$val == " "} {return 0}
596                return $val
597            }
598            xdamp-set {
599                setexp ${key}A $value 65 1
600            }
601            fref-get {
602                if {[string toupper [string range [readexp ${key}B] 63 63]] == "F"} {
603                    return 1
604                }
605                return 0
606            }
607            fref-set {
608                if $value {
609                    setexp ${key}B "F" 64 1
610                } else {
611                    setexp ${key}B " " 64 1
612                }           
613            }
614            fdamp-get {
615                set val [string range [readexp ${key}A] 63 63]
616                if {$val == " "} {return 0}
617                return $val
618            }
619            fdamp-set {
620                setexp ${key}A $value 64 1
621            }
622
623            uref-get {
624                if {[string toupper [string range [readexp ${key}B] 65 65]] == "U"} {
625                    return 1
626                }
627                return 0
628            }
629            uref-set {
630                if $value {
631                    setexp ${key}B "U" 66 1
632                } else {
633                    setexp ${key}B " " 66 1
634                }           
635            }
636            udamp-get {
637                set val [string range [readexp ${key}A] 65 65]
638                if {$val == " "} {return 0}
639                return $val
640            }
641            udamp-set {
642                setexp ${key}A $value 66 1
643            }
644            default {
645                set msg "Unsupported atominfo access: parm=$parm action=$action"
646                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
647                destroy .
648            }
649        }
650    }
651    return 1
652}
653
654# get histogram information: histinfo histlist parm action value
655# histlist is a list of histogram numbers
656# parm:
657#     title
658#     scale (*)
659#     sref/sdamp -- refinement flag/damping value for the scale factor (*)
660#     lam1, lam2 (*)
661#     ttref refinement flag for the 2theta (ED Xray) (*)
662#     wref refinement flag for the wavelength (*)
663#     ratref refinement flag for the wavelength ratio (*)
664#     difc, difa -- TOF calibration constants (*)
665#     dcref,daref -- refinement flag for difc, difa (*)
666#     zero (*)
667#     zref refinement flag for the zero correction (*)
668#     ipola (*)
669#     pola (*)
670#     pref refinement flag for the polarization (*)
671#     kratio (*)
672#     ddamp -- damping value for the diffractometer constants (*)
673#     backtype -- background function number *
674#     backterms -- number of background terms *
675#     bref/bdamp -- refinement flag/damping value for the background (*)
676#     bterm$n -- background term #n (*)
677#     bank -- Bank number
678#     tofangle -- detector angle (TOF only)
679#     foextract  -- Fobs extraction flag (*)
680proc histinfo {histlist parm "action get" "value {}"} {
681    foreach hist $histlist {
682        if {$hist < 10} {
683            set key "HST  $hist"
684        } else {
685            set key "HST $hist"
686        }
687        switch -glob ${parm}-$action {
688            foextract-get {
689                if {[string toupper [string range [readexp "${key} EPHAS" ] 49 49]] == "T"} {
690                    return 1
691                }
692                return 0
693            }
694            foextract-set {
695                if $value {
696                    setexp "${key} EPHAS" "T" 50 1
697                } else {
698                    setexp "${key} EPHAS" "F" 50 1
699                }           
700            }
701            title-get {
702                return [string trim [readexp "${key}  HNAM"] ]
703            }
704            scale-get {
705                return [string trim [string range [readexp ${key}HSCALE] 0 14]]
706            }
707            scale-set {
708                if ![validreal value 15 6] {return 0}
709                setexp ${key}HSCALE $value 1 15
710            }
711            sref-get {
712                if {[string toupper [string range [readexp ${key}HSCALE] 19 19]] == "Y"} {
713                    return 1
714                }
715                return 0
716            }
717            sref-set {
718                if $value {
719                    setexp ${key}HSCALE "Y" 20 1
720                } else {
721                    setexp ${key}HSCALE "N" 20 1
722                }           
723            }
724            sdamp-get {
725                set val [string range [readexp ${key}HSCALE] 24 24]
726                if {$val == " "} {return 0}
727                return $val
728            }
729            sdamp-set {
730                setexp ${key}HSCALE $value 25 1
731            }
732
733            difc-get -
734            lam1-get {
735                return [string trim [string range [readexp "${key} ICONS"] 0 9]]
736            }
737            difc-set -
738            lam1-set {
739                if ![validreal value 10 7] {return 0}
740                setexp "${key} ICONS" $value 1 10
741            }
742            difa-get -
743            lam2-get {
744                return [string trim [string range [readexp "${key} ICONS"] 10 19]]
745            }
746            difa-set -
747            lam2-set {
748                if ![validreal value 10 7] {return 0}
749                setexp "${key} ICONS" $value 11 10
750            }
751            zero-get {
752                return [string trim [string range [readexp "${key} ICONS"] 20 29]]
753            }
754            zero-set {
755                if ![validreal value 10 5] {return 0}
756                setexp "${key} ICONS" $value 21 10
757            }
758            ipola-get {
759                return [string trim [string range [readexp "${key} ICONS"] 54 54]]
760            }
761            ipola-set {
762                if ![validint value 1] {return 0}
763                setexp "${key} ICONS" $value 55 1
764            }
765            pola-get {
766                return [string trim [string range [readexp "${key} ICONS"] 40 49]]
767            }
768            pola-set {
769                if ![validreal value 10 5] {return 0}
770                setexp "${key} ICONS" $value 41 10
771            }
772            kratio-get {
773                return [string trim [string range [readexp "${key} ICONS"] 55 64]]
774            }
775            kratio-set {
776                if ![validreal value 10 5] {return 0}
777                setexp "${key} ICONS" $value 56 10
778            }
779
780            wref-get {
781            #------------------------------------------------------
782            # col 33: refine flag for lambda, difc, ratio and theta
783            #------------------------------------------------------
784                if {[string toupper [string range \
785                        [readexp "${key} ICONS"] 32 32]] == "L"} {
786                    return 1
787                }
788                return 0
789            }
790            wref-set {
791                if $value {
792                    setexp "${key} ICONS" "L" 33 1
793                } else {
794                    setexp "${key} ICONS" " " 33 1
795                }           
796            }
797            ratref-get {
798                if {[string toupper [string range \
799                        [readexp "${key} ICONS"] 32 32]] == "R"} {
800                    return 1
801                }
802                return 0
803            }
804            ratref-set {
805                if $value {
806                    setexp "${key} ICONS" "R" 33 1
807                } else {
808                    setexp "${key} ICONS" " " 33 1
809                }           
810            }
811            dcref-get {
812                if {[string toupper [string range \
813                        [readexp "${key} ICONS"] 32 32]] == "C"} {
814                    return 1
815                }
816                return 0
817            }
818            dcref-set {
819                if $value {
820                    setexp "${key} ICONS" "C" 33 1
821                } else {
822                    setexp "${key} ICONS" " " 33 1
823                }           
824            }
825            ttref-get {
826                if {[string toupper [string range \
827                        [readexp "${key} ICONS"] 32 32]] == "T"} {
828                    return 1
829                }
830                return 0
831            }
832            ttref-set {
833                if $value {
834                    setexp "${key} ICONS" "T" 33 1
835                } else {
836                    setexp "${key} ICONS" " " 33 1
837                }           
838            }
839
840
841            pref-get {
842            #------------------------------------------------------
843            # col 34: refine flag for POLA & DIFA
844            #------------------------------------------------------
845                if {[string toupper [string range \
846                        [readexp "${key} ICONS"] 33 33]] == "P"} {
847                    return 1
848                }
849                return 0
850            }
851            pref-set {
852                if $value {
853                    setexp "${key} ICONS" "P" 34 1
854                } else {
855                    setexp "${key} ICONS" " " 34 1
856                }           
857            }
858            daref-get {
859                if {[string toupper [string range \
860                        [readexp "${key} ICONS"] 33 33]] == "A"} {
861                    return 1
862                }
863                return 0
864            }
865            daref-set {
866                if $value {
867                    setexp "${key} ICONS" "A" 34 1
868                } else {
869                    setexp "${key} ICONS" " " 34 1
870                }           
871            }
872
873            zref-get {
874            #------------------------------------------------------
875            # col 34: refine flag for zero correction
876            #------------------------------------------------------
877                if {[string toupper [string range [readexp "${key} ICONS"] 34 34]] == "Z"} {
878                    return 1
879                }
880                return 0
881            }
882            zref-set {
883                if $value {
884                    setexp "${key} ICONS" "Z" 35 1
885                } else {
886                    setexp "${key} ICONS" " " 35 1
887                }           
888            }
889
890            ddamp-get {
891                set val [string range [readexp "${key} ICONS"] 39 39]
892                if {$val == " "} {return 0}
893                return $val
894            }
895            ddamp-set {
896                setexp "${key} ICONS" $value 40 1
897            }
898
899            backtype-get {
900                set val [string trim [string range [readexp "${key}BAKGD "] 0 4]]
901                if {$val == " "} {return 0}
902                return $val
903            }
904            backtype-set {
905                if ![validint value 5] {return 0}
906                setexp "${key}BAKGD " $value 1 5
907            }
908            backterms-get {
909                set val [string trim [string range [readexp "${key}BAKGD "] 5 9]]
910                if {$val == " "} {return 0}
911                return $val
912            }
913            backterms-set {
914                # this takes a bit of work -- if terms are added, add lines as needed to the .EXP
915                set oldval [string trim [string range [readexp "${key}BAKGD "] 5 9]]
916                if ![validint value 5] {return 0}
917                if {$oldval < $value} {
918                    set line1  [expr 2 + ($oldval - 1) / 4]
919                    set line2  [expr 1 + ($value - 1) / 4]
920                    for {set i $line1} {$i <= $line2} {incr i} {
921                        # create a blank entry if needed
922                        makeexprec ${key}BAKGD$i
923                    }
924                    incr oldval
925                    for {set num $oldval} {$num <= $value} {incr num} {
926                        set f1 [expr 15*(($num - 1) % 4)]
927                        set f2 [expr 15*(1 + ($num - 1) % 4)-1]
928                        set line  [expr 1 + ($num - 1) / 4]
929                        if {[string trim [string range [readexp ${key}BAKGD$line] $f1 $f2]] == ""} {
930                            set f1 [expr 15*(($num - 1) % 4)+1]
931                            setexp ${key}BAKGD$line 0.0 $f1 15                 
932                        }
933                    }
934                }
935                setexp "${key}BAKGD " $value 6 5
936
937            }
938            bref-get {
939                if {[string toupper [string range [readexp "${key}BAKGD"] 14 14]] == "Y"} {
940                    return 1
941                }
942                return 0
943            }
944            bref-set {
945                if $value {
946                    setexp "${key}BAKGD "  "Y" 15 1
947                } else {
948                    setexp "${key}BAKGD "  "N" 15 1
949                }           
950            }
951            bdamp-get {
952                set val [string range [readexp "${key}BAKGD "] 19 19]
953                if {$val == " "} {return 0}
954                return $val
955            }
956            bdamp-set {
957                setexp "${key}BAKGD " $value 20 1
958            }
959            bterm*-get {
960                regsub bterm $parm {} num
961                set f1 [expr 15*(($num - 1) % 4)]
962                set f2 [expr 15*(1 + ($num - 1) % 4)-1]
963                set line  [expr 1 + ($num - 1) / 4]
964                return [string trim [string range [readexp ${key}BAKGD$line] $f1 $f2] ]
965            }
966            bterm*-set {
967                regsub bterm $parm {} num
968                if ![validreal value 15 6] {return 0}
969                set f1 [expr 15*(($num - 1) % 4)+1]
970                set line  [expr 1 + ($num - 1) / 4]
971                setexp ${key}BAKGD$line $value $f1 15
972            }
973            bank-get {
974                return [string trim [string range [readexp "${key} BANK"] 0 4]]
975            }
976            tofangle-get {
977                return [string trim [string range [readexp "${key}BNKPAR"] 10 19]]
978            }
979            default {
980                set msg "Unsupported histinfo access: parm=$parm action=$action"
981                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
982                destroy .
983            }
984        }
985    }
986    return 1
987}
988
989# read the information that differs by both histogram and phase (profile & phase fraction)
990# use: hapinfo hist phase parm action value
991# 
992#     frac -- phase fraction (*)
993#     frref/frdamp -- refinement flag/damping value for the phase fraction (*)
994#     proftype -- profile function number
995#     profterms -- number of profile terms
996#     pdamp -- damping value for the profile (*)
997#     pcut -- cutoff value for the profile (*)
998#     pterm$n -- profile term #n
999#     pref$n -- refinement flag value for profile term #n (*)
1000#     extmeth -- Fobs extraction method (*)
1001proc hapinfo {histlist phaselist parm "action get" "value {}"} {
1002    foreach phase $phaselist hist $histlist {
1003        if {$phase == ""} {set phase [lindex $phaselist end]}
1004        if {$hist == ""} {set hist [lindex $histlist end]}
1005        if {$hist < 10} {
1006            set hist " $hist"
1007        }
1008        set key "HAP${phase}${hist}"
1009        switch -glob ${parm}-$action {
1010            extmeth-get {
1011                set i1 [expr ($phase - 1)*5]
1012                set i2 [expr $i1 + 4]
1013                return [string trim [string range [readexp "HST $hist EPHAS"] $i1 $i2]]
1014            }
1015            extmeth-set {
1016                set i1 [expr ($phase - 1)*5 + 1]
1017                if ![validint value 5] {return 0}
1018                setexp "HST $hist EPHAS" $value $i1 5
1019            }
1020            frac-get {
1021                return [string trim [string range [readexp ${key}PHSFR] 0 14]]
1022            }
1023            frac-set {
1024                if ![validreal value 15 6] {return 0}
1025                setexp ${key}PHSFR $value 1 15
1026            }
1027            frref-get {
1028                if {[string toupper [string range [readexp ${key}PHSFR] 19 19]] == "Y"} {
1029                    return 1
1030                }
1031                return 0
1032            }
1033            frref-set {
1034                if $value {
1035                    setexp ${key}PHSFR "Y" 20 1
1036                } else {
1037                    setexp ${key}PHSFR "N" 20 1
1038                }           
1039            }
1040            frdamp-get {
1041                set val [string range [readexp ${key}PHSFR] 24 24]
1042                if {$val == " "} {return 0}
1043                return $val
1044            }
1045            frdamp-set {
1046                setexp ${key}PHSFR $value 25 1
1047            }
1048            proftype-get {
1049                set val [string range [readexp "${key}PRCF "] 0 4]
1050                if {$val == " "} {return 0}
1051                return $val
1052            }
1053            profterms-get {
1054                set val [string range [readexp "${key}PRCF "] 5 9]
1055                if {$val == " "} {return 0}
1056                return $val
1057            }
1058            pcut-get {
1059                return [string trim [string range [readexp "${key}PRCF "] 10 19]]
1060            }
1061            pcut-set {
1062                if ![validreal value 10 5] {return 0}
1063                setexp "${key}PRCF " $value 11 10
1064            }
1065            pdamp-get {
1066                set val [string range [readexp "${key}PRCF "] 24 24]
1067                if {$val == " "} {return 0}
1068                return $val
1069            }
1070            pdamp-set {
1071                setexp "${key}PRCF   " $value 25 1
1072            }
1073            pterm*-get {
1074                regsub pterm $parm {} num
1075                set f1 [expr 15*(($num - 1) % 4)]
1076                set f2 [expr 15*(1 + ($num - 1) % 4)-1]
1077                set line  [expr 1 + ($num - 1) / 4]
1078                return [string trim [string range [readexp "${key}PRCF $line"] $f1 $f2] ]
1079            }
1080            pterm*-set {
1081                if ![validreal value 15 6] {return 0}
1082                regsub pterm $parm {} num
1083                set f1 [expr 1+ 15*(($num - 1) % 4)]
1084                set line  [expr 1 + ($num - 1) / 4]
1085                setexp "${key}PRCF $line" $value $f1 15
1086            }
1087            pref*-get {
1088                regsub pref $parm {} num
1089                set f [expr 24+$num]
1090                if {[string toupper [string range [readexp "${key}PRCF  "] $f $f]] == "Y"} {
1091                    return 1
1092                }
1093                return 0
1094            }
1095            pref*-set {
1096                regsub pref $parm {} num
1097                set f [expr 25+$num]
1098                if $value {
1099                    setexp ${key}PRCF "Y" $f 1
1100                } else {
1101                    setexp ${key}PRCF "N" $f 1
1102                }           
1103            }
1104            default {
1105                set msg "Unsupported hapinfo access: parm=$parm action=$action"
1106                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
1107                destroy .
1108            }
1109        }
1110    }
1111    return 1
1112}
1113
1114# write the .EXP file
1115proc expwrite {expfile} {
1116    global tcl_platform exparray
1117    set blankline "                                                                   "
1118    set fp [open ${expfile} w]
1119    set keylist [lsort [array names exparray]]
1120    # reorder the keys so that VERSION comes 1st
1121    set pos [lsearch -exact $keylist {     VERSION}]
1122    set keylist "{     VERSION} [lreplace $keylist $pos $pos]"
1123    if {$tcl_platform(platform) == "windows"} { 
1124        foreach key $keylist {
1125            puts $fp [string range \
1126                    "$key$exparray($key)$blankline" 0 79]
1127        }
1128    } else {
1129        foreach key $keylist {
1130            puts -nonewline $fp [string range \
1131                    "$key$exparray($key)$blankline" 0 79]
1132        }
1133    }
1134    close $fp
1135}
Note: See TracBrowser for help on using the repository browser.