source: trunk/readexp.tcl @ 19

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

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