source: trunk/readexp.tcl @ 57

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

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