source: trunk/readexp.tcl @ 236

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

# on 2000/07/20 22:09:56, toby did:
Add odf (spherical harmonic) support
move March-Dollase support here from orient
  • Property rcs:author set to toby
  • Property rcs:date set to 2000/07/20 22:09:56
  • Property rcs:lines set to +344 -5
  • Property rcs:rev set to 1.17
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 53.2 KB
Line 
1# $Id: readexp.tcl 236 2009-12-04 23:02:40Z toby $
2# Routines to deal with the .EXP "data structure"
3set expmap(Revision) {$Revision: 236 $ $Date: 2009-12-04 23:02:40 +0000 (Fri, 04 Dec 2009) $}
4
5#  The GSAS data is read from an EXP file.
6#   ... reading an EXP file into an array
7proc expload {expfile} {
8    global exparray
9    # $expfile is the path to the data file.
10    if [catch {set fil [open "$expfile" r]}] {
11        tk_dialog .expFileErrorMsg "File Open Error" \
12                "Unable to open file $expfile" error 0 "Exit" ; return -1
13    }
14    set len [gets $fil line]
15    if {[string length $line] != $len} {
16        tk_dialog .expConvErrorMsg "old tcl" \
17                "You are using an old version of Tcl/Tk and your .EXP file has binary characters; run convstod or upgrade" \
18                error 0 "Exit"
19        return -1
20    }
21    catch {
22        unset exparray
23    }
24    if {$len > 160} {
25        set fmt 0
26        # a UNIX-type file
27        set i1 0
28        set i2 79
29        while {$i2 < $len} {
30            set nline [string range $line $i1 $i2]
31            incr i1 80
32            incr i2 80
33            set key [string range $nline 0 11]
34            set exparray($key) [string range $nline 12 end]
35        }
36    } else {
37        set fmt 1
38        while {$len > 0} {
39            set key [string range $line 0 11]
40            set exparray($key) [string range $line 12 end]
41            set len [gets $fil line]
42        }
43    }
44    close $fil
45    return $fmt
46}
47
48proc createexp {expfile title} {
49    global exparray expmap
50    catch {unset exparray}
51    foreach key   {"     VERSION" "      DESCR" "ZZZZZZZZZZZZ" " EXPR NPHAS"} \
52            value {"   6"         ""            "  Last EXP file record" ""} {
53        # truncate long keys & pad short ones
54        set key [string range "$key        " 0 11]
55        set exparray($key) $value
56    }
57    expinfo title set $title
58    exphistory add " created readexp.tcl [lindex $expmap(Revision) 1] [clock format [clock seconds]]"
59    expwrite $expfile
60}
61
62# get information out from an EXP file
63#   creates the following entries in global array expmap
64#     expmap(phaselist)     gives a list of defined phases
65#     expmap(phasetype)     gives the phase type for each defined phase
66#                           =1 nuclear; 2 mag+nuc; 3 mag; 4 macro
67#     expmap(atomlist_$p)   gives a list of defined atoms in phase $p
68#     expmap(htype_$n)      gives the GSAS histogram type for histogram
69#     expmap(powderlist)    gives a list of powder histograms
70#     expmap(phaselist_$n)  gives a list of phases used in histogram $n
71#
72proc mapexp {} {
73    global expmap exparray
74    # clear out the old array
75    set expmap_Revision $expmap(Revision)
76    unset expmap
77    set expmap(Revision) $expmap_Revision
78    # get the defined phases
79    set line [readexp " EXPR NPHAS"]
80#    if {$line == ""} {
81#       set msg "No EXPR NPHAS entry. This is an invalid .EXP file"
82#       tk_dialog .badexp "Error in EXP" $msg error 0 Exit
83#       destroy .
84#    }
85    set expmap(phaselist) {}
86    set expmap(phasetype) {}
87    # loop over phases
88    foreach iph {1 2 3 4 5 6 7 8 9} {
89        set i5s [expr ($iph - 1)*5]
90        set i5e [expr $i5s + 4]
91        set flag [string trim [string range $line $i5s $i5e]]
92        if {$flag == ""} {set flag 0}
93        if $flag {
94            lappend expmap(phaselist) $iph
95            lappend expmap(phasetype) $flag
96        }
97    }
98    # get the list of defined atoms for each phase
99    foreach iph $expmap(phaselist) {
100        set expmap(atomlist_$iph) {}
101        foreach key [array names exparray "CRS$iph  AT*A"] {
102            regexp { AT *([0-9]+)A} $key a num
103            lappend expmap(atomlist_$iph) $num
104        }
105        # note that sometimes an .EXP file contains more atoms than are actually defined
106        # drop the extra ones
107        set expmap(atomlist_$iph) [lsort -integer $expmap(atomlist_$iph)]
108        set natom [phaseinfo $iph natoms]
109        if {$natom != [llength $expmap(atomlist_$iph)]} {
110            set expmap(atomlist_$iph) [lrange $expmap(atomlist_$iph) 0 [expr $natom-1]]
111        }
112    }
113    # now get the histogram types
114    set nhist [string trim [readexp { EXPR  NHST }]]
115    set n 0
116    set expmap(powderlist) {}
117    for {set i 0} {$i < $nhist} {incr i} {
118        set ihist [expr $i + 1]
119        if {[expr $i % 12] == 0} {
120            incr n
121            set line [readexp " EXPR  HTYP$n"]
122            if {$line == ""} {
123                set msg "No HTYP$n entry for Histogram $ihist. This is an invalid .EXP file"
124                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
125                destroy .
126            }
127            set j 0
128        } else {
129            incr j
130        }
131        set expmap(htype_$ihist) [lindex $line $j]
132        # at least for now, ignore non-powder histograms
133        if {[string range $expmap(htype_$ihist) 0 0] == "P" && \
134                [string range $expmap(htype_$ihist) 3 3] != "*"} {
135            lappend expmap(powderlist) $ihist
136        }
137    }
138
139    # now process powder histograms
140    foreach ihist $expmap(powderlist) {
141        # make a 2 digit key -- hh
142        if {$ihist < 10} {
143            set hh " $ihist"
144        } else {
145            set hh $ihist
146        }
147        set line [readexp "HST $hh NPHAS"]
148        if {$line == ""} {
149            set msg "No NPHAS entry for Histogram $ihist. This is an invalid .EXP file"
150            tk_dialog .badexp "Error in EXP" $msg error 0 Exit
151            destroy .
152        }
153        set expmap(phaselist_$ihist) {}
154        # loop over phases
155        foreach iph {1 2 3 4 5 6 7 8 9} {
156            set i5s [expr ($iph - 1)*5]
157            set i5e [expr $i5s + 4]
158            set flag [string trim [string range $line $i5s $i5e]]
159            if {$flag == ""} {set flag 0}
160            if $flag {lappend expmap(phaselist_$ihist) $iph}
161        }
162    }
163}
164
165# return the value for a ISAM key
166proc readexp {key} {
167    global exparray
168    # truncate long keys & pad short ones
169    set key [string range "$key        " 0 11]
170    if [catch {set val $exparray($key)}] {
171        global expgui
172        if $expgui(debug) {puts "Error accessing record $key"}
173        return ""
174    }
175    return $val
176}
177
178# return the number of records matching ISAM key (may contain wildcards)
179proc existsexp {key} {
180    global exparray
181    # key can contain wild cards so don't pad
182    return [llength [array names exparray  $key]]
183}
184
185
186# replace a section of the exparray with $value
187#   replace $char characters starting at character $start (numbered from 1)
188proc setexp {key value start chars} {
189    global exparray
190    # truncate long keys & pad short ones
191    set key [string range "$key        " 0 11]
192    if [catch {set exparray($key)}] {
193        global expgui
194        if $expgui(debug) {puts "Error accessing record $key"}
195        return ""
196    }
197
198    # pad value to $chars
199    set l0 [expr $chars - 1]
200    set value [string range "$value                                           " 0 $l0]
201
202    if {$start == 1} {
203        set ret {}
204        set l1 $chars
205    } else {
206        set l0 [expr $start - 2]
207        set l1 [expr $start + $chars - 1]
208        set ret [string range $exparray($key) 0 $l0]
209    }
210    append ret $value [string range $exparray($key) $l1 end]
211    set exparray($key) $ret
212}
213
214proc makeexprec {key} {
215    global exparray
216    # truncate long keys & pad short ones
217    set key [string range "$key        " 0 11]
218    if [catch {set exparray($key)}] {
219        # set to 68 blanks
220        set exparray($key) [format %68s " "]
221    }
222}
223
224# delete an exp record
225# returns 1 if OK; 0 if not found
226proc delexp {key} {
227    global exparray
228    # truncate long keys & pad short ones
229    set key [string range "$key        " 0 11]
230    if [catch {unset exparray($key)}] {
231        return 0
232    }
233    return 1
234}
235# test an argument if it is a valid number; reform the number to fit
236proc validreal {val length decimal} {
237    upvar $val value
238    if [catch {expr $value}] {return 0}
239    if [catch {
240        set tmp [format "%${length}.${decimal}f" $value]
241        while {[string length $tmp] > $length} {
242            set tmp [format "%${length}.${decimal}E" $value]
243            incr decimal -1
244        }
245        set value $tmp
246    }] {return 0}
247    return 1
248}
249
250# test an argument if it is a valid integer; reform the number into
251# an integer, if appropriate -- be sure to pass the name of the variable not the value
252proc validint {val length} {
253    upvar $val value
254    # FORTRAN type assumption: blank is 0
255    if {$value == ""} {set value 0}
256    set tmp [expr round($value)]
257    if {$tmp != $value} {return 0}
258    if [catch {
259        set value [format "%${length}d" $tmp]
260    }] {return 0}
261    return 1
262}
263
264# process history information
265#    action == last
266#       returns number and value of last record
267#    action == add
268#
269proc exphistory {action "value 0"} {
270    global exparray
271    if {$action == "last"} {
272        set key [lindex [lsort -decreasing [array names exparray *HSTRY*]] 0]
273        if {$key == ""} {return ""}
274        return [list [string trim [string range $key 9 end]] $exparray($key)]
275    } elseif {$action == "add"} {
276        set key [lindex [lsort -decreasing [array names exparray *HSTRY*]] 0]
277        if {$key == ""} {
278            set index 1
279        } else {
280            set index [string trim [string range $key 9 end]]
281            if {$index != "***"} {
282                if {$index < 999} {incr index}
283                set key [format "    HSTRY%3d" $index]
284                set exparray($key) $value
285            }
286        }
287        set key [format "    HSTRY%3d" $index]
288        set exparray($key) $value
289    }
290}
291# get overall info
292#   parm:
293#     print     -- GENLES print option (*)
294#     cycles    -- number of GENLES cycles (*)
295#     title     -- the overall title (*)
296proc expinfo {parm "action get" "value {}"} {
297    switch ${parm}-$action {
298        title-get {
299            return [string trim [readexp "      DESCR"]]
300        }
301        title-set {
302            setexp "      DESCR" "  $value" 2 68
303        }
304
305        cycles-get {
306            return [string trim [cdatget MXCY]]
307        }
308        cycles-set {
309            if ![validint value 1] {return 0}
310            cdatset MXCY [format %4d $value]
311        }
312        print-get {
313            set print [string trim [cdatget PRNT]]
314            if {$print != ""} {return $print}
315            return 0
316        }
317        print-set {
318            if ![validint value 1] {return 0}
319            cdatset PRNT [format %3d $value]
320        }
321        default {
322            set msg "Unsupported expinfo access: parm=$parm action=$action"
323            tk_dialog .badexp "Error in EXP" $msg error 0 Exit
324            destroy .
325        }
326    }
327    return 1
328}
329
330proc cdatget {key} {
331    foreach i {1 2 3 4 5 6 7 8 9} {
332        if {[existsexp "  GNLS CDAT$i"] == 0} break
333        set line [readexp "  GNLS CDAT$i"]
334        if {$line == {}} break
335        foreach i1 {2 10 18 26 34 42 50 58 66} \
336                i2 {9 17 25 33 41 49 57 65 73} {
337            set item [string range $line $i1 $i2]
338            if {[string trim $item] == {}} continue
339            if [regexp "${key}(.*)" $item a b] {return $b}
340        }
341    }
342    return {}
343}
344
345proc cdatset {key value} {
346    # round 1 see if we can find the string
347    foreach i {1 2 3 4 5 6 7 8 9} {
348        set line [readexp "  GNLS CDAT$i"]
349        if {$line == {}} break
350        foreach i1 {2 10 18 26 34 42 50 58 66} \
351                i2 {9 17 25 33 41 49 57 65 73} {
352            set item [string range $line $i1 $i2]
353            if {[string trim $item] == {}} continue
354            if [regexp "${key}(.*)" $item a b] {
355                # found it now replace it
356                incr i1
357                setexp "  GNLS CDAT$i" "${key}${value}" $i1 8
358                return
359            }
360        }
361    }
362    # not found, take the 1st blank space, creating a card if needed
363    foreach i {1 2 3 4 5 6 7 8 9} {
364        set line [readexp "  GNLS CDAT$i"]
365        if {$line == {}} {makeexprec "  GNLS CDAT$i"}
366        foreach i1 {2 10 18 26 34 42 50 58 66} \
367                i2 {9 17 25 33 41 49 57 65 73} {
368            set item [string range $line $i1 $i2]
369            if {[string trim $item] == {}} {
370                # found a blank space: now replace it
371                incr i1
372                setexp "  GNLS CDAT$i" "${key}${value}" $i1 8
373                return
374            }
375        }
376    }
377    return {}
378}
379
380# get phase information: phaseinfo phase parm action value
381#   phase: 1 to 9 (as defined)
382#   parm:
383#     name -- phase name
384#     natoms -- number of atoms
385#     a b c alpha beta gamma -- cell parameters (*)
386#     cellref -- refinement flag for the unit cell(*)
387#     celldamp  -- damping for the unit cell refinement (*)
388#     spacegroup -- space group symbol
389#     ODForder -- spherical harmonic order (*)
390#     ODFsym   -- sample symmetry (0-3) (*)
391#     ODFdampA -- damping for angles (*)
392#     ODFdampC -- damping for coefficients (*)
393#     ODFomega -- omega oriention angle (*)
394#     ODFchi -- chi oriention angle (*)
395#     ODFphi -- phi oriention angle (*)
396#     ODFomegaRef -- refinement flag for omega (*)
397#     ODFchiRef -- refinement flag for chi (*)
398#     ODFphiRef -- refinement flag for phi (*)
399#     ODFterms -- a list of the {l m n} values for each ODF term (*)
400#     ODFcoefXXX -- the ODF coefficient for for ODF term XXX (*)
401#     ODFRefcoef -- refinement flag for ODF terms (*)
402#  action: get (default) or set
403#  value: used only with set
404#  * =>  read+write supported
405proc phaseinfo {phase parm "action get" "value {}"} {
406    switch -glob ${parm}-$action {
407
408        name-get {
409            return [string trim [readexp "CRS$phase    PNAM"]]
410        }
411
412        spacegroup-get {
413            return [string trim [readexp "CRS$phase  SG SYM"]]
414        }
415
416        name-set {
417            setexp "CRS$phase    PNAM" " $value" 2 68
418        }
419
420        natoms-get {
421            return [string trim [readexp "CRS$phase   NATOM"]]     
422        }
423
424        a-get {
425           return [string trim [string range [readexp "CRS$phase  ABC"] 0 9]]
426        }
427        b-get {
428           return [string trim [string range [readexp "CRS$phase  ABC"] 10 19]]
429        }
430        c-get {
431           return [string trim [string range [readexp "CRS$phase  ABC"] 20 29]]
432        }
433        alpha-get {
434           return [string trim [string range [readexp "CRS$phase  ANGLES"] 0 9]]
435        }
436        beta-get {
437           return [string trim [string range [readexp "CRS$phase  ANGLES"] 10 19]]
438        }
439        gamma-get {
440           return [string trim [string range [readexp "CRS$phase  ANGLES"] 20 29]]
441        }
442
443        a-set {
444            if ![validreal value 10 6] {return 0}
445            setexp "CRS$phase  ABC" $value 1 10             
446        }
447        b-set {
448            if ![validreal value 10 6] {return 0}
449            setexp "CRS$phase  ABC" $value 11 10           
450        }
451        c-set {
452            if ![validreal value 10 6] {return 0}
453            setexp "CRS$phase  ABC" $value 21 10           
454        }
455        alpha-set {
456            if ![validreal value 10 4] {return 0}
457            setexp "CRS$phase  ANGLES" $value 1 10         
458        }
459        beta-set {
460            if ![validreal value 10 4] {return 0}
461            setexp "CRS$phase  ANGLES" $value 11 10         
462        }
463        gamma-set {
464            if ![validreal value10 4] {return 0}
465            setexp "CRS$phase  ANGLES" $value 21 10         
466        }
467        cellref-get {
468            if {[string toupper [string range [readexp "CRS$phase  ABC"] 34 34]] == "Y"} {
469                return 1
470            }
471            return 0
472        }
473        cellref-set {
474            if $value {
475                setexp "CRS$phase  ABC" "Y" 35 1
476            } else {
477                setexp "CRS$phase  ABC" "N" 35 1
478            }       
479        }
480        celldamp-get {
481            set val [string range [readexp "CRS$phase  ABC"] 39 39]
482            if {$val == " "} {return 0}
483            return $val
484        }
485        celldamp-set {
486            setexp "CRS$phase  ABC" $value 40 1
487        }
488
489        ODForder-get {
490            set val [string trim [string range [readexp "CRS$phase  ODF"] 0 4]]
491            if {$val == " "} {return 0}
492            return $val
493        }
494        ODForder-set {
495            if ![validint value 5] {return 0}
496            setexp "CRS$phase  ODF" $value 1 5
497        }
498        ODFsym-get {
499            set val [string trim [string range [readexp "CRS$phase  ODF"] 10 14]]
500            if {$val == " "} {return 0}
501            return $val
502        }
503        ODFsym-set {
504            if ![validint value 5] {return 0}
505            setexp "CRS$phase  ODF" $value 11 5
506        }
507        ODFdampA-get {
508            set val [string range [readexp "CRS$phase  ODF"] 24 24]
509            if {$val == " "} {return 0}
510            return $val
511        }
512        ODFdampA-set {
513            setexp "CRS$phase  ODF" $value 25 1
514        }
515        ODFdampC-get {
516            set val [string range [readexp "CRS$phase  ODF"] 29 29]
517            if {$val == " "} {return 0}
518            return $val
519        }
520        ODFdampC-set {
521            setexp "CRS$phase  ODF" $value 30 1
522        }
523        ODFomegaRef-get {
524            if {[string toupper [string range [readexp "CRS$phase  ODF"] 16 16]] == "Y"} {
525                return 1
526            }
527            return 0
528        }
529        ODFomegaRef-set {
530            if $value {
531                setexp "CRS$phase  ODF" "Y" 17 1
532            } else {
533                setexp "CRS$phase  ODF" "N" 17 1
534            }       
535        }
536        ODFchiRef-get {
537            if {[string toupper [string range [readexp "CRS$phase  ODF"] 17 17]] == "Y"} {
538                return 1
539            }
540            return 0
541        }
542        ODFchiRef-set {
543            if $value {
544                setexp "CRS$phase  ODF" "Y" 18 1
545            } else {
546                setexp "CRS$phase  ODF" "N" 18 1
547            }       
548        }
549        ODFphiRef-get {
550            if {[string toupper [string range [readexp "CRS$phase  ODF"] 18 18]] == "Y"} {
551                return 1
552            }
553            return 0
554        }
555        ODFphiRef-set {
556            if $value {
557                setexp "CRS$phase  ODF" "Y" 19 1
558            } else {
559                setexp "CRS$phase  ODF" "N" 19 1
560            }       
561        }
562        ODFcoef*-get {
563            regsub ODFcoef $parm {} term
564            set k [expr ($term+5)/6]
565            if {$k <= 9} {set k " $k"}
566            set j [expr (($term-1) % 6)+1]
567            set lineB [readexp "CRS$phase  ODF${k}B"]
568            set j0 [expr  ($j-1) *10]
569            set j1 [expr $j0 + 9]
570            set val [string trim [string range $lineB $j0 $j1]]
571            if {$val == ""} {return 0.0}
572            return $val
573        }
574        ODFcoef*-set {
575            regsub ODFcoef $parm {} term
576            if ![validreal value 10 3] {return 0}
577            set k [expr ($term+5)/6]
578            if {$k <= 9} {set k " $k"}
579            set j [expr (($term-1) % 6)+1]
580            set col [expr  ($j-1)*10 + 1]
581            setexp "CRS$phase  ODF${k}B" $value $col 10
582        }
583        ODFRefcoef-get {
584            if {[string toupper [string range [readexp "CRS$phase  ODF"] 19 19]] == "Y"} {
585                return 1
586            }
587            return 0
588        }
589        ODFRefcoef-set {
590            if $value {
591                setexp "CRS$phase  ODF" "Y" 20 1
592            } else {
593                setexp "CRS$phase  ODF" "N" 20 1
594            }       
595        }
596        ODFomega-get {
597           return [string trim [string range [readexp "CRS$phase  ODF"] 30 39]]
598        }
599        ODFchi-get {
600           return [string trim [string range [readexp "CRS$phase  ODF"] 40 49]]
601        }
602        ODFphi-get {
603           return [string trim [string range [readexp "CRS$phase  ODF"] 50 59]]
604        }
605        ODFomega-set {
606            if ![validreal value 10 4] {return 0}
607            setexp "CRS$phase  ODF" $value 31 10
608        }
609        ODFchi-set {
610            if ![validreal value 10 4] {return 0}
611            setexp "CRS$phase  ODF" $value 41 10
612        }
613        ODFphi-set {
614            if ![validreal value 10 4] {return 0}
615            setexp "CRS$phase  ODF" $value 51 10
616        }
617
618        ODFterms-get {
619            set vallist {}
620            set val [string trim [string range [readexp "CRS$phase  ODF"] 5 9]]
621            for {set i 1} {$i <= $val} {incr i 6} {
622                set k [expr 1+($i-1)/6]
623                if {$k <= 9} {set k " $k"}
624                set lineA [readexp "CRS$phase  ODF${k}A"]
625                set k 0
626                for {set j $i} {$j <= $val && $j < $i+6} {incr j} {
627                    set j0 [expr ($k)*10]
628                    set j1 [expr $j0 + 9]
629                    lappend vallist [string trim [string range $lineA $j0 $j1]]
630                    incr k
631                }
632            }
633            return $vallist
634        }
635        ODFterms-set {
636            set key "CRS$phase  ODF   "
637            if {![existsexp $key]} {
638                makeexprec $key
639                set oldlen 0
640            } else {
641                set oldlen [string trim [string range [readexp $key] 5 9]]
642            }
643            set len [llength $value]
644            if ![validint len 5] {return 0}
645            setexp $key $len 6 5
646            set j 0
647            set k 0
648            foreach item $value {
649                incr j
650                if {$j % 6 == 1} {
651                    incr k
652                    if {$k <= 9} {set k " $k"}
653                    set col 1
654                    set keyA "CRS$phase  ODF${k}A"
655                    set keyB "CRS$phase  ODF${k}B"
656                    if {![existsexp $keyA]} {
657                        makeexprec $keyA
658                        makeexprec $keyB
659                    }
660                }
661                set col1 [expr $col + 1]
662                foreach n [lrange $item 0 2] {
663                    if ![validint n 3] {return 0}
664                    setexp $keyA $n $col1 3
665                    incr col1 3
666                }
667                incr col 10
668            }
669            for {incr j} {$j <= $oldlen} {incr j} {
670                if {$j % 6 == 1} {
671                    incr k
672                    if {$k <= 9} {set k " $k"}
673                    set col 1
674                    set keyA "CRS$phase  ODF${k}A"
675                    set keyB "CRS$phase  ODF${k}B"
676                    delexp $keyA
677                    delexp $keyB
678                }
679                if {[existsexp $keyA]} {
680                    setexp $keyA "          " $col 10
681                    setexp $keyB "          " $col 10
682                }
683                incr col 10
684            }
685        }
686
687        default {
688            set msg "Unsupported phaseinfo access: parm=$parm action=$action"
689            tk_dialog .badexp "Error in EXP" $msg error 0 Exit
690#           destroy .
691        }
692    }
693    return 1
694}
695
696
697# get atom information: atominfo phase atom parm action value
698#   phase: 1 to 9 (as defined)
699#   atom: a valid atom number [see expmap(atomlist_$phase)]
700#      Note that atom and phase can be paired lists, but if there are extra
701#      entries in the atoms list, the last phase will be repeated.
702#      so that atominfo 1 {1 2 3} xset 1
703#               will set the xflag for atoms 1-3 in phase 1
704#      but atominfo {1 2 3} {1 1 1} xset 1
705#               will set the xflag for atoms 1 in phase 1-3
706#   parm:
707#     type -- element code
708#     mult -- atom multiplicity
709#     label -- atom label (*)
710#     x y z -- coordinates (*)
711#     frac --  occupancy (*)
712#     temptype -- I or A for Isotropic/Anisotropic
713#     Uiso  -- Isotropic temperature factor (*)
714#     U11  -- Anisotropic temperature factor (*)
715#     U22  -- Anisotropic temperature factor (*)
716#     U33  -- Anisotropic temperature factor (*)
717#     U12  -- Anisotropic temperature factor (*)
718#     U13  -- Anisotropic temperature factor (*)
719#     U23  -- Anisotropic temperature factor (*)
720#     xref/xdamp -- refinement flag/damping value for the coordinates (*)
721#     uref/udamp -- refinement flag/damping value for the temperature factor(s)  (*)
722#     fref/fdamp -- refinement flag/damping value for the occupancy (*)
723#  action: get (default) or set
724#  value: used only with set
725#  * =>  read+write supported
726
727proc atominfo {phaselist atomlist parm "action get" "value {}"} {
728    foreach phase $phaselist atom $atomlist {
729        if {$phase == ""} {set phase [lindex $phaselist end]}
730        if {$atom < 10} {
731            set key "CRS$phase  AT  $atom"
732        } elseif {$atom < 100} {
733            set key "CRS$phase  AT $atom"
734        } else {
735            set key "CRS$phase  AT$atom"
736        }
737        switch -glob ${parm}-$action {
738            type-get {
739                return [string trim [string range [readexp ${key}A] 2 9] ]
740            }
741            mult-get {
742                return [string trim [string range [readexp ${key}A] 58 61] ]
743            }
744            label-get {
745                return [string trim [string range [readexp ${key}A] 50 57] ]
746            }
747            label-set {
748                setexp ${key}A $value 51 8
749            }
750            temptype-get {
751                return [string trim [string range [readexp ${key}B] 62 62] ]
752            }
753            x-get {
754                return [string trim [string range [readexp ${key}A] 10 19] ]
755            }
756            x-set {
757                if ![validreal value 10 6] {return 0}
758                setexp ${key}A $value 11 10
759            }
760            y-get {
761                return [string trim [string range [readexp ${key}A] 20 29] ]
762            }
763            y-set {
764                if ![validreal value 10 6] {return 0}
765                setexp ${key}A $value 21 10
766            }
767            z-get {
768                return [string trim [string range [readexp ${key}A] 30 39] ]
769            }
770            z-set {
771                if ![validreal value 10 6] {return 0}
772                setexp ${key}A $value 31 10
773            }
774            frac-get {
775                return [string trim [string range [readexp ${key}A] 40 49] ]
776            }
777            frac-set {
778                if ![validreal value 10 6] {return 0}
779                setexp ${key}A $value 41 10
780            }
781            U*-get {
782                regsub U $parm {} type
783                if {$type == "iso" || $type == "11"} {
784                    return [string trim [string range [readexp ${key}B] 0 9] ]
785                } elseif {$type == "22"} {
786                    return [string trim [string range [readexp ${key}B] 10 19] ]
787                } elseif {$type == "33"} {
788                    return [string trim [string range [readexp ${key}B] 20 29] ]
789                } elseif {$type == "12"} {
790                    return [string trim [string range [readexp ${key}B] 30 39] ]
791                } elseif {$type == "13"} {
792                    return [string trim [string range [readexp ${key}B] 40 49] ]
793                } elseif {$type == "23"} {
794                    return [string trim [string range [readexp ${key}B] 50 59] ]
795                }
796            }
797            U*-set {
798                if ![validreal value 10 6] {return 0}
799                regsub U $parm {} type
800                if {$type == "iso" || $type == "11"} {
801                    setexp ${key}B $value 1 10
802                } elseif {$type == "22"} {
803                    setexp ${key}B $value 11 10
804                } elseif {$type == "33"} {
805                    setexp ${key}B $value 21 10
806                } elseif {$type == "12"} {
807                    setexp ${key}B $value 31 10
808                } elseif {$type == "13"} {
809                    setexp ${key}B $value 41 10
810                } elseif {$type == "23"} {
811                    setexp ${key}B $value 51 10
812                }
813            }
814            xref-get {
815                if {[string toupper [string range [readexp ${key}B] 64 64]] == "X"} {
816                    return 1
817                }
818                return 0
819            }
820            xref-set {
821                if $value {
822                    setexp ${key}B "X" 65 1
823                } else {
824                    setexp ${key}B " " 65 1
825                }           
826            }
827            xdamp-get {
828                set val [string range [readexp ${key}A] 64 64]
829                if {$val == " "} {return 0}
830                return $val
831            }
832            xdamp-set {
833                setexp ${key}A $value 65 1
834            }
835            fref-get {
836                if {[string toupper [string range [readexp ${key}B] 63 63]] == "F"} {
837                    return 1
838                }
839                return 0
840            }
841            fref-set {
842                if $value {
843                    setexp ${key}B "F" 64 1
844                } else {
845                    setexp ${key}B " " 64 1
846                }           
847            }
848            fdamp-get {
849                set val [string range [readexp ${key}A] 63 63]
850                if {$val == " "} {return 0}
851                return $val
852            }
853            fdamp-set {
854                setexp ${key}A $value 64 1
855            }
856
857            uref-get {
858                if {[string toupper [string range [readexp ${key}B] 65 65]] == "U"} {
859                    return 1
860                }
861                return 0
862            }
863            uref-set {
864                if $value {
865                    setexp ${key}B "U" 66 1
866                } else {
867                    setexp ${key}B " " 66 1
868                }           
869            }
870            udamp-get {
871                set val [string range [readexp ${key}A] 65 65]
872                if {$val == " "} {return 0}
873                return $val
874            }
875            udamp-set {
876                setexp ${key}A $value 66 1
877            }
878            default {
879                set msg "Unsupported atominfo access: parm=$parm action=$action"
880                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
881                destroy .
882            }
883        }
884    }
885    return 1
886}
887
888# get histogram information: histinfo histlist parm action value
889# histlist is a list of histogram numbers
890# parm:
891#     title
892#     scale (*)
893#     sref/sdamp -- refinement flag/damping value for the scale factor (*)
894#     lam1, lam2 (*)
895#     ttref refinement flag for the 2theta (ED Xray) (*)
896#     wref refinement flag for the wavelength (*)
897#     ratref refinement flag for the wavelength ratio (*)
898#     difc, difa -- TOF calibration constants (*)
899#     dcref,daref -- refinement flag for difc, difa (*)
900#     zero (*)
901#     zref refinement flag for the zero correction (*)
902#     ipola (*)
903#     pola (*)
904#     pref refinement flag for the polarization (*)
905#     kratio (*)
906#     ddamp -- damping value for the diffractometer constants (*)
907#     backtype -- background function number *
908#     backterms -- number of background terms *
909#     bref/bdamp -- refinement flag/damping value for the background (*)
910#     bterm$n -- background term #n (*)
911#     bank -- Bank number
912#     tofangle -- detector angle (TOF only)
913#     foextract  -- Fobs extraction flag (*)
914proc histinfo {histlist parm "action get" "value {}"} {
915    global expgui
916    foreach hist $histlist {
917        if {$hist < 10} {
918            set key "HST  $hist"
919        } else {
920            set key "HST $hist"
921        }
922        switch -glob ${parm}-$action {
923            foextract-get {
924                set line [readexp "${key} EPHAS"]
925                # add a EPHAS if not exists
926                if {$line == {}} {
927                    makeexprec "${key} EPHAS"
928                    # expedt defaults this to "F", but I think "T" is better
929                    setexp "${key} EPHAS" "T" 50 1
930                    if $expgui(debug) {puts "Warning: creating a ${key} EPHAS record"}
931                }
932                if {[string toupper [string range $line 49 49]] == "T"} {
933                    return 1
934                }
935                return 0
936            }
937            foextract-set {
938                if $value {
939                    setexp "${key} EPHAS" "T" 50 1
940                } else {
941                    setexp "${key} EPHAS" "F" 50 1
942                }           
943            }
944            title-get {
945                return [string trim [readexp "${key}  HNAM"] ]
946            }
947            scale-get {
948                return [string trim [string range [readexp ${key}HSCALE] 0 14]]
949            }
950            scale-set {
951                if ![validreal value 15 6] {return 0}
952                setexp ${key}HSCALE $value 1 15
953            }
954            sref-get {
955                if {[string toupper [string range [readexp ${key}HSCALE] 19 19]] == "Y"} {
956                    return 1
957                }
958                return 0
959            }
960            sref-set {
961                if $value {
962                    setexp ${key}HSCALE "Y" 20 1
963                } else {
964                    setexp ${key}HSCALE "N" 20 1
965                }           
966            }
967            sdamp-get {
968                set val [string range [readexp ${key}HSCALE] 24 24]
969                if {$val == " "} {return 0}
970                return $val
971            }
972            sdamp-set {
973                setexp ${key}HSCALE $value 25 1
974            }
975
976            difc-get -
977            lam1-get {
978                return [string trim [string range [readexp "${key} ICONS"] 0 9]]
979            }
980            difc-set -
981            lam1-set {
982                if ![validreal value 10 7] {return 0}
983                setexp "${key} ICONS" $value 1 10
984            }
985            difa-get -
986            lam2-get {
987                return [string trim [string range [readexp "${key} ICONS"] 10 19]]
988            }
989            difa-set -
990            lam2-set {
991                if ![validreal value 10 7] {return 0}
992                setexp "${key} ICONS" $value 11 10
993            }
994            zero-get {
995                return [string trim [string range [readexp "${key} ICONS"] 20 29]]
996            }
997            zero-set {
998                if ![validreal value 10 5] {return 0}
999                setexp "${key} ICONS" $value 21 10
1000            }
1001            ipola-get {
1002                return [string trim [string range [readexp "${key} ICONS"] 54 54]]
1003            }
1004            ipola-set {
1005                if ![validint value 1] {return 0}
1006                setexp "${key} ICONS" $value 55 1
1007            }
1008            pola-get {
1009                return [string trim [string range [readexp "${key} ICONS"] 40 49]]
1010            }
1011            pola-set {
1012                if ![validreal value 10 5] {return 0}
1013                setexp "${key} ICONS" $value 41 10
1014            }
1015            kratio-get {
1016                return [string trim [string range [readexp "${key} ICONS"] 55 64]]
1017            }
1018            kratio-set {
1019                if ![validreal value 10 5] {return 0}
1020                setexp "${key} ICONS" $value 56 10
1021            }
1022
1023            wref-get {
1024            #------------------------------------------------------
1025            # col 33: refine flag for lambda, difc, ratio and theta
1026            #------------------------------------------------------
1027                if {[string toupper [string range \
1028                        [readexp "${key} ICONS"] 32 32]] == "L"} {
1029                    return 1
1030                }
1031                return 0
1032            }
1033            wref-set {
1034                if $value {
1035                    setexp "${key} ICONS" "L" 33 1
1036                } else {
1037                    setexp "${key} ICONS" " " 33 1
1038                }           
1039            }
1040            ratref-get {
1041                if {[string toupper [string range \
1042                        [readexp "${key} ICONS"] 32 32]] == "R"} {
1043                    return 1
1044                }
1045                return 0
1046            }
1047            ratref-set {
1048                if $value {
1049                    setexp "${key} ICONS" "R" 33 1
1050                } else {
1051                    setexp "${key} ICONS" " " 33 1
1052                }           
1053            }
1054            dcref-get {
1055                if {[string toupper [string range \
1056                        [readexp "${key} ICONS"] 32 32]] == "C"} {
1057                    return 1
1058                }
1059                return 0
1060            }
1061            dcref-set {
1062                if $value {
1063                    setexp "${key} ICONS" "C" 33 1
1064                } else {
1065                    setexp "${key} ICONS" " " 33 1
1066                }           
1067            }
1068            ttref-get {
1069                if {[string toupper [string range \
1070                        [readexp "${key} ICONS"] 32 32]] == "T"} {
1071                    return 1
1072                }
1073                return 0
1074            }
1075            ttref-set {
1076                if $value {
1077                    setexp "${key} ICONS" "T" 33 1
1078                } else {
1079                    setexp "${key} ICONS" " " 33 1
1080                }           
1081            }
1082
1083
1084            pref-get {
1085            #------------------------------------------------------
1086            # col 34: refine flag for POLA & DIFA
1087            #------------------------------------------------------
1088                if {[string toupper [string range \
1089                        [readexp "${key} ICONS"] 33 33]] == "P"} {
1090                    return 1
1091                }
1092                return 0
1093            }
1094            pref-set {
1095                if $value {
1096                    setexp "${key} ICONS" "P" 34 1
1097                } else {
1098                    setexp "${key} ICONS" " " 34 1
1099                }           
1100            }
1101            daref-get {
1102                if {[string toupper [string range \
1103                        [readexp "${key} ICONS"] 33 33]] == "A"} {
1104                    return 1
1105                }
1106                return 0
1107            }
1108            daref-set {
1109                if $value {
1110                    setexp "${key} ICONS" "A" 34 1
1111                } else {
1112                    setexp "${key} ICONS" " " 34 1
1113                }           
1114            }
1115
1116            zref-get {
1117            #------------------------------------------------------
1118            # col 34: refine flag for zero correction
1119            #------------------------------------------------------
1120                if {[string toupper [string range [readexp "${key} ICONS"] 34 34]] == "Z"} {
1121                    return 1
1122                }
1123                return 0
1124            }
1125            zref-set {
1126                if $value {
1127                    setexp "${key} ICONS" "Z" 35 1
1128                } else {
1129                    setexp "${key} ICONS" " " 35 1
1130                }           
1131            }
1132
1133            ddamp-get {
1134                set val [string range [readexp "${key} ICONS"] 39 39]
1135                if {$val == " "} {return 0}
1136                return $val
1137            }
1138            ddamp-set {
1139                setexp "${key} ICONS" $value 40 1
1140            }
1141
1142            backtype-get {
1143                set val [string trim [string range [readexp "${key}BAKGD "] 0 4]]
1144                if {$val == " "} {return 0}
1145                return $val
1146            }
1147            backtype-set {
1148                if ![validint value 5] {return 0}
1149                setexp "${key}BAKGD " $value 1 5
1150            }
1151            backterms-get {
1152                set val [string trim [string range [readexp "${key}BAKGD "] 5 9]]
1153                if {$val == " "} {return 0}
1154                return $val
1155            }
1156            backterms-set {
1157                # this takes a bit of work -- if terms are added, add lines as needed to the .EXP
1158                set oldval [string trim [string range [readexp "${key}BAKGD "] 5 9]]
1159                if ![validint value 5] {return 0}
1160                if {$oldval < $value} {
1161                    set line1  [expr 2 + ($oldval - 1) / 4]
1162                    set line2  [expr 1 + ($value - 1) / 4]
1163                    for {set i $line1} {$i <= $line2} {incr i} {
1164                        # create a blank entry if needed
1165                        makeexprec ${key}BAKGD$i
1166                    }
1167                    incr oldval
1168                    for {set num $oldval} {$num <= $value} {incr num} {
1169                        set f1 [expr 15*(($num - 1) % 4)]
1170                        set f2 [expr 15*(1 + ($num - 1) % 4)-1]
1171                        set line  [expr 1 + ($num - 1) / 4]
1172                        if {[string trim [string range [readexp ${key}BAKGD$line] $f1 $f2]] == ""} {
1173                            set f1 [expr 15*(($num - 1) % 4)+1]
1174                            setexp ${key}BAKGD$line 0.0 $f1 15                 
1175                        }
1176                    }
1177                }
1178                setexp "${key}BAKGD " $value 6 5
1179
1180            }
1181            bref-get {
1182                if {[string toupper [string range [readexp "${key}BAKGD"] 14 14]] == "Y"} {
1183                    return 1
1184                }
1185                return 0
1186            }
1187            bref-set {
1188                if $value {
1189                    setexp "${key}BAKGD "  "Y" 15 1
1190                } else {
1191                    setexp "${key}BAKGD "  "N" 15 1
1192                }           
1193            }
1194            bdamp-get {
1195                set val [string range [readexp "${key}BAKGD "] 19 19]
1196                if {$val == " "} {return 0}
1197                return $val
1198            }
1199            bdamp-set {
1200                setexp "${key}BAKGD " $value 20 1
1201            }
1202            bterm*-get {
1203                regsub bterm $parm {} num
1204                set f1 [expr 15*(($num - 1) % 4)]
1205                set f2 [expr 15*(1 + ($num - 1) % 4)-1]
1206                set line  [expr 1 + ($num - 1) / 4]
1207                return [string trim [string range [readexp ${key}BAKGD$line] $f1 $f2] ]
1208            }
1209            bterm*-set {
1210                regsub bterm $parm {} num
1211                if ![validreal value 15 6] {return 0}
1212                set f1 [expr 15*(($num - 1) % 4)+1]
1213                set line  [expr 1 + ($num - 1) / 4]
1214                setexp ${key}BAKGD$line $value $f1 15
1215            }
1216            bank-get {
1217                return [string trim [string range [readexp "${key} BANK"] 0 4]]
1218            }
1219            tofangle-get {
1220                return [string trim [string range [readexp "${key}BNKPAR"] 10 19]]
1221            }
1222            default {
1223                set msg "Unsupported histinfo access: parm=$parm action=$action"
1224                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
1225                destroy .
1226            }
1227        }
1228    }
1229    return 1
1230}
1231
1232# read the information that differs by both histogram and phase (profile & phase fraction)
1233# use: hapinfo hist phase parm action value
1234# 
1235#     frac -- phase fraction (*)
1236#     frref/frdamp -- refinement flag/damping value for the phase fraction (*)
1237#     proftype -- profile function number (*)
1238#     profterms -- number of profile terms (*)
1239#     pdamp -- damping value for the profile (*)
1240#     pcut -- cutoff value for the profile (*)
1241#     pterm$n -- profile term #n (*)
1242#     pref$n -- refinement flag value for profile term #n (*)
1243#     extmeth -- Fobs extraction method (*)
1244#     POnaxis -- number of defined M-D preferred axes
1245proc hapinfo {histlist phaselist parm "action get" "value {}"} {
1246    foreach phase $phaselist hist $histlist {
1247        if {$phase == ""} {set phase [lindex $phaselist end]}
1248        if {$hist == ""} {set hist [lindex $histlist end]}
1249        if {$hist < 10} {
1250            set hist " $hist"
1251        }
1252        set key "HAP${phase}${hist}"
1253        switch -glob ${parm}-$action {
1254            extmeth-get {
1255                set i1 [expr ($phase - 1)*5]
1256                set i2 [expr $i1 + 4]
1257                return [string trim [string range [readexp "HST $hist EPHAS"] $i1 $i2]]
1258            }
1259            extmeth-set {
1260                set i1 [expr ($phase - 1)*5 + 1]
1261                if ![validint value 5] {return 0}
1262                setexp "HST $hist EPHAS" $value $i1 5
1263            }
1264            frac-get {
1265                return [string trim [string range [readexp ${key}PHSFR] 0 14]]
1266            }
1267            frac-set {
1268                if ![validreal value 15 6] {return 0}
1269                setexp ${key}PHSFR $value 1 15
1270            }
1271            frref-get {
1272                if {[string toupper [string range [readexp ${key}PHSFR] 19 19]] == "Y"} {
1273                    return 1
1274                }
1275                return 0
1276            }
1277            frref-set {
1278                if $value {
1279                    setexp ${key}PHSFR "Y" 20 1
1280                } else {
1281                    setexp ${key}PHSFR "N" 20 1
1282                }           
1283            }
1284            frdamp-get {
1285                set val [string range [readexp ${key}PHSFR] 24 24]
1286                if {$val == " "} {return 0}
1287                return $val
1288            }
1289            frdamp-set {
1290                setexp ${key}PHSFR $value 25 1
1291            }
1292            proftype-get {
1293                set val [string range [readexp "${key}PRCF "] 0 4]
1294                if {$val == " "} {return 0}
1295                return $val
1296            }
1297            proftype-set {
1298                if ![validint value 5] {return 0}
1299                setexp "${key}PRCF " $value 1 5
1300            }
1301            profterms-get {
1302                set val [string range [readexp "${key}PRCF "] 5 9]
1303                if {$val == " "} {return 0}
1304                return $val
1305            }
1306            profterms-set {
1307                if ![validint value 5] {return 0}
1308                setexp "${key}PRCF " $value 6 5
1309                # now check that all needed entries exist
1310                set lines [expr 1 + ($value - 1) / 4]
1311                for {set i 1} {$i <= $lines} {incr i} {
1312                    makeexprec "${key}PRCF $i"
1313                }
1314            }
1315            pcut-get {
1316                return [string trim [string range [readexp "${key}PRCF "] 10 19]]
1317            }
1318            pcut-set {
1319                if ![validreal value 10 5] {return 0}
1320                setexp "${key}PRCF " $value 11 10
1321            }
1322            pdamp-get {
1323                set val [string range [readexp "${key}PRCF "] 24 24]
1324                if {$val == " "} {return 0}
1325                return $val
1326            }
1327            pdamp-set {
1328                setexp "${key}PRCF   " $value 25 1
1329            }
1330            pterm*-get {
1331                regsub pterm $parm {} num
1332                set f1 [expr 15*(($num - 1) % 4)]
1333                set f2 [expr 15*(1 + ($num - 1) % 4)-1]
1334                set line  [expr 1 + ($num - 1) / 4]
1335                return [string trim [string range [readexp "${key}PRCF $line"] $f1 $f2] ]
1336            }
1337            pterm*-set {
1338                if ![validreal value 15 6] {return 0}
1339                regsub pterm $parm {} num
1340                set f1 [expr 1+ 15*(($num - 1) % 4)]
1341                set line  [expr 1 + ($num - 1) / 4]
1342                setexp "${key}PRCF $line" $value $f1 15
1343            }
1344            pref*-get {
1345                regsub pref $parm {} num
1346                set f [expr 24+$num]
1347                if {[string toupper [string range [readexp "${key}PRCF  "] $f $f]] == "Y"} {
1348                    return 1
1349                }
1350                return 0
1351            }
1352            pref*-set {
1353                regsub pref $parm {} num
1354                set f [expr 25+$num]
1355                if $value {
1356                    setexp ${key}PRCF "Y" $f 1
1357                } else {
1358                    setexp ${key}PRCF "N" $f 1
1359                }           
1360            }
1361            POnaxis-get {
1362                set val [string trim \
1363                        [string range [readexp "${key}NAXIS"] 0 4]]
1364                if {$val == ""} {return 0}
1365                return $val
1366            }
1367            POnaxis-set {
1368                if ![validint value 5] {return 0}
1369                # there should be a NAXIS record, but if not make one
1370                if {![existsexp "${key}NAXIS"]} {
1371                    makeexprec "${key}NAXIS"
1372                }
1373                setexp "${key}NAXIS  " $value 1 5
1374            }
1375            default {
1376                set msg "Unsupported hapinfo access: parm=$parm action=$action"
1377                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
1378                destroy .
1379            }
1380        }
1381    }
1382    return 1
1383}
1384
1385#  get a logical constraint
1386#
1387#  type action
1388#  -----------
1389#  atom get  number        returns a list of constraints.
1390#   "   set  number value  replaces a list of constraints
1391#                          (value is a list of constraints)
1392#   "   add  number value  inserts a new list of constraints
1393#                          (number is ignored)
1394#   "   delete number      deletes a set of constraint entries
1395# Each item in the list of constraints is composed of 4 items:
1396#              phase, atom, variable, multiplier
1397# If variable=UISO atom can be ALL, otherwise atom is a number
1398# legal variable names: FRAC, X, Y, Z, UISO, U11, U22, U33, U12, U23, U13,
1399#                       MX, MY, MZ
1400#
1401#  type action
1402#  -----------
1403#  profileXX get number         returns a list of constraints for term XX=1-36
1404#                               use number=0 to get # of defined
1405#                                  constraints for term XX
1406#   "        set number value   replaces a list of constraints
1407#                               (value is a list of constraints)
1408#   "        add number value   inserts a new list of constraints
1409#                               (number is ignored)
1410#   "        delete number      deletes a set of constraint entries
1411# Each item in the list of constraints is composed of 3 items:
1412#              phase-list, histogram-list, multiplier
1413# Note that phase-list and/or histogram-list can be ALL
1414
1415proc constrinfo {type action number "value {}"} {
1416    switch -glob ${type}-$action {
1417        atom-get {
1418            # does this constraint exist?
1419            set key [format "LNCN%4d%4d" $number 1]
1420            if {![existsexp $key]} {return -1}
1421            set clist {}
1422            for {set i 1} {$i < 999} {incr i} {
1423                set key [format "LNCN%4d%4d" $number $i]
1424                if {![existsexp $key]} break
1425                set line [readexp $key]
1426                set j1 2
1427                set j2 17
1428                set seg [string range $line $j1 $j2]
1429                while {[string trim $seg] != ""} {
1430                    lappend clist [list \
1431                            [string range $seg 0 0] \
1432                            [string trim [string range $seg 1 3]] \
1433                            [string trim [string range $seg 4 7]] \
1434                            [string trim [string range $seg 8 end]]]
1435                    incr j1 16
1436                    incr j2 16
1437                    set seg [string range $line $j1 $j2]
1438                }
1439            }
1440            return $clist
1441        }
1442        atom-set {
1443            # delete records for current constraint
1444            for {set i 1} {$i < 999} {incr i} {
1445                set key [format "LNCN%4d%4d" $number $i]
1446                if {![existsexp $key]} break
1447                delexp $key
1448            }
1449            set line {}
1450            set i 1
1451            foreach tuple $value {
1452                if {[string toupper [lindex $tuple 1]] == "ALL"} {
1453                    set seg [format %1dALL%-4s%8.4f \
1454                            [lindex $tuple 0] \
1455                            [lindex $tuple 2] \
1456                            [lindex $tuple 3]]
1457                } else {
1458                    set seg [eval format %1d%3d%-4s%8.4f $tuple]
1459                }
1460                append line $seg
1461                if {[string length $line] > 50} {
1462                    set key  [format "LNCN%4d%4d" $number $i]
1463                    makeexprec $key
1464                    setexp $key $line 3 68
1465                    set line {}
1466                    incr i
1467                }
1468            }
1469            if {$line != ""} {
1470                set key  [format "LNCN%4d%4d" $number $i]
1471                makeexprec $key
1472                setexp $key $line 3 68
1473            }
1474            return
1475        }
1476        atom-add {
1477            # loop over defined constraints
1478            for {set j 1} {$j < 9999} {incr j} {
1479                set key [format "LNCN%4d%4d" $j 1]
1480                if {![existsexp $key]} break
1481            }
1482            set number $j
1483            # save the constraint
1484            set line {}
1485            set i 1
1486            foreach tuple $value {
1487                if {[string toupper [lindex $tuple 1]] == "ALL"} {
1488                    set seg [format %1dALL%-4s%8.4f \
1489                            [lindex $tuple 0] \
1490                            [lindex $tuple 2] \
1491                            [lindex $tuple 3]]
1492                } else {
1493                    set seg [eval format %1d%3d%-4s%8.4f $tuple]
1494                }
1495                append line $seg
1496                if {[string length $line] > 50} {
1497                    set key  [format "LNCN%4d%4d" $number $i]
1498                    makeexprec $key
1499                    setexp $key $line 3 68
1500                    set line {}
1501                    incr i
1502                }
1503            }
1504            if {$line != ""} {
1505                set key  [format "LNCN%4d%4d" $number $i]
1506                makeexprec $key
1507                setexp $key $line 3 68
1508            }
1509            return
1510        }
1511        atom-delete {
1512            for {set j $number} {$j < 9999} {incr j} {
1513                # delete records for current constraint
1514                for {set i 1} {$i < 999} {incr i} {
1515                    set key [format "LNCN%4d%4d" $j $i]
1516                    if {![existsexp $key]} break
1517                    delexp $key
1518                }
1519                # now copy records, from the next entry, if any
1520                set j1 $j
1521                incr j1
1522                set key1 [format "LNCN%4d%4d" $j1 1]
1523                # if there is no record, there is nothing to copy -- done
1524                if {![existsexp $key1]} return
1525                for {set i 1} {$i < 999} {incr i} {
1526                    set key1 [format "LNCN%4d%4d" $j1 $i]
1527                    if {![existsexp $key1]} break
1528                    set key  [format "LNCN%4d%4d" $j  $i]
1529                    makeexprec $key
1530                    setexp $key [readexp $key1] 1 68
1531                }
1532            }
1533        }
1534        profile*-delete {
1535            regsub profile $type {} term
1536            if {$term < 10} {
1537                set term " $term"
1538            }
1539            set key "LEQV PF$term   "
1540            # return nothing if no term exists
1541            if {![existsexp $key]} {return 0}
1542
1543            # number of constraint terms
1544            set nterms [string trim [string range [readexp ${key}] 0 4] ]
1545            # don't delete a non-existing entry
1546            if {$number > $nterms} {return 0}
1547            set val [expr $nterms - 1]
1548            validint val 5
1549            setexp $key $val 1 5
1550            for {set i1 $number} {$i1 < $nterms} {incr i1} {
1551                set i2 [expr 1 + $i1]
1552                # move the contents of constraint #i2 -> i1
1553                if {$i1 > 9} {
1554                    set k1 [expr ($i1+1)/10]
1555                    set l1 $i1
1556                } else {
1557                    set k1 " "
1558                    set l1 " $i1"
1559                }
1560                set key1 "LEQV PF$term  $k1"
1561                # number of constraint lines for #i1
1562                set n1 [string trim [string range [readexp ${key1}] \
1563                        [expr ($i1%10)*5] [expr 4+(($i1%10)*5)]] ]
1564                if {$i2 > 9} {
1565                    set k2 [expr ($i2+1)/10]
1566                    set l2 $i2
1567                } else {
1568                    set k2 " "
1569                    set l2 " $i2"
1570                }
1571                set key2 "LEQV PF$term  $k2"
1572                # number of constraint lines for #i2
1573                set n2 [string trim [string range [readexp ${key2}] \
1574                        [expr ($i2%10)*5] [expr 4+(($i2%10)*5)]] ]
1575                set val $n2
1576                validint val 5
1577                # move the # of terms
1578                setexp $key1 $val [expr 1+(($i1%10)*5)] 5
1579                # move the terms
1580                for {set j 1} {$j <= $n2} {incr j 1} {
1581                    set key "LEQV PF${term}${l1}$j"
1582                    makeexprec $key
1583                    setexp $key [readexp "LEQV PF${term}${l2}$j"] 1 68
1584                }
1585                # delete any remaining lines
1586                for {set j [expr $n2+1]} {$j <= $n1} {incr j 1} {
1587                    delexp "LEQV PF${term}${l1}$j"
1588                }
1589            }
1590
1591            # clear the last term
1592            if {$nterms > 9} {
1593                set i [expr ($nterms+1)/10]
1594            } else {
1595                set i " "
1596            }
1597            set key "LEQV PF$term  $i"
1598            set cb [expr ($nterms%10)*5]
1599            set ce [expr 4+(($nterms%10)*5)]
1600            set n2 [string trim [string range [readexp ${key}] $cb $ce] ]
1601            incr cb
1602            setexp $key "     " $cb 5
1603            # delete any remaining lines
1604            for {set j 1} {$j <= $n2} {incr j 1} {
1605                delexp "LEQV PF${term}${nterms}$j"
1606            }
1607        }
1608        profile*-set {
1609            regsub profile $type {} term
1610            if {$term < 10} {
1611                set term " $term"
1612            }
1613            set key "LEQV PF$term   "
1614            # get number of constraint terms
1615            set nterms [string trim [string range [readexp ${key}] 0 4] ]
1616            # don't change a non-existing entry
1617            if {$number > $nterms} {return 0}
1618            if {$number > 9} {
1619                set k1 [expr ($number+1)/10]
1620                set l1 $number
1621            } else {
1622                set k1 " "
1623                set l1 " $number"
1624            }
1625            set key1 "LEQV PF$term  $k1"
1626            # old number of constraint lines
1627            set n1 [string trim [string range [readexp ${key1}] \
1628                    [expr ($number%10)*5] [expr 4+(($number%10)*5)]] ]
1629            # number of new constraints
1630            set j2 [llength $value]
1631            # number of new constraint lines
1632            set val [set n2 [expr ($j2 + 2)/3]]
1633            # store the new # of lines
1634            validint val 5
1635            setexp $key1 $val [expr 1+(($number%10)*5)] 5
1636
1637            # loop over the # of lines in the old or new, whichever is greater
1638            set v0 0
1639            for {set j 1} {$j <= [expr ($n1 > $n2) ? $n1 : $n2]} {incr j 1} {
1640                set key "LEQV PF${term}${l1}$j"
1641                # were there more lines in the old?
1642                if {$j > $n2} {
1643                    # this line is not needed
1644                    if {$j % 3 == 1} {
1645                        delexp %key
1646                    }
1647                    continue
1648                }
1649                # are we adding new lines?
1650                if {$j > $n1} {
1651                    makeexprec $key
1652                }
1653                # add the three constraints to the line
1654                foreach s {3 23 43} \
1655                        item [lrange $value $v0 [expr 2+$v0]] {
1656                    if {$item != ""} {
1657                        set val [format %-10s%9.3f \
1658                                [lindex $item 0],[lindex $item 1] \
1659                                [lindex $item 2]]
1660                        setexp $key $val $s 19
1661                    } else {
1662                        setexp $key " " $s 19
1663                    }
1664                }
1665                incr v0 3
1666            }
1667        }
1668        profile*-add {
1669            regsub profile $type {} term
1670            if {$term < 10} {
1671                set term " $term"
1672            }
1673            set key "LEQV PF$term   "
1674            if {![existsexp $key]} {makeexprec $key}
1675            set nterms [string trim [string range [readexp ${key}] 0 4] ]
1676            if {$nterms == ""} {
1677                set nterms 1
1678            } elseif {$nterms >= 99} {
1679                return 0
1680            } else {
1681                incr nterms
1682            }
1683            # store the new # of constraints
1684            set val $nterms
1685            validint val 5
1686            setexp $key $val 1 5
1687
1688            if {$nterms > 9} {
1689                set k1 [expr ($nterms+1)/10]
1690                set l1 $nterms
1691            } else {
1692                set k1 " "
1693                set l1 " $nterms"
1694            }
1695            set key1 "LEQV PF$term  $k1"
1696
1697            # number of new constraints
1698            set j2 [llength $value]
1699            # number of new constraint lines
1700            set val [set n2 [expr ($j2 + 2)/3]]
1701            # store the new # of lines
1702            validint val 5
1703            setexp $key1 $val [expr 1+(($nterms%10)*5)] 5
1704
1705            # loop over the # of lines to be added
1706            set v0 0
1707            for {set j 1} {$j <= $n2} {incr j 1} {
1708                set key "LEQV PF${term}${l1}$j"
1709                makeexprec $key
1710                # add the three constraints to the line
1711                foreach s {3 23 43} \
1712                        item [lrange $value $v0 [expr 2+$v0]] {
1713                    if {$item != ""} {
1714                        set val [format %-10s%9.3f \
1715                                [lindex $item 0],[lindex $item 1] \
1716                                [lindex $item 2]]
1717                        setexp $key $val $s 19
1718                    } else {
1719                        setexp $key " " $s 19
1720                    }
1721                }
1722                incr v0 3
1723            }
1724        }
1725        profile*-get {
1726            regsub profile $type {} term
1727            if {$term < 10} {
1728                set term " $term"
1729            }
1730            if {$number > 9} {
1731                set i [expr ($number+1)/10]
1732            } else {
1733                set i " "
1734            }
1735            set key "LEQV PF$term  $i"
1736            # return nothing if no term exists
1737            if {![existsexp $key]} {return 0}
1738            # number of constraint lines
1739           
1740            set numline [string trim [string range [readexp ${key}] \
1741                    [expr ($number%10)*5] [expr 4+(($number%10)*5)]] ]
1742            if {$number == 0} {return $numline}
1743            set clist {}
1744            if {$number < 10} {
1745                set number " $number"
1746            }
1747            for {set i 1} {$i <= $numline} {incr i} {
1748                set key "LEQV PF${term}${number}$i"
1749                set line [readexp ${key}]
1750                foreach s {1 21 41} e {20 40 60} {
1751                    set seg [string range $line $s $e]
1752                    if {[string trim $seg] == ""} continue
1753                    # parse the string segment
1754                    set parse [regexp { *([0-9AL]+),([0-9AL]+) +([0-9.]+)} \
1755                            $seg junk phase hist mult]
1756                    # was parse successful
1757                    if {!$parse} {continue}
1758                    lappend clist [list $phase $hist $mult]
1759                }
1760            }
1761            return $clist
1762        }
1763        default {
1764            set msg "Unsupported constrinfo access: type=$type action=$action"
1765            tk_dialog .badexp "Error in EXP access" $msg error 0 OK
1766        }
1767
1768    }
1769}
1770
1771# read the default profile information for a histogram
1772# use: profdefinfo hist set# parm action
1773# 
1774#     proftype -- profile function number
1775#     profterms -- number of profile terms
1776#     pdamp -- damping value for the profile (*)
1777#     pcut -- cutoff value for the profile (*)
1778#     pterm$n -- profile term #n
1779#     pref$n -- refinement flag value for profile term #n (*)
1780
1781proc profdefinfo {hist set parm "action get"} {
1782    global expgui
1783    if {$hist < 10} {
1784        set key "HST  $hist"
1785    } else {
1786        set key "HST $hist"
1787    }
1788    switch -glob ${parm}-$action {
1789        proftype-get {
1790            set val [string range [readexp "${key}PRCF$set"] 0 4]
1791            if {$val == " "} {return 0}
1792            return $val
1793        }
1794        profterms-get {
1795            set val [string range [readexp "${key}PRCF$set"] 5 9]
1796            if {$val == " "} {return 0}
1797            return $val
1798        }
1799        pcut-get {
1800            return [string trim [string range [readexp "${key}PRCF$set"] 10 19]]
1801        }
1802        pdamp-get {
1803                set val [string range [readexp "${key}PRCF$set"] 24 24]
1804            if {$val == " "} {return 0}
1805            return $val
1806        }
1807        pterm*-get {
1808            regsub pterm $parm {} num
1809            set f1 [expr 15*(($num - 1) % 4)]
1810            set f2 [expr 15*(1 + ($num - 1) % 4)-1]
1811            set line  [expr 1 + ($num - 1) / 4]
1812            return [string trim [string range [\
1813                        readexp "${key}PRCF${set}$line"] $f1 $f2] ]
1814        }
1815        pref*-get {
1816            regsub pref $parm {} num
1817            set f [expr 24+$num]
1818            if {[string toupper [string range [readexp "${key}PRCF$set"] $f $f]] == "Y"} {
1819                return 1
1820            }
1821            return 0
1822        }
1823        default {
1824            set msg "Unsupported profdefinfo access: parm=$parm action=$action"
1825            tk_dialog .badexp "Code Error" $msg error 0 Exit
1826        }
1827    }
1828}
1829
1830# get March-Dollase preferred orientation information
1831# use MDprefinfo hist phase axis-number parm action value
1832#    ratio    -- ratio of xtallites in PO direction vs random (>1 for more)
1833#    fraction -- fraction in this direction, when more than one axis is used
1834#    h k & l  -- indices of P.O. axis
1835#    ratioref -- flag to vary ratio
1836#    fracref  -- flag to vary fraction
1837#    damp     -- damping value
1838#    type     -- model type (0 = P.O. _|_ to beam, 1 = || to beam)
1839#    new      -- creates a new record with default values (set only)
1840proc MDprefinfo {histlist phaselist axislist parm "action get" "value {}"} {
1841    foreach phase $phaselist hist $histlist axis $axislist {
1842        if {$phase == ""} {set phase [lindex $phaselist end]}
1843        if {$hist == ""} {set hist [lindex $histlist end]}
1844        if {$axis == ""} {set axis [lindex $axislist end]}
1845        if {$hist < 10} {
1846            set hist " $hist"
1847        }
1848        if {$axis > 9} {
1849            set axis "0"
1850        }
1851        set key "HAP${phase}${hist}PREFO${axis}"
1852        switch -glob ${parm}-$action {
1853            ratio-get {
1854                return [string trim [string range [readexp $key] 0 9]]
1855            }
1856            ratio-set {
1857                if ![validreal value 10 6] {return 0}
1858                setexp $key $value 1 10
1859            }
1860            fraction-get {
1861                return [string trim [string range [readexp $key] 10 19]]
1862            }
1863            fraction-set {
1864                if ![validreal value 10 6] {return 0}
1865                setexp $key $value 11 10
1866            }
1867            h-get {
1868                set h [string trim [string range [readexp $key] 20 29]]
1869                # why not allow negative h values?
1870                #               if {$h < 1} {return 0}
1871                return $h
1872            }
1873            h-set {
1874                if ![validreal value 10 2] {return 0}
1875                setexp $key $value 21 10
1876            }
1877            k-get {
1878                set k [string trim [string range [readexp $key] 30 39]]
1879                #               if {$k < 1} {return 0}
1880                return $k
1881            }
1882            k-set {
1883                if ![validreal value 10 2] {return 0}
1884                setexp $key $value 31 10
1885            }
1886            l-get {
1887                set l [string trim [string range [readexp $key] 40 49]]
1888                #if {$l < 1} {return 0}
1889                return $l
1890            }
1891            l-set {
1892                if ![validreal value 10 2] {return 0}
1893                setexp $key $value 41 10
1894            }
1895            ratioref-get {
1896                if {[string toupper \
1897                        [string range [readexp $key] 53 53]] == "Y"} {
1898                    return 1
1899                }
1900                return 0
1901            }
1902            ratioref-set {
1903                if $value {
1904                    setexp $key "Y" 54 1
1905                } else {
1906                    setexp $key "N" 54 1
1907                }
1908            }
1909            fracref-get {
1910                if {[string toupper \
1911                        [string range [readexp $key] 54 54]] == "Y"} {
1912                    return 1
1913                }
1914                return 0
1915            }
1916            fracref-set {
1917                if $value {
1918                    setexp $key "Y" 55 1
1919                } else {
1920                    setexp $key "N" 55 1
1921              }
1922            }
1923            damp-get {
1924                set val [string trim [string range [readexp $key] 59 59]]
1925                if {$val == " "} {return 0}
1926                return $val
1927            }
1928            damp-set {
1929                setexp $key $value 60 1
1930            }
1931            type-get {
1932                set val [string trim [string range [readexp $key] 64 64]]
1933                if {$val == " "} {return 0}
1934                return $val
1935            }
1936            type-set {
1937                # only valid settings are 0 & 1
1938                if {$value != "0" && $value != "1"} {set value "0"}
1939                setexp $key $value 65 1
1940            }
1941            new-set {
1942                makeexprec $key
1943                setexp $key \
1944                        {  1.000000  1.000000  0.000000  0.000000  1.000000   NN    0    0} \
1945                        1 68
1946            }
1947            default {
1948                set msg "Unsupported MDprefinfo access: parm=$parm action=$action"
1949                tk_dialog .badexp "Error in EXP" $msg error 0 Exit
1950                destroy .
1951            }
1952
1953        }
1954
1955    }
1956}
1957
1958# write the .EXP file
1959proc expwrite {expfile} {
1960    global tcl_platform exparray
1961    set blankline \
1962     "                                                                        "
1963    set fp [open ${expfile} w]
1964    set keylist [lsort [array names exparray]]
1965    # reorder the keys so that VERSION comes 1st
1966    set pos [lsearch -exact $keylist {     VERSION}]
1967    set keylist "{     VERSION} [lreplace $keylist $pos $pos]"
1968    if {$tcl_platform(platform) == "windows"} { 
1969        foreach key $keylist {
1970            puts $fp [string range \
1971                    "$key$exparray($key)$blankline" 0 79]
1972        }
1973    } else {
1974        foreach key $keylist {
1975            puts -nonewline $fp [string range \
1976                    "$key$exparray($key)$blankline" 0 79]
1977        }
1978    }
1979    close $fp
1980}
1981
1982# history commands -- delete all but last $keep history records,
1983# renumber if $renumber is true
1984proc DeleteHistory {keep renumber} {
1985    global exparray
1986    foreach y [lrange [lsort -decreasing \
1987            [array names exparray {    HSTRY*}]] $keep end] {
1988        unset exparray($y)
1989    }
1990    if !$renumber return
1991    # renumber
1992    set i 0
1993    foreach y [lsort -increasing \
1994            [array names exparray {    HSTRY*}]] {
1995        set key [format "    HSTRY%3d" [incr i]]
1996        set exparray($key) $exparray($y)
1997        unset exparray($y)
1998    }
1999    # list all history
2000    #    foreach y [lsort -decreasing [array names exparray {    HSTRY*}]] {puts "$y $exparray($y)"}
2001}
2002
2003proc CountHistory {} {
2004    global exparray
2005    return [llength [array names exparray {    HSTRY*}]]
2006}
Note: See TracBrowser for help on using the repository browser.