source: trunk/readexp.tcl @ 13

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

# on 1998/12/28 02:34:29, toby did:
fix bug -- set print option as 0 for missing entry.

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