source: trunk/readinst.tcl @ 803

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

# on 2004/09/20 15:29:14, toby did:
force all output to instfile to be in ASCII

this might solve bugs where non-ascii chars invalidate .EXP file

  • Property rcs:author set to toby
  • Property rcs:date set to 2004/09/20 15:29:14
  • Property rcs:lines set to +2 -2
  • Property rcs:rev set to 1.4
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 10.2 KB
Line 
1# $Id: readinst.tcl 803 2009-12-04 23:12:18Z toby $
2# Routines to deal with reading and writing instrument parameter files
3
4# test an argument if it is a valid number; reform the number to fit
5proc validreal {val length decimal} {
6    upvar $val value
7    if [catch {expr {$value}}] {return 0}
8    if [catch {
9        # for small values, switch to exponential notation
10        # 2 -> three sig figs.
11        set pow [expr 2 - $decimal]
12        if {abs($value) < pow(10,$pow) && $length > 6} {
13            if {$length - $decimal < 5} {set decimal [expr $length -5]}
14            set tmp [format "%${length}.${decimal}E" $value]
15        } else {
16            set tmp [format "%${length}.${decimal}f" $value]
17        }
18        # if the string will not fit, use scientific notation & drop
19        # digits, as needed
20        while {[string length $tmp] > $length && $decimal >= 0} {
21            # try to make it fit
22            set tmp [format "%${length}.${decimal}E" $value]
23            incr decimal -1
24        }
25        set value $tmp
26    }] {return 0}
27    return 1
28}
29
30# test an argument if it is a valid integer; reform the number into
31# an integer, if appropriate -- be sure to pass the name of the variable not the value
32proc validint {val length} {
33    upvar $val value
34    # FORTRAN type assumption: blank is 0
35    if {$value == ""} {set value 0}
36    if [catch {
37        set tmp [expr {round($value)}]
38        if {$tmp != $value} {return 0}
39        set value [format "%${length}d" $tmp]
40    }] {return 0}
41    return 1
42}
43
44proc instload {instfile} {
45    global instarray tcl_platform
46    if [catch {set fil [open "$instfile" r]}] {
47        tk_dialog .instFileErrorMsg "File Open Error" \
48                "Unable to open file $instfile" error 0 "Exit" 
49        return -1
50    }
51    fconfigure $fil -translation lf
52    set len [gets $fil line]
53    if {[string length $line] != $len} {
54        tk_dialog .instConvErrorMsg "old tcl" \
55                "You are using an old version of Tcl/Tk and your instrument parameter file has binary characters; run convstod or upgrade" \
56                error 0 "Exit"
57        return -1
58    }
59    catch {
60        unset instarray
61    }
62    if {$len > 160} {
63        set fmt 0
64        # a UNIX-type file
65        set i1 0
66        set i2 79
67        while {$i2 < $len} {
68            set nline [string range $line $i1 $i2]
69            incr i1 80
70            incr i2 80
71            set key [string range $nline 0 11]
72            set instarray($key) [string range $nline 12 end]
73        }
74    } else {
75        set fmt 1
76        while {$len > 0} {
77            set key [string range $line 0 11]
78            set instarray($key) [string range $line 12 79]
79            if {$len != 81 || [string range $line end end] != "\r"} {set fmt 2}
80            set len [gets $fil line]
81        }
82    }
83    close $fil
84    return $fmt
85}
86
87proc instInit {} {
88    global instarray
89    catch {unset instarray}
90    # create a blank key to show columns, not required but sort of a tradition
91    set key "            "
92    foreach i {1 2 3 4 5 6} {
93        append instarray($key) 1234567890
94    }
95}
96
97# write the instrument parameter file
98proc instwrite {instfile} {
99    global instarray
100    set blankline \
101     "                                                                        "
102    # count the number of "banks" and set the INS   BANK record accordingly
103    set i 1
104    set bank 0
105    while {[instexistsrec [format "INS%3d*" $i]] != 0} {
106        set bank $i
107        incr i
108    }
109    set key "INS   BANK"
110    if {[instexistsrec $key] == 0} {instmakerec $key}
111    set value $bank
112    validint value 5
113    instsetrec $key $value 1 5
114
115    # open the file and write all the records
116    set fp [open ${instfile} w]
117    fconfigure $fp -translation crlf -encoding ascii
118    set keylist [lsort [array names instarray]]
119    foreach key $keylist {
120        puts $fp [string range \
121                "$key$instarray($key)$blankline" 0 79]
122    }
123    close $fp
124}
125
126# return the value for a ISAM key
127proc instgetrec {key} {
128    global instarray
129    # truncate long keys & pad short ones
130    set key [string range "$key        " 0 11]
131    if [catch {set val $instarray($key)}] {
132        #global expgui
133        #if $expgui(debug) {puts "Error accessing record $key"}
134        return ""
135    }
136    return $val
137}
138
139# return the number of records matching ISAM key (may contain wildcards)
140proc instexistsrec {key} {
141    global instarray
142    # key can contain wild cards so don't pad
143    return [llength [array names instarray $key]]
144}
145
146# replace a section of the instarray with $value
147#   replace $char characters starting at character $start (numbered from 1)
148proc instsetrec {key value start chars} {
149    global instarray
150    # truncate long keys & pad short ones
151    set key [string range "$key        " 0 11]
152    if [catch {set instarray($key)}] {
153        #global expgui
154        #if $expgui(debug) {puts "Error accessing record $key"}
155        return ""
156    }
157
158    # pad value to $chars
159    set l0 [expr {$chars - 1}]
160    set value [string range "$value                                           " 0 $l0]
161
162    if {$start == 1} {
163        set ret {}
164        set l1 $chars
165    } else {
166        set l0 [expr {$start - 2}]
167        set l1 [expr {$start + $chars - 1}]
168        set ret [string range $instarray($key) 0 $l0]
169    }
170    append ret $value [string range $instarray($key) $l1 end]
171    set instarray($key) $ret
172}
173
174proc instmakerec {key} {
175    global instarray
176    # truncate long keys & pad short ones
177    set key [string range "$key        " 0 11]
178    if [catch {set instarray($key)}] {
179        # set to 68 blanks
180        set instarray($key) [format %68s " "]
181    }
182}
183
184# delete an inst record
185# returns 1 if OK; 0 if not found
186proc instdelrec {key} {
187    global instarray
188    # truncate long keys & pad short ones
189    set key [string range "$key        " 0 11]
190    if [catch {unset instarray($key)}] {
191        return 0
192    }
193    return 1
194}
195
196# get/set info from instrument parameter file
197#    bank & type
198proc instinfo {parm "action get" "value {}"} {
199    switch ${parm}-$action {
200        bank-get {
201           return [string trim [string range [instgetrec "INS   BANK"] 0 4]]
202        }
203        type-get {
204           return [string range [instgetrec "INS   HTYPE"] 2 5]
205        }
206        type-set {
207            set key "INS   HTYPE"
208            if {[instexistsrec $key] == 0} {instmakerec $key}
209            instsetrec $key $value 3 4     
210        }
211        default {
212            set msg "Unsupported instinfo access: parm=$parm action=$action"
213            tk_dialog .badinst "Error in instinfo" $msg error 0 Exit
214        }
215    }
216    return 1
217}
218
219# get/set parameters for a bank
220#   rad (radiation type) 0 to 5: other, Cr, Fe, Cu, Mo or Ag K
221
222#   header (spectrum header)
223#   name (used in GSAS2CIF)
224#   itype (incident spectrum type) "ITYP,TMIN,TMAX,CHKSUM"  (0, 0, 180, 1 for CW)
225#   icons (instrument constants)  "DIFC,DIFA,ZERO,POLA,IPOLA,KRATIO"
226#                                 "WAV1,WAV2,ZERO,POLA,IPOLA,KRATIO"
227
228proc instbankinfo {parm bank "action get" "value {}"} {
229    set key [format INS%3d $bank]
230    switch ${parm}-$action {
231        rad-get {
232            return [string trim [string range [instgetrec "${key} IRAD"] 0 4]]
233        }
234        rad-set {
235            append key " IRAD"
236            if {[instexistsrec $key] == 0} {instmakerec $key}
237            if ![validint value 5] {return 0}
238            instsetrec $key $value 1 5
239        }
240        head-get {
241            return [string trim [string range [instgetrec "${key}I HEAD"] 2 end]]
242        }
243        head-set {
244            append key "I HEAD"
245            if {[instexistsrec $key] == 0} {instmakerec $key}
246            instsetrec $key $value 3 68
247        }
248        name-get {
249            return [string trim [string range [instgetrec "${key}INAME"] 2 end]]
250        }
251        name-set {
252            append key "INAME"
253            if {[instexistsrec $key] == 0} {instmakerec $key}
254            instsetrec $key $value 3 68
255        }
256        itype-get {
257            set line [instgetrec "${key}I ITYP"]
258            return [list \
259                    [string trim [string range $line 0 4]] \
260                    [string trim [string range $line 5 14]] \
261                    [string trim [string range $line 15 24]] \
262                    [string trim [string range $line 30 34]] \
263                    ]
264        }
265        itype-set {
266            append key "I ITYP"
267            if {[instexistsrec $key] == 0} {instmakerec $key}
268            set line {}
269            foreach v $value fmt "%5d %10.4f %10.4f %10d" {
270                if {[catch {
271                    if {[string trim $v] == ""} {set v 0}
272                    append line [format $fmt $v]
273                } err]} {catch {puts $err}; return 0}
274            }
275            instsetrec $key $line 1 35
276        }
277        icons-get {
278            set line [instgetrec "${key} ICONS"]
279            return [list \
280                    [string trim [string range $line 0 9]] \
281                    [string trim [string range $line 10 19]] \
282                    [string trim [string range $line 20 29]] \
283                    [string trim [string range $line 40 49]] \
284                    [string trim [string range $line 50 54]] \
285                    [string trim [string range $line 55 64]] \
286                    ]
287        }
288        icons-set {
289            append key " ICONS"
290            if {[instexistsrec $key] == 0} {instmakerec $key}
291            set line {}
292            foreach v $value \
293                    fmt {%10.4f %10.4f %10.4f "          %10.3f" %5d %10.3f} {
294                if {[catch {
295                    if {[string trim $v] == ""} {set v 0}
296                    append line [format $fmt $v]
297                } err]} {return 0}
298            }
299            instsetrec $key $line 1 65
300        }
301        default {
302            set msg "Unsupported instinfo access: parm=$parm action=$action"
303            tk_dialog .badinst "Error in instbankinfo" $msg error 0 Exit
304        }
305    }
306    return 1
307}
308
309# read and set the profile terms
310proc instprofinfo {bank profile "action get" "value {}"} {
311    set key [format INS%3d $bank]PRCF[format %1d $profile]
312    if {$action == "get"} {
313        if {[instexistsrec "$key "] == 0} {return}
314        set line [instgetrec "${key} "]
315        set type [string trim [string range $line 0 4]]
316        set terms [string trim [string range $line 5 9]]
317        if {$terms == ""} {set terms 0}
318        set cutoff [string trim [string range $line 10 19]]
319        set termlist {}
320        catch {
321            set i 1
322            set j 0
323            while {$j < $terms} {
324                if {($j % 4) == 0} {
325                    set line {}
326                    if {[instexistsrec "$key "] != 0} {
327                        set line [instgetrec "${key}$i"]
328                    }
329                }
330                set col1 [expr {($j % 4) * 15}]
331                set col2 [expr {$col1 + 15}]
332                set p [string trim [string range $line $col1 $col2]]
333                if {$p == ""} {set p 0.0}
334                lappend termlist $p
335                if {($j % 4) == 3} {
336                    incr i
337                }
338                incr j
339            }
340        }
341        return [list $type $cutoff $termlist]
342    } elseif {$action == "set"} {
343        if {[instexistsrec "$key "] == 0} {instmakerec "$key "}
344        foreach {type cutoff termlist} $value {}
345        set terms [llength $termlist]
346        if ![validint type 5] {return 0}
347        if ![validint terms 5] {return 0}
348        if ![validreal cutoff 10 5] {return 0}
349        instsetrec "$key " ${type}${terms}${cutoff} 1 20
350        set line {}
351        set j 1
352        set i 0
353        foreach p $termlist {
354            if {$i == 4} {
355                set i 0
356                set key1 ${key}$j
357                if {[instexistsrec $key1] == 0} {instmakerec $key1}
358                instsetrec $key1 $line 1 60
359                set line {}
360                incr j
361            }
362            if ![validreal p 15 6] {return 0}
363            append line $p
364            incr i
365        }
366        set key1 ${key}$j
367        if {[instexistsrec $key1] == 0} {instmakerec $key1}
368        instsetrec $key1 $line 1 60
369    } else {
370        set msg "Unsupported instinfo access: action=$action"
371        tk_dialog .badinst "Error in instprofinfo" $msg error 0 Exit
372    }
373    return 1
374}
Note: See TracBrowser for help on using the repository browser.