source: trunk/readexp.tcl

Last change on this file was 1251, checked in by toby, 7 years ago

use svn ps svn:eol-style "native" * to change line ends

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Revision Id
File size: 144.8 KB
RevLine 
[85]1# $Id: readexp.tcl 1251 2014-03-10 22:17:29Z toby $
[11]2# Routines to deal with the .EXP "data structure"
3set expmap(Revision) {$Revision: 1251 $ $Date: 2014-03-10 22:17:29 +0000 (Mon, 10 Mar 2014) $}
4
5#  The GSAS data is read from an EXP file.
6#   ... reading an EXP file into an array
[381]7# returns -1 on error
8# returns 0 if the file is old-style UNIX format (no CR/LF)
9# returns 1 if the file is 80 char/line + cr/lf
10# returns 2 if the file is sequential but not fixed-record length
[1166]11proc expload {expfile "ns {}"} {
12    # expfile is the path to the data file.
13    # ns is the namespace to place the output array (default is global)
14    if {$ns != ""} {
15        namespace eval $ns {}
16    }
[468]17    if [catch {set fil [open "$expfile" r]}] {
[11]18        tk_dialog .expFileErrorMsg "File Open Error" \
[468]19                "Unable to open file $expfile" error 0 "Exit" 
20        return -1
[11]21    }
[381]22    fconfigure $fil -translation lf
[11]23    set len [gets $fil line]
24    if {[string length $line] != $len} {
25        tk_dialog .expConvErrorMsg "old tcl" \
26                "You are using an old version of Tcl/Tk and your .EXP file has binary characters; run convstod or upgrade" \
27                error 0 "Exit"
[128]28        return -1
[11]29    }
[128]30    catch {
[1166]31        unset ${ns}::exparray
[128]32    }
[11]33    if {$len > 160} {
[128]34        set fmt 0
[11]35        # a UNIX-type file
36        set i1 0
37        set i2 79
38        while {$i2 < $len} {
39            set nline [string range $line $i1 $i2]
40            incr i1 80
41            incr i2 80
42            set key [string range $nline 0 11]
[1166]43            set ${ns}::exparray($key) [string range $nline 12 end]
[11]44        }
45    } else {
[128]46        set fmt 1
[11]47        while {$len > 0} {
48            set key [string range $line 0 11]
[1166]49            set ${ns}::exparray($key) [string range $line 12 79]
[381]50            if {$len != 81 || [string range $line end end] != "\r"} {set fmt 2}
[11]51            set len [gets $fil line]
52        }
53    }
54    close $fil
[128]55    return $fmt
[11]56}
57
[19]58proc createexp {expfile title} {
59    global exparray expmap
60    catch {unset exparray}
61    foreach key   {"     VERSION" "      DESCR" "ZZZZZZZZZZZZ" " EXPR NPHAS"} \
[90]62            value {"   6"         ""            "  Last EXP file record" ""} {
[19]63        # truncate long keys & pad short ones
64        set key [string range "$key        " 0 11]
65        set exparray($key) $value
66    }
67    expinfo title set $title
[852]68    exphistory add " created readexp.tcl [lindex $expmap(Revision) 1] [clock format [clock seconds] -format %Y-%m-%dT%T]"
[19]69    expwrite $expfile
70}
71
[11]72# get information out from an EXP file
73#   creates the following entries in global array expmap
74#     expmap(phaselist)     gives a list of defined phases
[128]75#     expmap(phasetype)     gives the phase type for each defined phase
76#                           =1 nuclear; 2 mag+nuc; 3 mag; 4 macro
[11]77#     expmap(atomlist_$p)   gives a list of defined atoms in phase $p
[453]78#     expmap(htype_$n)      gives the GSAS histogram type for histogram (all)
79#     expmap(powderlist)    gives a list of powder histograms in use
[11]80#     expmap(phaselist_$n)  gives a list of phases used in histogram $n
[453]81#     expmap(nhst)          the number of GSAS histograms
[11]82#
83proc mapexp {} {
[1025]84    global expgui expmap exparray
[229]85    # clear out the old array
86    set expmap_Revision $expmap(Revision)
87    unset expmap
88    set expmap(Revision) $expmap_Revision
[850]89    # apply any updates to the .EXP file
90    updateexpfile
[11]91    # get the defined phases
92    set line [readexp " EXPR NPHAS"]
[19]93#    if {$line == ""} {
94#       set msg "No EXPR NPHAS entry. This is an invalid .EXP file"
95#       tk_dialog .badexp "Error in EXP" $msg error 0 Exit
96#       destroy .
97#    }
[11]98    set expmap(phaselist) {}
[128]99    set expmap(phasetype) {}
[11]100    # loop over phases
101    foreach iph {1 2 3 4 5 6 7 8 9} {
[396]102        set i5s [expr {($iph - 1)*5}]
103        set i5e [expr {$i5s + 4}]
[11]104        set flag [string trim [string range $line $i5s $i5e]]
105        if {$flag == ""} {set flag 0}
[128]106        if $flag {
107            lappend expmap(phaselist) $iph
108            lappend expmap(phasetype) $flag
109        }
[11]110    }
111    # get the list of defined atoms for each phase
112    foreach iph $expmap(phaselist) {
113        set expmap(atomlist_$iph) {}
[544]114        if {[lindex $expmap(phasetype) [expr {$iph - 1}]] != 4} {
115            foreach key [array names exparray "CRS$iph  AT*A"] {
116                regexp { AT *([0-9]+)A} $key a num
117                lappend expmap(atomlist_$iph) $num
118            }
119        } else {
120            foreach key [array names exparray "CRS$iph  AT*"] {
[662]121                scan [string range $key 8 11] %x atm
122                lappend expmap(atomlist_$iph) $atm
[544]123            }
[11]124        }
125        # note that sometimes an .EXP file contains more atoms than are actually defined
126        # drop the extra ones
127        set expmap(atomlist_$iph) [lsort -integer $expmap(atomlist_$iph)]
128        set natom [phaseinfo $iph natoms]
129        if {$natom != [llength $expmap(atomlist_$iph)]} {
[396]130            set expmap(atomlist_$iph) [lrange $expmap(atomlist_$iph) 0 [expr {$natom-1}]]
[11]131        }
132    }
133    # now get the histogram types
[453]134    set expmap(nhst) [string trim [readexp { EXPR  NHST }]]
[11]135    set n 0
136    set expmap(powderlist) {}
[453]137    for {set i 0} {$i < $expmap(nhst)} {incr i} {
[396]138        set ihist [expr {$i + 1}]
139        if {[expr {$i % 12}] == 0} {
[11]140            incr n
141            set line [readexp " EXPR  HTYP$n"]
142            if {$line == ""} {
143                set msg "No HTYP$n entry for Histogram $ihist. This is an invalid .EXP file"
[252]144                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
[11]145            }
146            set j 0
147        } else {
148            incr j
149        }
[453]150        set expmap(htype_$ihist) [string range $line [expr 2+5*$j] [expr 5*($j+1)]]
151        # is this a dummy histogram?
152        if {$ihist <=9} {
153            set key "HST  $ihist DUMMY"
154        } else {
155            set key "HST $ihist DUMMY"
156        }
[11]157        # at least for now, ignore non-powder histograms
[128]158        if {[string range $expmap(htype_$ihist) 0 0] == "P" && \
159                [string range $expmap(htype_$ihist) 3 3] != "*"} {
[453]160            if {[existsexp $key]} {
161                set expmap(htype_$ihist) \
[471]162                        [string range $expmap(htype_$ihist) 0 2]D
[453]163            }
[11]164            lappend expmap(powderlist) $ihist
165        }
166    }
167
168    # now process powder histograms
169    foreach ihist $expmap(powderlist) {
170        # make a 2 digit key -- hh
171        if {$ihist < 10} {
172            set hh " $ihist"
173        } else {
174            set hh $ihist
175        }
176        set line [readexp "HST $hh NPHAS"]
177        if {$line == ""} {
178            set msg "No NPHAS entry for Histogram $ihist. This is an invalid .EXP file"
[252]179            tk_dialog .badexp "Error in readexp" $msg error 0 Exit
[11]180        }
181        set expmap(phaselist_$ihist) {}
182        # loop over phases
183        foreach iph {1 2 3 4 5 6 7 8 9} {
[396]184            set i5s [expr {($iph - 1)*5}]
185            set i5e [expr {$i5s + 4}]
[11]186            set flag [string trim [string range $line $i5s $i5e]]
187            if {$flag == ""} {set flag 0}
188            if $flag {lappend expmap(phaselist_$ihist) $iph}
189        }
190    }
[1166]191    # load the constrained parameters
192    atom_constraint_load
[1175]193    # construct tables of mapped atoms in rigid bodies
194    foreach phase $::expmap(phaselist) {
195        set expmap(rbatoms_$phase) {}
196        foreach bodnum [RigidBodyList] {
197            set natoms [llength [lindex [lindex [lindex [ReadRigidBody $bodnum] 1] 0] 3]]
198            foreach mapnum [RigidBodyMappingList $phase $bodnum] {
199                set atomnum [lindex [ReadRigidBodyMapping $phase $bodnum $mapnum] 0]
200                set st [lsearch $::expmap(atomlist_$phase) $atomnum]
201                set en [expr {$st+$natoms-1}]
202                set atoms [lrange $::expmap(atomlist_$phase) $st $en]
203                set expmap(rbatoms_$phase) [concat $expmap(rbatoms_$phase) $atoms]
204            }
205        }
206    }
[1025]207    set expgui(mapstat) 1
[11]208}
209
[850]210# this routine is called to update changes in the .EXP file
211proc updateexpfile {} {
212    global exparray
213    # change "CRSx  ODFxxx" records to "CRSx  OD xxx" records
214    # needed by the June 8, 2005 GSAS release
215    set ODFlist [array names exparray "CRS?  ODF*"]
216    if {[llength $ODFlist] > 0} {
217        catch {incr ::expgui(changed)}
218        foreach key $ODFlist {
219            regsub "ODF" $key "OD " newkey
220            set exparray($newkey) $exparray($key)
221            unset exparray($key)
222        }
223    }
224}
225
226
[11]227# return the value for a ISAM key
228proc readexp {key} {
229    global exparray
230    # truncate long keys & pad short ones
231    set key [string range "$key        " 0 11]
232    if [catch {set val $exparray($key)}] {
233        global expgui
234        if $expgui(debug) {puts "Error accessing record $key"}
235        return ""
236    }
237    return $val
238}
239
[15]240# return the number of records matching ISAM key (may contain wildcards)
241proc existsexp {key} {
242    global exparray
[19]243    # key can contain wild cards so don't pad
[15]244    return [llength [array names exparray  $key]]
245}
246
247
[11]248# replace a section of the exparray with $value
249#   replace $char characters starting at character $start (numbered from 1)
250proc setexp {key value start chars} {
251    global exparray
252    # truncate long keys & pad short ones
253    set key [string range "$key        " 0 11]
254    if [catch {set exparray($key)}] {
255        global expgui
256        if $expgui(debug) {puts "Error accessing record $key"}
257        return ""
258    }
259
260    # pad value to $chars
[396]261    set l0 [expr {$chars - 1}]
[11]262    set value [string range "$value                                           " 0 $l0]
263
264    if {$start == 1} {
265        set ret {}
266        set l1 $chars
267    } else {
[396]268        set l0 [expr {$start - 2}]
269        set l1 [expr {$start + $chars - 1}]
[11]270        set ret [string range $exparray($key) 0 $l0]
271    }
272    append ret $value [string range $exparray($key) $l1 end]
273    set exparray($key) $ret
274}
275
276proc makeexprec {key} {
277    global exparray
278    # truncate long keys & pad short ones
279    set key [string range "$key        " 0 11]
280    if [catch {set exparray($key)}] {
281        # set to 68 blanks
282        set exparray($key) [format %68s " "]
283    }
284}
285
[128]286# delete an exp record
[15]287# returns 1 if OK; 0 if not found
288proc delexp {key} {
289    global exparray
290    # truncate long keys & pad short ones
291    set key [string range "$key        " 0 11]
292    if [catch {unset exparray($key)}] {
293        return 0
294    }
295    return 1
296}
[843]297
[11]298# test an argument if it is a valid number; reform the number to fit
299proc validreal {val length decimal} {
300    upvar $val value
[843]301    # is this a number?
[396]302    if [catch {expr {$value}}] {return 0}
[11]303    if [catch {
[843]304        # how many digits are needed to the left of the decimal?
305        set sign 0
306        if {$value > 0} {
307            set digits [expr {1 + int(log10($value))}]
308        } elseif {$value < 0} {
309            set digits [expr {1 + int(log10(-$value))}]
310            set sign 1
311        } else {
312            set digits 1
313        }
[1166]314        if {$digits <= 0} {set digits 1}
[843]315        if {$digits + $sign >= $length} {
316            # the number is much too big -- use exponential notation
317            set decimal [expr {$length - 6 - $sign}]
318            # drop more decimal places, as needed
[11]319            set tmp [format "%${length}.${decimal}E" $value]
[843]320            while {[string length $tmp] > $length && $decimal >= 0} {
321                incr decimal -1
322                set tmp [format "%${length}.${decimal}E" $value]
323            }
324        } elseif {$digits + $sign >= $length - $decimal} {
325            # we will have to trim the number of decimal digits
326            set decimal [expr {$length - $digits - $sign - 1}]
327            set tmp [format "%#.${decimal}f" $value]
[1166]328        } elseif {abs($value) < pow(10,2-$decimal) && $length > 6 && $value != 0} {
[843]329            # for small values, switch to exponential notation (2-$decimal -> three sig figs.)
330            set decimal [expr {$length - 6 - $sign}]
331            # drop more decimal places, as needed
332            set tmp [format "%${length}.${decimal}E" $value]
333            while {[string length $tmp] > $length && $decimal >= 0} {
334                incr decimal -1
335                set tmp [format "%${length}.${decimal}E" $value]
336            }
[544]337        } else {
[843]338            # use format as specified
[544]339            set tmp [format "%${length}.${decimal}f" $value]
340        }
[11]341        set value $tmp
[843]342    } errmsg] {return 0}
[11]343    return 1
344}
345
346# test an argument if it is a valid integer; reform the number into
347# an integer, if appropriate -- be sure to pass the name of the variable not the value
348proc validint {val length} {
349    upvar $val value
350    # FORTRAN type assumption: blank is 0
351    if {$value == ""} {set value 0}
352    if [catch {
[396]353        set tmp [expr {round($value)}]
[287]354        if {$tmp != $value} {return 0}
[11]355        set value [format "%${length}d" $tmp]
356    }] {return 0}
357    return 1
358}
359
[15]360# process history information
361#    action == last
362#       returns number and value of last record
363#    action == add
364#
365proc exphistory {action "value 0"} {
366    global exparray
367    if {$action == "last"} {
368        set key [lindex [lsort -decreasing [array names exparray *HSTRY*]] 0]
369        if {$key == ""} {return ""}
370        return [list [string trim [string range $key 9 end]] $exparray($key)]
371    } elseif {$action == "add"} {
372        set key [lindex [lsort -decreasing [array names exparray *HSTRY*]] 0]
373        if {$key == ""} {
[19]374            set index 1
[15]375        } else {
376            set index [string trim [string range $key 9 end]]
377            if {$index != "***"} {
378                if {$index < 999} {incr index}
379                set key [format "    HSTRY%3d" $index]
380                set exparray($key) $value
381            }
382        }
383        set key [format "    HSTRY%3d" $index]
384        set exparray($key) $value
385    }
386}
[11]387# get overall info
388#   parm:
389#     print     -- GENLES print option (*)
390#     cycles    -- number of GENLES cycles (*)
[19]391#     title     -- the overall title (*)
[396]392#     convg     -- convergence criterion: -200 to 200 (*)
393#     marq      -- Marquardt damping factor: 1.0 to 9.99 (*)
[843]394#     mbw       -- LS matrix bandwidth; =0 for full matrix (*)
[11]395proc expinfo {parm "action get" "value {}"} {
396    switch ${parm}-$action {
[19]397        title-get {
398            return [string trim [readexp "      DESCR"]]
399        }
400        title-set {
[196]401            setexp "      DESCR" "  $value" 2 68
[19]402        }
[11]403        cycles-get {
404            return [string trim [cdatget MXCY]]
405        }
406        cycles-set {
407            if ![validint value 1] {return 0}
408            cdatset MXCY [format %4d $value]
409        }
[480]410        cyclesrun-get {
411            set cycle -1
412            regexp {.*cycles run *([0-9]*) } [readexp "  GNLS  RUN"] x cycle
413            return $cycle
414        }
[11]415        print-get {
[13]416            set print [string trim [cdatget PRNT]]
417            if {$print != ""} {return $print}
418            return 0
[11]419        }
420        print-set {
421            if ![validint value 1] {return 0}
[843]422            cdatset PRNT [format %4d $value]
[11]423        }
[396]424        convg-get {
425            set cvg [string trim [cdatget CVRG]]
426            if {$cvg == ""} {return -200}
427            if [catch {expr {$cvg}}] {return -200}
428            return $cvg
429        }
430        convg-set {
431            if ![validint value 1] {return 0}
432            set value [expr {-200>$value?-200:$value}]
433            set value [expr {200<$value?200:$value}]
434            cdatset CVRG [format %4d $value]
435        }
436        marq-get {
437            set mar [string trim [cdatget MARQ]]
438            if {$mar == ""} {return 1.0}
439            if [catch {expr $mar}] {return 1.}
440            return $mar
441        }
442        marq-set {
443            if [catch {
444                set value [expr {1.0>$value?1.0:$value}]
445                set value [expr {9.99<$value?9.99:$value}]
446            }] {return 0}
447            if ![validreal value 4 2] {return 0}
448            cdatset MARQ $value
449        }
[843]450        mbw-get {
451            set mbw [string trim [cdatget MBW]]
452            if {$mbw == ""} {return 0}
453            if [catch {expr $mbw}] {return 0}
454            return $mbw
455        }
456        mbw-set {
457            if ![validint value 1] {return 0}
458            if {$value < 0} {return 0}
459            cdatset MBW [format %5d $value]
460        }
[11]461        default {
462            set msg "Unsupported expinfo access: parm=$parm action=$action"
[252]463            tk_dialog .badexp "Error in readexp" $msg error 0 Exit
[11]464        }
465    }
466    return 1
467}
468
469proc cdatget {key} {
470    foreach i {1 2 3 4 5 6 7 8 9} {
[15]471        if {[existsexp "  GNLS CDAT$i"] == 0} break
[11]472        set line [readexp "  GNLS CDAT$i"]
473        if {$line == {}} break
474        foreach i1 {2 10 18 26 34 42 50 58 66} \
475                i2 {9 17 25 33 41 49 57 65 73} {
476            set item [string range $line $i1 $i2]
477            if {[string trim $item] == {}} continue
478            if [regexp "${key}(.*)" $item a b] {return $b}
479        }
480    }
481    return {}
482}
483
484proc cdatset {key value} {
485    # round 1 see if we can find the string
486    foreach i {1 2 3 4 5 6 7 8 9} {
487        set line [readexp "  GNLS CDAT$i"]
488        if {$line == {}} break
489        foreach i1 {2 10 18 26 34 42 50 58 66} \
490                i2 {9 17 25 33 41 49 57 65 73} {
491            set item [string range $line $i1 $i2]
492            if {[string trim $item] == {}} continue
493            if [regexp "${key}(.*)" $item a b] {
494                # found it now replace it
495                incr i1
496                setexp "  GNLS CDAT$i" "${key}${value}" $i1 8
497                return
498            }
499        }
500    }
501    # not found, take the 1st blank space, creating a card if needed
502    foreach i {1 2 3 4 5 6 7 8 9} {
503        set line [readexp "  GNLS CDAT$i"]
504        if {$line == {}} {makeexprec "  GNLS CDAT$i"}
505        foreach i1 {2 10 18 26 34 42 50 58 66} \
506                i2 {9 17 25 33 41 49 57 65 73} {
507            set item [string range $line $i1 $i2]
508            if {[string trim $item] == {}} {
509                # found a blank space: now replace it
510                incr i1
511                setexp "  GNLS CDAT$i" "${key}${value}" $i1 8
512                return
513            }
514        }
515    }
516    return {}
517}
518
[1025]519proc disagldat_get {phase} {
520    set key "  DSGL CDAT$phase"
521    if {[existsexp $key] == 0} {return "{none} {none}"}
522    set line [readexp $key]
523    set i1 2
524    # read atom-atom distance parameter
525    set dist {}
526    set item [string range $line $i1 [expr {$i1+3}]]
527    if {$item == "DMAX"} {
528        set val [string range $line [expr {$i1+4}] [expr {$i1+11}]]
529        set dist [string trim $val]
530        incr i1 13
531    } else {
532        set dist "radii"
533        incr i1 5
534    }
535    # read atom-atom-atom angle parameter
536    set ang {}
537    set item [string range $line $i1 [expr {$i1+3}]]
538    if {$item == "DAGL"} {
539        set val [string range $line [expr {$i1+4}] [expr {$i1+11}]]
540        set ang [string trim $val]
541        incr i1 13
542    } else {
543        set ang "radii"
544        incr i1 5
545    }
546    # note there are two more parameters, NOFO/FORA & ONCR/DFLT, but they are not being processed yet
547    return "$dist $ang"
548}
549
[11]550# get phase information: phaseinfo phase parm action value
551#   phase: 1 to 9 (as defined)
552#   parm:
553#     name -- phase name
[252]554#     natoms -- number of atoms (*)
[11]555#     a b c alpha beta gamma -- cell parameters (*)
556#     cellref -- refinement flag for the unit cell(*)
557#     celldamp  -- damping for the unit cell refinement (*)
[252]558#     spacegroup -- space group symbol (*)
[236]559#     ODForder -- spherical harmonic order (*)
560#     ODFsym   -- sample symmetry (0-3) (*)
561#     ODFdampA -- damping for angles (*)
562#     ODFdampC -- damping for coefficients (*)
563#     ODFomega -- omega oriention angle (*)
564#     ODFchi -- chi oriention angle (*)
565#     ODFphi -- phi oriention angle (*)
566#     ODFomegaRef -- refinement flag for omega (*)
567#     ODFchiRef -- refinement flag for chi (*)
568#     ODFphiRef -- refinement flag for phi (*)
569#     ODFterms -- a list of the {l m n} values for each ODF term (*)
570#     ODFcoefXXX -- the ODF coefficient for for ODF term XXX (*)
571#     ODFRefcoef -- refinement flag for ODF terms (*)
[1025]572#     DistCalc   -- returns "radii", "none" or a number (*)
573#                   none: no distance or angle computation for the phase
574#                   radii: computation will be done by sums of radii
575#                          (see AtmTypInfo and DefAtmTypInfo)
576#                   other: a distance specifing the maximum distance
577#     AngCalc    -- returns "radii", "none" or a number (*)
578#                   none: no distance or angle computation for the phase
579#                   radii: computation will be done by sums of radii
580#                          (see AtmTypInfo and DefAtmTypInfo)
581#                   other: a distance specifing the maximum distance
[11]582#  action: get (default) or set
583#  value: used only with set
584#  * =>  read+write supported
585proc phaseinfo {phase parm "action get" "value {}"} {
[236]586    switch -glob ${parm}-$action {
[11]587
588        name-get {
589            return [string trim [readexp "CRS$phase    PNAM"]]
590        }
591
[252]592        name-set {
593            setexp "CRS$phase    PNAM" " $value" 2 68
594        }
595
[56]596        spacegroup-get {
597            return [string trim [readexp "CRS$phase  SG SYM"]]
598        }
599
[252]600        spacegroup-set {
601            setexp "CRS$phase  SG SYM" " $value" 2 68
[19]602        }
603
[11]604        natoms-get {
605            return [string trim [readexp "CRS$phase   NATOM"]]     
606        }
607
[252]608        natoms-set {
609            if ![validint value 5] {return 0}
610            setexp "CRS$phase   NATOM" $value 1 5
611        }
612
[11]613        a-get {
614           return [string trim [string range [readexp "CRS$phase  ABC"] 0 9]]
615        }
616        b-get {
617           return [string trim [string range [readexp "CRS$phase  ABC"] 10 19]]
618        }
619        c-get {
620           return [string trim [string range [readexp "CRS$phase  ABC"] 20 29]]
621        }
622        alpha-get {
623           return [string trim [string range [readexp "CRS$phase  ANGLES"] 0 9]]
624        }
625        beta-get {
626           return [string trim [string range [readexp "CRS$phase  ANGLES"] 10 19]]
627        }
628        gamma-get {
629           return [string trim [string range [readexp "CRS$phase  ANGLES"] 20 29]]
630        }
631
632        a-set {
633            if ![validreal value 10 6] {return 0}
634            setexp "CRS$phase  ABC" $value 1 10             
635        }
636        b-set {
637            if ![validreal value 10 6] {return 0}
638            setexp "CRS$phase  ABC" $value 11 10           
639        }
640        c-set {
641            if ![validreal value 10 6] {return 0}
642            setexp "CRS$phase  ABC" $value 21 10           
643        }
644        alpha-set {
645            if ![validreal value 10 4] {return 0}
646            setexp "CRS$phase  ANGLES" $value 1 10         
647        }
648        beta-set {
649            if ![validreal value 10 4] {return 0}
650            setexp "CRS$phase  ANGLES" $value 11 10         
651        }
652        gamma-set {
[265]653            if ![validreal value 10 4] {return 0}
[11]654            setexp "CRS$phase  ANGLES" $value 21 10         
655        }
656        cellref-get {
657            if {[string toupper [string range [readexp "CRS$phase  ABC"] 34 34]] == "Y"} {
658                return 1
659            }
660            return 0
661        }
662        cellref-set {
663            if $value {
664                setexp "CRS$phase  ABC" "Y" 35 1
665            } else {
666                setexp "CRS$phase  ABC" "N" 35 1
667            }       
668        }
669        celldamp-get {
670            set val [string range [readexp "CRS$phase  ABC"] 39 39]
671            if {$val == " "} {return 0}
672            return $val
673        }
674        celldamp-set {
675            setexp "CRS$phase  ABC" $value 40 1
676        }
677
[236]678        ODForder-get {
[850]679            set val [string trim [string range [readexp "CRS$phase  OD "] 0 4]]
[236]680            if {$val == " "} {return 0}
681            return $val
682        }
683        ODForder-set {
684            if ![validint value 5] {return 0}
[850]685            setexp "CRS$phase  OD " $value 1 5
[236]686        }
687        ODFsym-get {
[850]688            set val [string trim [string range [readexp "CRS$phase  OD "] 10 14]]
[236]689            if {$val == " "} {return 0}
690            return $val
691        }
692        ODFsym-set {
693            if ![validint value 5] {return 0}
[850]694            setexp "CRS$phase  OD " $value 11 5
[236]695        }
696        ODFdampA-get {
[850]697            set val [string range [readexp "CRS$phase  OD "] 24 24]
[236]698            if {$val == " "} {return 0}
699            return $val
700        }
701        ODFdampA-set {
[850]702            setexp "CRS$phase  OD " $value 25 1
[236]703        }
704        ODFdampC-get {
[850]705            set val [string range [readexp "CRS$phase  OD "] 29 29]
[236]706            if {$val == " "} {return 0}
707            return $val
708        }
709        ODFdampC-set {
[850]710            setexp "CRS$phase  OD " $value 30 1
[236]711        }
712        ODFomegaRef-get {
[850]713            if {[string toupper [string range [readexp "CRS$phase  OD "] 16 16]] == "Y"} {
[236]714                return 1
715            }
716            return 0
717        }
718        ODFomegaRef-set {
719            if $value {
[850]720                setexp "CRS$phase  OD " "Y" 17 1
[236]721            } else {
[850]722                setexp "CRS$phase  OD " "N" 17 1
[236]723            }       
724        }
725        ODFchiRef-get {
[850]726            if {[string toupper [string range [readexp "CRS$phase  OD "] 17 17]] == "Y"} {
[236]727                return 1
728            }
729            return 0
730        }
731        ODFchiRef-set {
732            if $value {
[850]733                setexp "CRS$phase  OD " "Y" 18 1
[236]734            } else {
[850]735                setexp "CRS$phase  OD " "N" 18 1
[236]736            }       
737        }
738        ODFphiRef-get {
[850]739            if {[string toupper [string range [readexp "CRS$phase  OD "] 18 18]] == "Y"} {
[236]740                return 1
741            }
742            return 0
743        }
744        ODFphiRef-set {
745            if $value {
[850]746                setexp "CRS$phase  OD " "Y" 19 1
[236]747            } else {
[850]748                setexp "CRS$phase  OD " "N" 19 1
[236]749            }       
750        }
751        ODFcoef*-get {
752            regsub ODFcoef $parm {} term
[396]753            set k [expr {($term+5)/6}]
[850]754            if {$k <= 9} {
755                set k "  $k"
756            } elseif {$k <= 99} {
757                set k " $k"
758            }
[396]759            set j [expr {(($term-1) % 6)+1}]
[850]760            set lineB [readexp "CRS$phase  OD${k}B"]
[396]761            set j0 [expr { ($j-1) *10}]
762            set j1 [expr {$j0 + 9}]
[236]763            set val [string trim [string range $lineB $j0 $j1]]
764            if {$val == ""} {return 0.0}
765            return $val
766        }
767        ODFcoef*-set {
768            regsub ODFcoef $parm {} term
769            if ![validreal value 10 3] {return 0}
[396]770            set k [expr {($term+5)/6}]
[850]771            if {$k <= 9} {
772                set k "  $k"
773            } elseif {$k <= 99} {
774                set k " $k"
775            }
[396]776            set j [expr {(($term-1) % 6)+1}]
777            set col [expr { ($j-1)*10 + 1}]
[850]778            setexp "CRS$phase  OD${k}B" $value $col 10
[236]779        }
780        ODFRefcoef-get {
[850]781            if {[string toupper [string range [readexp "CRS$phase  OD "] 19 19]] == "Y"} {
[236]782                return 1
783            }
784            return 0
785        }
786        ODFRefcoef-set {
787            if $value {
[850]788                setexp "CRS$phase  OD " "Y" 20 1
[236]789            } else {
[850]790                setexp "CRS$phase  OD " "N" 20 1
[236]791            }       
792        }
793        ODFomega-get {
[850]794           return [string trim [string range [readexp "CRS$phase  OD "] 30 39]]
[236]795        }
796        ODFchi-get {
[850]797           return [string trim [string range [readexp "CRS$phase  OD "] 40 49]]
[236]798        }
799        ODFphi-get {
[850]800           return [string trim [string range [readexp "CRS$phase  OD "] 50 59]]
[236]801        }
802        ODFomega-set {
803            if ![validreal value 10 4] {return 0}
[850]804            setexp "CRS$phase  OD " $value 31 10
[236]805        }
806        ODFchi-set {
807            if ![validreal value 10 4] {return 0}
[850]808            setexp "CRS$phase  OD " $value 41 10
[236]809        }
810        ODFphi-set {
811            if ![validreal value 10 4] {return 0}
[850]812            setexp "CRS$phase  OD " $value 51 10
[236]813        }
814
815        ODFterms-get {
816            set vallist {}
[850]817            set val [string trim [string range [readexp "CRS$phase  OD "] 5 9]]
[236]818            for {set i 1} {$i <= $val} {incr i 6} {
[396]819                set k [expr {1+($i-1)/6}]
[850]820                if {$k <= 9} {
821                    set k "  $k"
822                } elseif {$k <= 99} {
823                    set k " $k"
824                }
825                set lineA [readexp "CRS$phase  OD${k}A"]
[236]826                set k 0
827                for {set j $i} {$j <= $val && $j < $i+6} {incr j} {
[396]828                    set j0 [expr {($k)*10}]
829                    set j1 [expr {$j0 + 9}]
[236]830                    lappend vallist [string trim [string range $lineA $j0 $j1]]
831                    incr k
832                }
833            }
834            return $vallist
835        }
836        ODFterms-set {
[850]837            set key "CRS$phase  OD    "
[236]838            if {![existsexp $key]} {
839                makeexprec $key
840                set oldlen 0
841            } else {
842                set oldlen [string trim [string range [readexp $key] 5 9]]
843            }
844            set len [llength $value]
845            if ![validint len 5] {return 0}
846            setexp $key $len 6 5
847            set j 0
848            set k 0
849            foreach item $value {
850                incr j
851                if {$j % 6 == 1} {
852                    incr k
[850]853                    if {$k <= 9} {
854                        set k "  $k"
855                    } elseif {$k <= 99} {
856                        set k " $k"
857                    }
[236]858                    set col 1
[850]859                    set keyA "CRS$phase  OD${k}A"
860                    set keyB "CRS$phase  OD${k}B"
[236]861                    if {![existsexp $keyA]} {
862                        makeexprec $keyA
863                        makeexprec $keyB
864                    }
865                }
[396]866                set col1 [expr {$col + 1}]
[236]867                foreach n [lrange $item 0 2] {
868                    if ![validint n 3] {return 0}
869                    setexp $keyA $n $col1 3
870                    incr col1 3
871                }
872                incr col 10
873            }
874            for {incr j} {$j <= $oldlen} {incr j} {
875                if {$j % 6 == 1} {
876                    incr k
[850]877                    if {$k <= 9} {
878                        set k "  $k"
879                    } elseif {$k <= 99} {
880                        set k " $k"
881                    }
[236]882                    set col 1
[850]883                    set keyA "CRS$phase  OD${k}A"
884                    set keyB "CRS$phase  OD${k}B"
[236]885                    delexp $keyA
886                    delexp $keyB
887                }
888                if {[existsexp $keyA]} {
889                    setexp $keyA "          " $col 10
890                    setexp $keyB "          " $col 10
891                }
892                incr col 10
893            }
894        }
[1025]895        DistCalc-get {
896            set val [disagldat_get $phase]
897            return [lindex $val 0]
898        }
899        DistCalc-set {
900            set key "  DSGL CDAT$phase"
901            # for none delete the record & thats all folks
902            if {$value == "none"} {
903                catch {unset ::exparray($key)}
904                return
905            }
906            if {[existsexp $key] == 0} {
907                makeexprec $key
908            }
909            set line [readexp $key]
910            if {[string trim $line] == ""} {
911                # blank set to defaults
912                set line [string replace $line 2 15 "DRAD ARAD NOFO"]
913            }
914            if {$value == "radii"} {
915                if {[string range $line 2 5] == "DMAX"} {
916                    set line [string replace $line 2 13 "DRAD"]
917                } else {
918                    set line [string replace $line 2 5 "DRAD"]
919                }
920            } else {
921                if ![validreal value 8 2] {return 0}
922                if {[string range $line 2 5] == "DMAX"} {
923                    set line [string replace $line 6 13 $value]
924                } else {
925                    set line [string replace $line 2 5 "DMAX"]
926                    set line [string replace $line 6 6 "$value "]
927                }
928            }
929            setexp $key $line 0 68
930        }
931        AngCalc-get {
932            set val [disagldat_get $phase]
933            return [lindex $val 1]
934        }
935        AngCalc-set {
936            set key "  DSGL CDAT$phase"
937            # for none delete the record & thats all folks
938            if {$value == "none"} {
939                catch {unset ::exparray($key)}
940                return
941            }
942            if {[existsexp $key] == 0} {
943                makeexprec $key
944            }
945            set line [readexp $key]
946            if {[string trim $line] == ""} {
947                # blank set to defaults
948                set line [string replace $line 2 15 "DRAD ARAD NOFO"]
949            }
950            if {[string range $line 2 5] == "DMAX"} {
951                set i2 8
952            } else {
953                set i2 0
954            }
955            if {$value == "radii"} {
956                if {[string range $line [expr {$i2+7}] [expr {$i2+10}]] == "DAGL"} {
957                    set line [string replace $line [expr {$i2+7}] [expr {$i2+18}] "ARAD"]
958                } else {
959                    set line [string replace $line [expr {$i2+7}] [expr {$i2+10}] "ARAD"]
960                }
961            } else {
962                if ![validreal value 8 2] {return 0}
963                if {[string range $line [expr {$i2+7}] [expr {$i2+10}]] == "DAGL"} {
964                    set line [string replace $line [expr {$i2+11}] [expr {$i2+18}] $value]
965                } else {
966                    set line [string replace $line [expr {$i2+7}] [expr {$i2+10}] "DAGL"]
967                    set line [string replace $line [expr {$i2+11}] [expr {$i2+11}] "$value "]
968                }
969            }
970            setexp $key $line 0 68
971        }
[11]972        default {
973            set msg "Unsupported phaseinfo access: parm=$parm action=$action"
[1025]974            tk_dialog .badexp "Error in readexp" $msg error 0 Exit
[11]975        }
976    }
977    return 1
978}
979
[236]980
[1025]981
[11]982# get atom information: atominfo phase atom parm action value
983#   phase: 1 to 9 (as defined)
984#   atom: a valid atom number [see expmap(atomlist_$phase)]
985#      Note that atom and phase can be paired lists, but if there are extra
986#      entries in the atoms list, the last phase will be repeated.
987#      so that atominfo 1 {1 2 3} xset 1
988#               will set the xflag for atoms 1-3 in phase 1
989#      but atominfo {1 2 3} {1 1 1} xset 1
990#               will set the xflag for atoms 1 in phase 1-3
991#   parm:
992#     type -- element code
[55]993#     mult -- atom multiplicity
[11]994#     label -- atom label (*)
995#     x y z -- coordinates (*)
996#     frac --  occupancy (*)
[253]997#     temptype -- I or A for Isotropic/Anisotropic (*)
[11]998#     Uiso  -- Isotropic temperature factor (*)
999#     U11  -- Anisotropic temperature factor (*)
1000#     U22  -- Anisotropic temperature factor (*)
1001#     U33  -- Anisotropic temperature factor (*)
1002#     U12  -- Anisotropic temperature factor (*)
[57]1003#     U13  -- Anisotropic temperature factor (*)
[11]1004#     U23  -- Anisotropic temperature factor (*)
1005#     xref/xdamp -- refinement flag/damping value for the coordinates (*)
1006#     uref/udamp -- refinement flag/damping value for the temperature factor(s)  (*)
1007#     fref/fdamp -- refinement flag/damping value for the occupancy (*)
1008#  action: get (default) or set
1009#  value: used only with set
1010#  * =>  read+write supported
1011proc atominfo {phaselist atomlist parm "action get" "value {}"} {
1012    foreach phase $phaselist atom $atomlist {
1013        if {$phase == ""} {set phase [lindex $phaselist end]}
1014        if {$atom < 10} {
1015            set key "CRS$phase  AT  $atom"
1016        } elseif {$atom < 100} {
1017            set key "CRS$phase  AT $atom"
1018        } else {
1019            set key "CRS$phase  AT$atom"
1020        }
1021        switch -glob ${parm}-$action {
1022            type-get {
1023                return [string trim [string range [readexp ${key}A] 2 9] ]
1024            }
[55]1025            mult-get {
1026                return [string trim [string range [readexp ${key}A] 58 61] ]
1027            }
[11]1028            label-get {
1029                return [string trim [string range [readexp ${key}A] 50 57] ]
1030            }
[49]1031            label-set {
1032                setexp ${key}A $value 51 8
1033            }
[11]1034            temptype-get {
1035                return [string trim [string range [readexp ${key}B] 62 62] ]
1036            }
[252]1037            temptype-set {
1038                if {$value == "A"} {
1039                    setexp ${key}B A 63 1
1040                    # copy the Uiso to the diagonal terms
[261]1041                    set Uiso [string range [readexp ${key}B] 0 9]
1042                    foreach value [CalcAniso $phase $Uiso] \
1043                            col {1 11 21 31 41 51} {
1044                        validreal value 10 6
1045                        setexp ${key}B $value $col 10
1046                    }
[252]1047                } else {
1048                    setexp ${key}B I 63 1
1049                    set value 0.0
1050                    catch {
1051                        # get the trace
[396]1052                        set value [expr {( \
[252]1053                                [string range [readexp ${key}B] 0 9] + \
1054                                [string range [readexp ${key}B] 10 19] + \
[396]1055                                [string range [readexp ${key}B] 20 29])/3.}]
[252]1056                    }
1057                    validreal value 10 6
1058                    setexp ${key}B $value 1 10
1059                    # blank out the remaining terms
1060                    set value " "
1061                    setexp ${key}B $value 11 10
1062                    setexp ${key}B $value 21 10
1063                    setexp ${key}B $value 31 10
1064                    setexp ${key}B $value 41 10
1065                    setexp ${key}B $value 51 10
1066                }
1067            }
[11]1068            x-get {
1069                return [string trim [string range [readexp ${key}A] 10 19] ]
1070            }
1071            x-set {
1072                if ![validreal value 10 6] {return 0}
1073                setexp ${key}A $value 11 10
1074            }
1075            y-get {
1076                return [string trim [string range [readexp ${key}A] 20 29] ]
1077            }
1078            y-set {
1079                if ![validreal value 10 6] {return 0}
1080                setexp ${key}A $value 21 10
1081            }
1082            z-get {
1083                return [string trim [string range [readexp ${key}A] 30 39] ]
1084            }
1085            z-set {
1086                if ![validreal value 10 6] {return 0}
1087                setexp ${key}A $value 31 10
1088            }
1089            frac-get {
1090                return [string trim [string range [readexp ${key}A] 40 49] ]
1091            }
1092            frac-set {
1093                if ![validreal value 10 6] {return 0}
1094                setexp ${key}A $value 41 10
1095            }
1096            U*-get {
1097                regsub U $parm {} type
1098                if {$type == "iso" || $type == "11"} {
1099                    return [string trim [string range [readexp ${key}B] 0 9] ]
1100                } elseif {$type == "22"} {
1101                    return [string trim [string range [readexp ${key}B] 10 19] ]
1102                } elseif {$type == "33"} {
1103                    return [string trim [string range [readexp ${key}B] 20 29] ]
1104                } elseif {$type == "12"} {
1105                    return [string trim [string range [readexp ${key}B] 30 39] ]
[57]1106                } elseif {$type == "13"} {
1107                    return [string trim [string range [readexp ${key}B] 40 49] ]
[11]1108                } elseif {$type == "23"} {
1109                    return [string trim [string range [readexp ${key}B] 50 59] ]
1110                }
1111            }
1112            U*-set {
1113                if ![validreal value 10 6] {return 0}
1114                regsub U $parm {} type
1115                if {$type == "iso" || $type == "11"} {
1116                    setexp ${key}B $value 1 10
1117                } elseif {$type == "22"} {
1118                    setexp ${key}B $value 11 10
1119                } elseif {$type == "33"} {
1120                    setexp ${key}B $value 21 10
1121                } elseif {$type == "12"} {
1122                    setexp ${key}B $value 31 10
[57]1123                } elseif {$type == "13"} {
1124                    setexp ${key}B $value 41 10
[11]1125                } elseif {$type == "23"} {
1126                    setexp ${key}B $value 51 10
1127                }
1128            }
1129            xref-get {
1130                if {[string toupper [string range [readexp ${key}B] 64 64]] == "X"} {
1131                    return 1
1132                }
1133                return 0
1134            }
1135            xref-set {
1136                if $value {
1137                    setexp ${key}B "X" 65 1
1138                } else {
1139                    setexp ${key}B " " 65 1
1140                }           
1141            }
1142            xdamp-get {
1143                set val [string range [readexp ${key}A] 64 64]
1144                if {$val == " "} {return 0}
1145                return $val
1146            }
1147            xdamp-set {
1148                setexp ${key}A $value 65 1
1149            }
1150            fref-get {
1151                if {[string toupper [string range [readexp ${key}B] 63 63]] == "F"} {
1152                    return 1
1153                }
1154                return 0
1155            }
1156            fref-set {
1157                if $value {
1158                    setexp ${key}B "F" 64 1
1159                } else {
1160                    setexp ${key}B " " 64 1
1161                }           
1162            }
1163            fdamp-get {
1164                set val [string range [readexp ${key}A] 63 63]
1165                if {$val == " "} {return 0}
1166                return $val
1167            }
1168            fdamp-set {
1169                setexp ${key}A $value 64 1
1170            }
1171
1172            uref-get {
1173                if {[string toupper [string range [readexp ${key}B] 65 65]] == "U"} {
1174                    return 1
1175                }
1176                return 0
1177            }
1178            uref-set {
1179                if $value {
1180                    setexp ${key}B "U" 66 1
1181                } else {
1182                    setexp ${key}B " " 66 1
1183                }           
1184            }
1185            udamp-get {
1186                set val [string range [readexp ${key}A] 65 65]
1187                if {$val == " "} {return 0}
1188                return $val
1189            }
1190            udamp-set {
1191                setexp ${key}A $value 66 1
1192            }
1193            default {
1194                set msg "Unsupported atominfo access: parm=$parm action=$action"
[252]1195                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
[11]1196            }
1197        }
1198    }
1199    return 1
1200}
1201
[544]1202# get macromolecular atom information: mmatominfo phase atom parm action value
1203#   phase: 1 (at present only one mm phase can be defined)
1204#   atom: a valid atom number [see expmap(atomlist_$phase)]
1205#      Note that atoms can be lists
1206#      so that mmatominfo 1 {1 2 3} xset 1
1207#               will set the xflag for atoms 1-3 in phase 1
1208#   parm:
1209#     type -- element code
1210#     frac --  occupancy (*)
1211#     x y z -- coordinates (*)
1212#     Uiso  -- Isotropic temperature factor (*)
1213#     label -- atom label (*)
1214#     residue -- residue label (*)
1215#     group -- group label (*)
1216#     resnum -- residue number (*)
1217#     xref/xdamp -- refinement flag/damping value for the coordinates (*)
1218#     uref/udamp -- refinement flag/damping value for the temperature factor(s)  (*)
1219#     fref/fdamp -- refinement flag/damping value for the occupancy (*)
1220#  action: get (default) or set
1221#  value: used only with set
1222#  * =>  read+write supported
1223proc mmatominfo {phaselist atomlist parm "action get" "value {}"} {
1224    foreach phase $phaselist atom $atomlist {
1225        if {$phase == ""} {set phase [lindex $phaselist end]}
1226        set num [string toupper [format %.4x $atom]]
1227        set key "CRS$phase  AT$num"
1228        switch -glob ${parm}-$action {
1229            type-get {
1230                return [string trim [string range [readexp ${key}] 2 9] ]
1231            }
1232            frac-get {
1233                return [string trim [string range [readexp ${key}] 10 15] ]
1234            }
1235            frac-set {
1236                if ![validreal value 6 4] {return 0}
1237                setexp ${key} $value 11 6
1238            }
1239            x-get {
1240                return [string trim [string range [readexp ${key}] 16 23] ]
1241            }
1242            x-set {
1243                if ![validreal value 8 5] {return 0}
1244                setexp ${key} $value 17 8
1245            }
1246            y-get {
1247                return [string trim [string range [readexp ${key}] 24 31] ]
1248            }
1249            y-set {
1250                if ![validreal value 8 5] {return 0}
1251                setexp ${key} $value 25 8
1252            }
1253            z-get {
1254                return [string trim [string range [readexp ${key}] 32 39] ]
1255            }
1256            z-set {
1257                if ![validreal value 8 5] {return 0}
1258                setexp ${key} $value 33 8
1259            }
1260            Uiso-get {
1261                return [string trim [string range [readexp ${key}] 40 45] ]
1262            }
1263            Uiso-set {
1264                if ![validreal value 6 4] {return 0}
1265                setexp ${key} $value 41 6
1266            }
1267            label-get {
1268                return [string trim [string range [readexp ${key}] 46 50] ]
1269            }
1270            label-set {
1271                setexp ${key} $value 47 5
1272            }
1273            residue-get {
1274                return [string range [readexp ${key}] 51 53]
1275            }
1276            residue-set {
1277                setexp ${key} $value 52 3
1278            }
1279            group-get {
1280                return [string range [readexp ${key}] 54 55]
1281            }
1282            group-set {
1283                setexp ${key} $value 55 2
1284            }
1285            resnum-get {
1286                return [string trim [string range [readexp ${key}] 56 59] ]
1287            }
1288            resnum-set {
1289                if ![validint value 4] {return 0}
1290                setexp "${key} EPHAS" $value 57 4
1291            }
1292            fref-get {
1293                if {[string toupper [string range [readexp $key] 60 60]] == "F"} {
1294                    return 1
1295                }
1296                return 0
1297            }
1298            fref-set {
1299                if $value {
1300                    setexp $key "F" 61 1
1301                } else {
1302                    setexp $key " " 61 1
1303                }           
1304            }
1305            xref-get {
1306                if {[string toupper [string range [readexp $key] 61 61]] == "X"} {
1307                    return 1
1308                }
1309                return 0
1310            }
1311            xref-set {
1312                if $value {
1313                    setexp $key "X" 62 1
1314                } else {
1315                    setexp ${key}B " " 62 1
1316                }           
1317            }
1318            uref-get {
1319                if {[string toupper [string range [readexp $key] 62 62]] == "U"} {
1320                    return 1
1321                }
1322                return 0
1323            }
1324            uref-set {
1325                if $value {
1326                    setexp $key "U" 63 1
1327                } else {
1328                    setexp $key " " 63 1
1329                }           
1330            }
1331
1332            fdamp-get {
1333                set val [string range [readexp ${key}] 63 63]
1334                if {$val == " "} {return 0}
1335                return $val
1336            }
1337            fdamp-set {
1338                setexp ${key} $value 64 1
1339            }
1340            xdamp-get {
1341                set val [string range [readexp ${key}] 64 64]
1342                if {$val == " "} {return 0}
1343                return $val
1344            }
1345            xdamp-set {
1346                setexp ${key} $value 65 1
1347            }
1348
1349            udamp-get {
1350                set val [string range [readexp ${key}] 65 65]
1351                if {$val == " "} {return 0}
1352                return $val
1353            }
1354            udamp-set {
1355                setexp ${key} $value 66 1
1356            }
1357            default {
1358                set msg "Unsupported mmatominfo access: parm=$parm action=$action"
1359                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
1360            }
1361        }
1362    }
1363    return 1
1364}
1365
1366
1367
[11]1368# get histogram information: histinfo histlist parm action value
1369# histlist is a list of histogram numbers
1370# parm:
1371#     title
[453]1372#     file  -- file name of raw data for histogram (*)
[11]1373#     scale (*)
1374#     sref/sdamp -- refinement flag/damping value for the scale factor (*)
1375#     lam1, lam2 (*)
1376#     ttref refinement flag for the 2theta (ED Xray) (*)
1377#     wref refinement flag for the wavelength (*)
1378#     ratref refinement flag for the wavelength ratio (*)
1379#     difc, difa -- TOF calibration constants (*)
1380#     dcref,daref -- refinement flag for difc, difa (*)
1381#     zero (*)
1382#     zref refinement flag for the zero correction (*)
1383#     ipola (*)
1384#     pola (*)
1385#     pref refinement flag for the polarization (*)
1386#     kratio (*)
1387#     ddamp -- damping value for the diffractometer constants (*)
1388#     backtype -- background function number *
1389#     backterms -- number of background terms *
1390#     bref/bdamp -- refinement flag/damping value for the background (*)
1391#     bterm$n -- background term #n (*)
1392#     bank -- Bank number
1393#     tofangle -- detector angle (TOF only)
1394#     foextract  -- Fobs extraction flag (*)
[396]1395#     LBdamp  -- LeBail damping value (*)
1396#     tmin/tmax -- minimum & maximum usable 2theta/TOF/energy
[415]1397#     excl -- excluded regions (*)
[429]1398#     dmin -- minimum d-space for reflection generation (*)
[453]1399#     use  -- use flag; 1 = use; 0 = do not use (*)
1400#     dstart -- dummy histogram starting tmin/emin/2theta (*)
1401#     dstep -- dummy histogram step size tmin/emin/2theta (*)
1402#     dpoints -- dummy histogram number of points (*)
[480]1403#     dtype   -- dummy histogram type (CONST or SLOG)
[559]1404#     abscor1 -- 1st absorption correction (*)
1405#     abscor2 -- 2nd absorption correction (*)
1406#     abstype -- absorption correction type (*)
1407#     absdamp -- damping for absorption refinement (*)
1408#     absref -- refinement damping for absorption refinement (*)
[1166]1409#     proftbl -- returns number of profile table terms
1410#     anomff -- returns a list of elements, f' and f"
[480]1411#   parameters transferred from the instrument parameter file:
1412#     ITYP    -- returns the contents of the ITYP record
[11]1413proc histinfo {histlist parm "action get" "value {}"} {
[124]1414    global expgui
[11]1415    foreach hist $histlist {
1416        if {$hist < 10} {
1417            set key "HST  $hist"
1418        } else {
1419            set key "HST $hist"
1420        }
1421        switch -glob ${parm}-$action {
1422            foextract-get {
[124]1423                set line [readexp "${key} EPHAS"]
1424                # add a EPHAS if not exists
1425                if {$line == {}} {
1426                    makeexprec "${key} EPHAS"
1427                    # expedt defaults this to "F", but I think "T" is better
[381]1428                    setexp "${key} EPHAS" "Y" 50 1
[124]1429                    if $expgui(debug) {puts "Warning: creating a ${key} EPHAS record"}
1430                }
1431                if {[string toupper [string range $line 49 49]] == "T"} {
[11]1432                    return 1
1433                }
[373]1434                # the flag has changed to "Y/N" in the latest versions
1435                # of GSAS
1436                if {[string toupper [string range $line 49 49]] == "Y"} {
1437                    return 1
1438                }
[11]1439                return 0
1440            }
1441            foextract-set {
[373]1442                # the flag has changed to "Y/N" in the latest versions
1443                # of GSAS
[381]1444                if $value {
1445                    setexp "${key} EPHAS" "Y" 50 1
1446                } else {
1447                    setexp "${key} EPHAS" "N" 50 1
[373]1448                }
[11]1449            }
[396]1450            LBdamp-get {
1451                set v [string trim [string range [readexp "${key} EPHAS"] 54 54]]
1452                if {$v == ""} {return 0}
1453                return $v
1454            }
1455            LBdamp-set {
1456                if ![validint value 5] {return 0}
1457                setexp "${key} EPHAS" $value 51 5
1458            }
[11]1459            title-get {
1460                return [string trim [readexp "${key}  HNAM"] ]
1461            }
1462            scale-get {
[1177]1463                if {![existsexp ${key}HSCALE]} {
1464                    # fix missing scale factor record
1465                    makeexprec ${key}HSCALE
1466                    set value 1.0
1467                    validreal value 15 6
1468                    setexp ${key}HSCALE $value 1 15
1469                    catch {incr ::expgui(changed)}
1470                    setexp ${key}HSCALE "N" 20 1
1471                }
[11]1472                return [string trim [string range [readexp ${key}HSCALE] 0 14]]
1473            }
1474            scale-set {
1475                if ![validreal value 15 6] {return 0}
1476                setexp ${key}HSCALE $value 1 15
1477            }
1478            sref-get {
1479                if {[string toupper [string range [readexp ${key}HSCALE] 19 19]] == "Y"} {
1480                    return 1
1481                }
1482                return 0
1483            }
1484            sref-set {
1485                if $value {
1486                    setexp ${key}HSCALE "Y" 20 1
1487                } else {
1488                    setexp ${key}HSCALE "N" 20 1
1489                }           
1490            }
1491            sdamp-get {
1492                set val [string range [readexp ${key}HSCALE] 24 24]
1493                if {$val == " "} {return 0}
1494                return $val
1495            }
1496            sdamp-set {
1497                setexp ${key}HSCALE $value 25 1
1498            }
1499
1500            difc-get -
1501            lam1-get {
1502                return [string trim [string range [readexp "${key} ICONS"] 0 9]]
1503            }
1504            difc-set -
1505            lam1-set {
1506                if ![validreal value 10 7] {return 0}
1507                setexp "${key} ICONS" $value 1 10
[674]1508                # set the powpref warning (1 = suggested)
1509                catch {
1510                    global expgui
1511                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1512                    set msg "Diffractometer constants" 
1513                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1514                        append expgui(needpowpref_why) "\t$msg were changed\n"
1515                    }
1516                }
[11]1517            }
1518            difa-get -
1519            lam2-get {
1520                return [string trim [string range [readexp "${key} ICONS"] 10 19]]
1521            }
1522            difa-set -
1523            lam2-set {
1524                if ![validreal value 10 7] {return 0}
1525                setexp "${key} ICONS" $value 11 10
[674]1526                # set the powpref warning (1 = suggested)
1527                catch {
1528                    global expgui
1529                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1530                    set msg "Diffractometer constants" 
1531                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1532                        append expgui(needpowpref_why) "\t$msg were changed\n"
1533                    }
1534                }
[11]1535            }
1536            zero-get {
1537                return [string trim [string range [readexp "${key} ICONS"] 20 29]]
1538            }
1539            zero-set {
1540                if ![validreal value 10 5] {return 0}
1541                setexp "${key} ICONS" $value 21 10
[674]1542                # set the powpref warning (1 = suggested)
1543                catch {
1544                    global expgui
1545                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1546                    set msg "Diffractometer constants" 
1547                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1548                        append expgui(needpowpref_why) "\t$msg were changed\n"
1549                    }
1550                }
[11]1551            }
1552            ipola-get {
1553                return [string trim [string range [readexp "${key} ICONS"] 54 54]]
1554            }
1555            ipola-set {
1556                if ![validint value 1] {return 0}
1557                setexp "${key} ICONS" $value 55 1
1558            }
1559            pola-get {
1560                return [string trim [string range [readexp "${key} ICONS"] 40 49]]
1561            }
1562            pola-set {
1563                if ![validreal value 10 5] {return 0}
1564                setexp "${key} ICONS" $value 41 10
1565            }
1566            kratio-get {
[792]1567                set val [string trim [string range [readexp "${key} ICONS"] 55 64]]
1568                if {$val == ""} {set val 0}
1569                # N.B. this code is used w/CW, where Kratio may not be 0.0
1570                set lam2 [string trim [string range [readexp "${key} ICONS"] 10 19]]
1571                if {$lam2 == ""} {set lam2 0}
1572                # Change kratio & flag the change (this is rather kludged)
1573                if {$val == 0 && $lam2 != 0} {
1574                    set val 0.5
1575                    validreal val 10 5
1576                    setexp "${key} ICONS" $val 56 10
1577                    catch {incr ::expgui(changed)}
1578                }
1579                return $val
[11]1580            }
1581            kratio-set {
1582                if ![validreal value 10 5] {return 0}
1583                setexp "${key} ICONS" $value 56 10
1584            }
1585
1586            wref-get {
1587            #------------------------------------------------------
1588            # col 33: refine flag for lambda, difc, ratio and theta
1589            #------------------------------------------------------
1590                if {[string toupper [string range \
1591                        [readexp "${key} ICONS"] 32 32]] == "L"} {
1592                    return 1
1593                }
1594                return 0
1595            }
1596            wref-set {
1597                if $value {
1598                    setexp "${key} ICONS" "L" 33 1
1599                } else {
1600                    setexp "${key} ICONS" " " 33 1
1601                }           
1602            }
1603            ratref-get {
1604                if {[string toupper [string range \
1605                        [readexp "${key} ICONS"] 32 32]] == "R"} {
1606                    return 1
1607                }
1608                return 0
1609            }
1610            ratref-set {
1611                if $value {
1612                    setexp "${key} ICONS" "R" 33 1
1613                } else {
1614                    setexp "${key} ICONS" " " 33 1
1615                }           
1616            }
1617            dcref-get {
1618                if {[string toupper [string range \
1619                        [readexp "${key} ICONS"] 32 32]] == "C"} {
1620                    return 1
1621                }
1622                return 0
1623            }
1624            dcref-set {
1625                if $value {
1626                    setexp "${key} ICONS" "C" 33 1
1627                } else {
1628                    setexp "${key} ICONS" " " 33 1
1629                }           
1630            }
1631            ttref-get {
1632                if {[string toupper [string range \
1633                        [readexp "${key} ICONS"] 32 32]] == "T"} {
1634                    return 1
1635                }
1636                return 0
1637            }
1638            ttref-set {
1639                if $value {
1640                    setexp "${key} ICONS" "T" 33 1
1641                } else {
1642                    setexp "${key} ICONS" " " 33 1
1643                }           
1644            }
1645
1646
1647            pref-get {
1648            #------------------------------------------------------
1649            # col 34: refine flag for POLA & DIFA
1650            #------------------------------------------------------
1651                if {[string toupper [string range \
1652                        [readexp "${key} ICONS"] 33 33]] == "P"} {
1653                    return 1
1654                }
1655                return 0
1656            }
1657            pref-set {
1658                if $value {
1659                    setexp "${key} ICONS" "P" 34 1
1660                } else {
1661                    setexp "${key} ICONS" " " 34 1
1662                }           
1663            }
1664            daref-get {
1665                if {[string toupper [string range \
1666                        [readexp "${key} ICONS"] 33 33]] == "A"} {
1667                    return 1
1668                }
1669                return 0
1670            }
1671            daref-set {
1672                if $value {
1673                    setexp "${key} ICONS" "A" 34 1
1674                } else {
1675                    setexp "${key} ICONS" " " 34 1
1676                }           
1677            }
1678
1679            zref-get {
1680            #------------------------------------------------------
1681            # col 34: refine flag for zero correction
1682            #------------------------------------------------------
1683                if {[string toupper [string range [readexp "${key} ICONS"] 34 34]] == "Z"} {
1684                    return 1
1685                }
1686                return 0
1687            }
1688            zref-set {
1689                if $value {
1690                    setexp "${key} ICONS" "Z" 35 1
1691                } else {
1692                    setexp "${key} ICONS" " " 35 1
1693                }           
1694            }
1695
1696            ddamp-get {
1697                set val [string range [readexp "${key} ICONS"] 39 39]
1698                if {$val == " "} {return 0}
1699                return $val
1700            }
1701            ddamp-set {
1702                setexp "${key} ICONS" $value 40 1
1703            }
1704
1705            backtype-get {
1706                set val [string trim [string range [readexp "${key}BAKGD "] 0 4]]
1707                if {$val == " "} {return 0}
1708                return $val
1709            }
1710            backtype-set {
1711                if ![validint value 5] {return 0}
1712                setexp "${key}BAKGD " $value 1 5
1713            }
1714            backterms-get {
1715                set val [string trim [string range [readexp "${key}BAKGD "] 5 9]]
1716                if {$val == " "} {return 0}
1717                return $val
1718            }
1719            backterms-set {
1720                # this takes a bit of work -- if terms are added, add lines as needed to the .EXP
1721                set oldval [string trim [string range [readexp "${key}BAKGD "] 5 9]]
1722                if ![validint value 5] {return 0}
1723                if {$oldval < $value} {
[396]1724                    set line1  [expr {2 + ($oldval - 1) / 4}]
1725                    set line2  [expr {1 + ($value - 1) / 4}]
[11]1726                    for {set i $line1} {$i <= $line2} {incr i} {
1727                        # create a blank entry if needed
1728                        makeexprec ${key}BAKGD$i
1729                    }
1730                    incr oldval
1731                    for {set num $oldval} {$num <= $value} {incr num} {
[396]1732                        set f1 [expr {15*(($num - 1) % 4)}]
1733                        set f2 [expr {15*(1 + ($num - 1) % 4)-1}]
1734                        set line  [expr {1 + ($num - 1) / 4}]
[11]1735                        if {[string trim [string range [readexp ${key}BAKGD$line] $f1 $f2]] == ""} {
[396]1736                            set f1 [expr {15*(($num - 1) % 4)+1}]
[11]1737                            setexp ${key}BAKGD$line 0.0 $f1 15                 
1738                        }
1739                    }
1740                }
1741                setexp "${key}BAKGD " $value 6 5
1742
1743            }
1744            bref-get {
1745                if {[string toupper [string range [readexp "${key}BAKGD"] 14 14]] == "Y"} {
1746                    return 1
1747                }
1748                return 0
1749            }
1750            bref-set {
1751                if $value {
1752                    setexp "${key}BAKGD "  "Y" 15 1
1753                } else {
1754                    setexp "${key}BAKGD "  "N" 15 1
[396]1755                }
[11]1756            }
1757            bdamp-get {
1758                set val [string range [readexp "${key}BAKGD "] 19 19]
1759                if {$val == " "} {return 0}
1760                return $val
1761            }
1762            bdamp-set {
1763                setexp "${key}BAKGD " $value 20 1
1764            }
1765            bterm*-get {
1766                regsub bterm $parm {} num
[396]1767                set f1 [expr {15*(($num - 1) % 4)}]
1768                set f2 [expr {15*(1 + ($num - 1) % 4)-1}]
1769                set line  [expr {1 + ($num - 1) / 4}]
[11]1770                return [string trim [string range [readexp ${key}BAKGD$line] $f1 $f2] ]
1771            }
1772            bterm*-set {
1773                regsub bterm $parm {} num
1774                if ![validreal value 15 6] {return 0}
[396]1775                set f1 [expr {15*(($num - 1) % 4)+1}]
1776                set line  [expr {1 + ($num - 1) / 4}]
[11]1777                setexp ${key}BAKGD$line $value $f1 15
1778            }
1779            bank-get {
1780                return [string trim [string range [readexp "${key} BANK"] 0 4]]
1781            }
1782            tofangle-get {
1783                return [string trim [string range [readexp "${key}BNKPAR"] 10 19]]
1784            }
[396]1785            tmin-get {
1786                return [string trim [string range [readexp "${key} TRNGE"] 0 9]]
1787            }
1788            tmax-get {
1789                return [string trim [string range [readexp "${key} TRNGE"] 10 19]]
1790            }
[415]1791            excl-get {
1792                set n [string trim [string range [readexp "${key} NEXC"] 0 4]]
1793                set exlist {}
1794                for {set i 1} {$i <= $n} {incr i} {
[634]1795                    set line [readexp [format "${key}EXC%3d" $i]]
1796                    lappend exlist [list \
1797                            [string trim [string range $line  0  9]] \
1798                            [string trim [string range $line 10 19]]]
[415]1799                }
1800                return $exlist
1801            }
1802            excl-set {
1803                set n [llength $value]
1804                if ![validint n 5] {return 0}
1805                setexp "${key} NEXC" $n 1 5
1806                set i 0
1807                foreach p $value {
1808                    incr i
1809                    foreach {r1 r2} $p {}
1810                    validreal r1 10 3
1811                    validreal r2 10 3
1812                    set k [format "${key}EXC%3d" $i]
1813                    if {![existsexp $k]} {
1814                        makeexprec $k
1815                    }
1816                    setexp $k ${r1}${r2} 1 20
1817                }
[674]1818                # set the powpref warning (2 = required)
1819                catch {
1820                    global expgui
1821                    set expgui(needpowpref) 2
1822                    set msg "Excluded regions" 
1823                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1824                        append expgui(needpowpref_why) "\t$msg were changed\n"
1825                    }
1826                }
[415]1827            }
1828            file-get {
1829                return [string trim [readexp "${key}  HFIL"] ]
1830            }
[429]1831            file-set {
1832                setexp "${key}  HFIL" $value 3 65
1833            }
[415]1834            bank-get {
1835                return [string trim [string range [readexp "${key} BANK"] 0 4]]
1836            }
[429]1837            dmin-get {
1838                return [string trim [string range [readexp "${key} NREF"] 5 14]]
1839            }
1840            dmin-set {
1841                if ![validreal value 10 4] {return 0}
1842                setexp "${key} NREF" $value 6 10
[674]1843                # set the powpref warning (2 = required)
1844                catch {
1845                    global expgui
1846                    set expgui(needpowpref) 2
1847                    set msg "Dmin (reflection range)" 
1848                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1849                        append expgui(needpowpref_why) "\t$msg was changed\n"
1850                    }
1851                }
[429]1852            }
[453]1853            use-get {
1854                set k [expr {($hist+11)/12}]
1855                set line [readexp " EXPR  HTYP$k"]
1856                set j [expr {((($hist-1) % 12)+1)*5}]
1857                if {[string range $line $j $j] == "*"} {return 0}
1858                return 1
1859            }
1860            use-set {
1861                set k [expr {($hist+11)/12}]
1862                set line [readexp " EXPR  HTYP$k"]
1863                set j [expr {((($hist-1) % 12)+1)*5+1}]
1864                if {$value} {
1865                    setexp " EXPR  HTYP$k" " " $j 1
1866                } else {
1867                    setexp " EXPR  HTYP$k" "*" $j 1
1868                }
[674]1869                # set the powpref warning (2 = required)
1870                catch {
1871                    global expgui
1872                    set expgui(needpowpref) 2
1873                    set msg "Histogram use flags" 
1874                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1875                        append expgui(needpowpref_why) "\t$msg were changed\n"
1876                    }
1877                }
[453]1878            }
1879            dstart-get {
1880                return [string trim [string range [readexp "${key} DUMMY"] 20 29]]
1881            }
1882            dstart-set {
1883                if ![validreal value 10 3] {return 0}
1884                setexp "${key} DUMMY" $value 21 10
[674]1885                # set the powpref warning (1 = suggested)
1886                catch {
1887                    global expgui
1888                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1889                    set msg "Dummy histogram parameters" 
1890                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1891                        append expgui(needpowpref_why) "\t$msg were changed\n"
1892                    }
1893                }
[453]1894            }
1895            dstep-get {
1896                return [string trim [string range [readexp "${key} DUMMY"] 30 39]]
1897            }
1898            dstep-set {
1899                if ![validreal value 10 3] {return 0}
1900                setexp "${key} DUMMY" $value 31 10
[674]1901                catch {
1902                    global expgui
1903                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1904                    set msg "Dummy histogram parameters" 
1905                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1906                        append expgui(needpowpref_why) "\t$msg were changed\n"
1907                    }
1908                }
[453]1909            }
1910            dpoints-get {
1911                return [string trim [string range [readexp "${key} DUMMY"] 0 9]]
1912            }
1913            dpoints-set {
1914                if ![validint value 10] {return 0}
1915                setexp "${key} DUMMY" $value 1 10
[674]1916                catch {
1917                    global expgui
1918                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
1919                    set msg "Dummy histogram parameters" 
1920                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
1921                        append expgui(needpowpref_why) "\t$msg were changed\n"
1922                    }
1923                }
[453]1924            }
[480]1925            dtype-get {
1926                return [string trim [string range [readexp "${key} DUMMY"] 10 19]]
1927            }
[544]1928            abscor1-get {
1929                return [string trim [string range [readexp "${key}ABSCOR"] 0 14]]
1930            }
[559]1931            abscor1-set {
[674]1932                if ![validreal value 15 7] {return 0}
[559]1933                setexp "${key}ABSCOR" $value 1 15
1934            }
[544]1935            abscor2-get {
1936                return [string trim [string range [readexp "${key}ABSCOR"] 15 29]]
1937            }
[559]1938            abscor2-set {
[1033]1939                # this must have a decimal as the 5th character, so that we end up with a
1940                # decimal point in column 20.
1941                set tmp $value
1942                if ![validreal tmp 12 7] {return 0}
1943                set pos [string first "." $tmp]
1944                while {$pos < 4} {
1945                    set tmp " $tmp"
1946                    set pos [string first "." $tmp]
1947                }
1948                if {$pos == 4} {
1949                    setexp "${key}ABSCOR" $tmp 16 15
1950                    return
1951                }
1952                catch {
1953                    set tmp [format "%12.6E" $value]
1954                    set pos [string first "." $tmp]
1955                    while {$pos < 4} {
1956                        set tmp " $tmp"
1957                        set pos [string first "." $tmp]
[712]1958                    }
[1033]1959                    if {$pos == 4} {
1960                        setexp "${key}ABSCOR" $tmp 16 15
1961                        return
1962                    }
1963                }
1964                return 0
[559]1965            }
[544]1966            abstype-get {
[702]1967                set val [string trim [string range [readexp "${key}ABSCOR"] 40 44]]
1968                if {$val == ""} {set val 0}
1969                return $val
[544]1970            }
[559]1971            abstype-set {
1972                if ![validint value 5] {return 0}
1973                setexp "${key}ABSCOR" $value 41 5
1974            }
1975            absdamp-get {
1976                set val [string range [readexp "${key}ABSCOR"] 39 39]
1977                if {$val == " "} {return 0}
1978                return $val
1979            }
1980            absdamp-set {
[674]1981                if ![validint value 5] {return 0}
1982                setexp "${key}ABSCOR" $value 36 5
[559]1983            }
1984            absref-get {
1985                if {[string toupper \
1986                        [string range [readexp "${key}ABSCOR"] 34 34]] == "Y"} {
1987                    return 1
1988                }
1989                return 0
1990            }
1991            absref-set {
1992                if $value {
[674]1993                    setexp "${key}ABSCOR" "    Y" 31 5
[559]1994                } else {
[674]1995                    setexp "${key}ABSCOR" "    N" 31 5
[559]1996                }
1997            }
[480]1998            ITYP-get {
1999                return [string trim [readexp "${key}I ITYP"]]
2000            }
[992]2001            proftbl-get {
2002                set line [readexp "${key}PAB3"]
2003                if {$line == ""} {return 0}
2004                set val [string trim [string range $line 0 4]]
2005                if {$val == ""} {return 0}
2006                return $val
2007            }
[1166]2008            anomff-get {
2009                set l {}
2010                foreach i {1 2 3 4 5 6 7 8 9} {
2011                    if {![existsexp "${key}FFANS$i"]} continue
2012                    set line [readexp "${key}FFANS$i"]
2013                    set elem [string trim [string range $line 2 9]]
2014                    set fp [string trim [string range $line 10 19]]
2015                    set fpp [string trim [string range $line 20 29]]
2016                    lappend l [list $elem $fp $fpp]
2017                }
2018                return $l
2019            }
2020            anomff-set {
2021                # match up input against elements in list.
2022                # change elements included, return any elements that are
2023                # not found.
2024                set errorlist {}
2025                foreach triplet $value {
2026                    foreach {e fp fpp} $triplet {}               
2027                    foreach i {1 2 3 4 5 6 7 8 9} {
2028                        if {![existsexp "${key}FFANS$i"]} continue
2029                        # note that the element name is not used or validated
2030                        set elem [string trim [string range \
2031                                                   [readexp "${key}FFANS$i"] 2 9]]
[1237]2032                        if {[string match -nocase $e $elem]} {
2033                            # seems to be a bug in GSAS if anom FF use too many digits,
2034                            # many digits, or perhaps due to exponential notation. Restricting
2035                            # the length to use the last 6 digits on output is a work around.
2036                            if ![validreal fp 6 3] {return 0}
2037                            setexp "${key}FFANS$i" "    $fp" 11 10
2038                            if ![validreal fpp 6 3] {return 0}
2039                            setexp "${key}FFANS$i" "    $fpp" 21 10
[1166]2040                            set e {}
2041                            break
2042                        }
2043                    }
2044                    if {$e != ""} {
2045                        # oops, no match
2046                        lappend errorlist $e
2047                    }
2048                }
2049                if {$errorlist != ""} {return [list 0 $errorlist]}
2050            }
[11]2051            default {
2052                set msg "Unsupported histinfo access: parm=$parm action=$action"
[252]2053                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
[11]2054            }
2055        }
2056    }
2057    return 1
2058}
2059
[1227]2060proc add_anomff {histlist type {fp 0} {fpp 0}} {
2061    global expgui
2062    foreach hist $histlist {
2063        if {$hist < 10} {
2064            set key "HST  $hist"
2065        } else {
2066            set key "HST $hist"
2067        }
2068        if ![validreal fp 10 3] {return 0}
2069        if ![validreal fpp 10 3] {return 0}
2070        foreach i {1 2 3 4 5 6 7 8 9} {
2071            if {![existsexp "${key}FFANS$i"]} {
2072                makeexprec "${key}FFANS$i"
2073                setexp "${key}FFANS$i" [string trim $type] 3 8
2074                setexp "${key}FFANS$i" $fp 11 10
2075                setexp "${key}FFANS$i" $fpp 21 10
2076                setexp "${key}FFANS$i" "NN" 34 2
2077                return 1
2078            }
2079        }
2080        return 0
2081    }
2082}
2083
[11]2084# read the information that differs by both histogram and phase (profile & phase fraction)
2085# use: hapinfo hist phase parm action value
2086
2087#     frac -- phase fraction (*)
2088#     frref/frdamp -- refinement flag/damping value for the phase fraction (*)
[229]2089#     proftype -- profile function number (*)
2090#     profterms -- number of profile terms (*)
[11]2091#     pdamp -- damping value for the profile (*)
2092#     pcut -- cutoff value for the profile (*)
[229]2093#     pterm$n -- profile term #n (*)
[11]2094#     pref$n -- refinement flag value for profile term #n (*)
2095#     extmeth -- Fobs extraction method (*)
[196]2096#     POnaxis -- number of defined M-D preferred axes
[11]2097proc hapinfo {histlist phaselist parm "action get" "value {}"} {
2098    foreach phase $phaselist hist $histlist {
2099        if {$phase == ""} {set phase [lindex $phaselist end]}
2100        if {$hist == ""} {set hist [lindex $histlist end]}
2101        if {$hist < 10} {
2102            set hist " $hist"
2103        }
2104        set key "HAP${phase}${hist}"
2105        switch -glob ${parm}-$action {
2106            extmeth-get {
[396]2107                set i1 [expr {($phase - 1)*5}]
2108                set i2 [expr {$i1 + 4}]
[11]2109                return [string trim [string range [readexp "HST $hist EPHAS"] $i1 $i2]]
2110            }
2111            extmeth-set {
[396]2112                set i1 [expr {($phase - 1)*5 + 1}]
[11]2113                if ![validint value 5] {return 0}
2114                setexp "HST $hist EPHAS" $value $i1 5
2115            }
2116            frac-get {
2117                return [string trim [string range [readexp ${key}PHSFR] 0 14]]
2118            }
2119            frac-set {
2120                if ![validreal value 15 6] {return 0}
2121                setexp ${key}PHSFR $value 1 15
2122            }
2123            frref-get {
2124                if {[string toupper [string range [readexp ${key}PHSFR] 19 19]] == "Y"} {
2125                    return 1
2126                }
2127                return 0
2128            }
2129            frref-set {
2130                if $value {
2131                    setexp ${key}PHSFR "Y" 20 1
2132                } else {
2133                    setexp ${key}PHSFR "N" 20 1
2134                }           
2135            }
2136            frdamp-get {
2137                set val [string range [readexp ${key}PHSFR] 24 24]
2138                if {$val == " "} {return 0}
2139                return $val
2140            }
2141            frdamp-set {
2142                setexp ${key}PHSFR $value 25 1
2143            }
2144            proftype-get {
2145                set val [string range [readexp "${key}PRCF "] 0 4]
2146                if {$val == " "} {return 0}
2147                return $val
2148            }
[229]2149            proftype-set {
2150                if ![validint value 5] {return 0}
2151                setexp "${key}PRCF " $value 1 5
[674]2152                # set the powpref warning (1 = suggested)
2153                catch {
2154                    global expgui
2155                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
2156                    set msg "Profile parameters" 
2157                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
2158                        append expgui(needpowpref_why) "\t$msg were changed\n"
2159                    }
2160                }
[229]2161            }
[11]2162            profterms-get {
2163                set val [string range [readexp "${key}PRCF "] 5 9]
2164                if {$val == " "} {return 0}
2165                return $val
2166            }
[229]2167            profterms-set {
2168                if ![validint value 5] {return 0}
2169                setexp "${key}PRCF " $value 6 5
2170                # now check that all needed entries exist
[396]2171                set lines [expr {1 + ($value - 1) / 4}]
[229]2172                for {set i 1} {$i <= $lines} {incr i} {
2173                    makeexprec "${key}PRCF $i"
2174                }
[674]2175                # set the powpref warning (1 = suggested)
2176                catch {
2177                    global expgui
2178                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
2179                    set msg "Profile parameters" 
2180                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
2181                        append expgui(needpowpref_why) "\t$msg were changed\n"
2182                    }
2183                }
[229]2184            }
[11]2185            pcut-get {
2186                return [string trim [string range [readexp "${key}PRCF "] 10 19]]
2187            }
2188            pcut-set {
2189                if ![validreal value 10 5] {return 0}
2190                setexp "${key}PRCF " $value 11 10
[674]2191                # set the powpref warning (1 = suggested)
2192                catch {
2193                    global expgui
2194                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
2195                    set msg "Profile parameters" 
2196                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
2197                        append expgui(needpowpref_why) "\t$msg were changed\n"
2198                    }
2199                }
[11]2200            }
2201            pdamp-get {
2202                set val [string range [readexp "${key}PRCF "] 24 24]
2203                if {$val == " "} {return 0}
2204                return $val
2205            }
2206            pdamp-set {
2207                setexp "${key}PRCF   " $value 25 1
2208            }
2209            pterm*-get {
2210                regsub pterm $parm {} num
[396]2211                set f1 [expr {15*(($num - 1) % 4)}]
2212                set f2 [expr {15*(1 + ($num - 1) % 4)-1}]
2213                set line  [expr {1 + ($num - 1) / 4}]
[11]2214                return [string trim [string range [readexp "${key}PRCF $line"] $f1 $f2] ]
2215            }
2216            pterm*-set {
2217                if ![validreal value 15 6] {return 0}
2218                regsub pterm $parm {} num
[396]2219                set f1 [expr {1+ 15*(($num - 1) % 4)}]
2220                set line  [expr {1 + ($num - 1) / 4}]
[11]2221                setexp "${key}PRCF $line" $value $f1 15
[674]2222                # set the powpref warning (1 = suggested)
2223                catch {
2224                    global expgui
2225                    if {$expgui(needpowpref) == 0} {set expgui(needpowpref) 1}
2226                    set msg "Profile parameters" 
2227                    if {[string first $msg $expgui(needpowpref_why)] == -1} {
2228                        append expgui(needpowpref_why) "\t$msg were changed\n"
2229                    }
2230                }
[11]2231            }
2232            pref*-get {
2233                regsub pref $parm {} num
[396]2234                set f [expr {24+$num}]
[11]2235                if {[string toupper [string range [readexp "${key}PRCF  "] $f $f]] == "Y"} {
2236                    return 1
2237                }
2238                return 0
2239            }
2240            pref*-set {
2241                regsub pref $parm {} num
[396]2242                set f [expr {25+$num}]
[11]2243                if $value {
2244                    setexp ${key}PRCF "Y" $f 1
2245                } else {
2246                    setexp ${key}PRCF "N" $f 1
2247                }           
2248            }
[196]2249            POnaxis-get {
2250                set val [string trim \
2251                        [string range [readexp "${key}NAXIS"] 0 4]]
2252                if {$val == ""} {return 0}
2253                return $val
2254            }
2255            POnaxis-set {
2256                if ![validint value 5] {return 0}
2257                # there should be a NAXIS record, but if not make one
2258                if {![existsexp "${key}NAXIS"]} {
2259                    makeexprec "${key}NAXIS"
2260                }
2261                setexp "${key}NAXIS  " $value 1 5
2262            }
[11]2263            default {
2264                set msg "Unsupported hapinfo access: parm=$parm action=$action"
[252]2265                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
[11]2266            }
2267        }
2268    }
2269    return 1
2270}
2271
[1219]2272#  read fixed constraints for a phase
[1166]2273proc atom_constraint_read {phase} {
[1219]2274    set fixlist ""
[1166]2275    foreach k {1 2 3 4 5 6 7 8 9} {
2276        set key [format "LEQV HOLD%1d%2d" $phase $k]
2277        set line [readexp $key]
2278        foreach j {2 10 18 26 34 42 50 58} {
2279            set fix_param [string range $line $j [expr $j+7]]
[1219]2280            if {[string trim $fix_param] == ""} {return $fixlist}
2281            lappend fixlist $fix_param
[1166]2282        }
2283    }
[1219]2284    return $fixlist
[1166]2285}
2286
2287# load all atom constraints into global array fix_param
2288proc atom_constraint_load { } {
2289    catch {unset ::fix_param}
2290    foreach i $::expmap(phaselist) {
2291        set temp [atom_constraint_read $i]
2292        foreach j $temp {
2293            set atomnum [string trim [string range $j 2 3]]
2294            set param [string trim [string range $j 4 6]]
2295            set ::fix_param($i,$atomnum,$param) 1   
2296        }
2297    }
2298}
2299
[1219]2300# returns 1 if the specified variable is fixed
2301proc atom_constraint_get {phase atom type} {
2302    if {[array names ::fix_param "$phase,$atom,$type"] == ""} {
2303        return 0
2304    }
2305    return 1
2306}
2307
2308proc atom_constraint_set {phase atomlist type mode} {
2309    foreach atom $atomlist {
2310        set key "$phase,$atom,$type"
2311        if {$mode} {
2312            set ::fix_param($key) 1
2313        } else {
2314            array unset ::fix_param $key
2315        }
2316    } 
2317    set fixlist {}
2318    foreach key [array names ::fix_param "$phase,*"] {
2319        foreach {j atom parm} [split $key ","] {}
2320        lappend fixlist \
2321            [format "%1s %+2s%-4s" $phase $atom $parm]
2322    }
[1166]2323    foreach key [array names ::exparray "LEQV HOLD$phase*"] {
2324        delexp $key
2325    }
2326    set k 0
2327    set j 1
2328    set line ""
[1219]2329    foreach fix $fixlist {
[1166]2330        incr k
2331        append line $fix
2332        if {$k == 8} {
2333            set key [format "LEQV HOLD%1d%2d" $phase $j]
2334            makeexprec $key
2335            setexp $key $line 3 [expr ($k * 8) + 2]
2336            set k 0
2337            incr j
2338            set line ""
2339        }
2340    }
2341    if {$line != ""} {
2342        set key [format "LEQV HOLD%1d%2d" $phase $j]
2343        makeexprec $key
2344        setexp $key $line 3 [expr ($k * 8) + 2]
2345    }   
2346}
2347
2348
[129]2349#  get a logical constraint
[229]2350#
[129]2351#  type action
2352#  -----------
[229]2353#  atom get  number        returns a list of constraints.
2354#   "   set  number value  replaces a list of constraints
2355#                          (value is a list of constraints)
2356#   "   add  number value  inserts a new list of constraints
2357#                          (number is ignored)
2358#   "   delete number      deletes a set of constraint entries
[129]2359# Each item in the list of constraints is composed of 4 items:
[229]2360#              phase, atom, variable, multiplier
2361# If variable=UISO atom can be ALL, otherwise atom is a number
[129]2362# legal variable names: FRAC, X, Y, Z, UISO, U11, U22, U33, U12, U23, U13,
2363#                       MX, MY, MZ
[229]2364#
2365#  type action
2366#  -----------
2367#  profileXX get number         returns a list of constraints for term XX=1-36
2368#                               use number=0 to get # of defined
2369#                                  constraints for term XX
2370#   "        set number value   replaces a list of constraints
2371#                               (value is a list of constraints)
2372#   "        add number value   inserts a new list of constraints
2373#                               (number is ignored)
2374#   "        delete number      deletes a set of constraint entries
2375# Each item in the list of constraints is composed of 3 items:
2376#              phase-list, histogram-list, multiplier
2377# Note that phase-list and/or histogram-list can be ALL
[1219]2378#
2379#  type action
2380#  -----------
2381#  absorbX get number         returns a list of constraints for term X=1 or 2
2382#   returns a the number of constraints for number = 0
2383#   returns a list of lists {{hist mult} {hist mult} ...}
[229]2384
[1219]2385#  absorbX set number value   replaces a list of constraints
2386#      number corresponds to a specific constraint see "absorbX get 0"
2387#      value is a list of lists {{hist mult} {hist mult} ...}
2388#  absorbX add number value   inserts a new list of constraints
2389#                               (number is ignored)
2390#  absorbX  delete number      deletes a set of constraint entries and renumbers
2391# note that hist can be:
2392#      a histogram number (such as 2) or
2393#      range of histograms (such as 1:10 or 11:99, etc.) or
2394#      the string "ALL"
2395
[129]2396proc constrinfo {type action number "value {}"} {
[544]2397    global expmap
2398    if {[lindex $expmap(phasetype) 0] == 4} {
2399        set mm 1
2400    } else {
2401        set mm 0
2402    }
[129]2403    switch -glob ${type}-$action {
2404        atom-get {
2405            # does this constraint exist?
2406            set key [format "LNCN%4d%4d" $number 1]
2407            if {![existsexp $key]} {return -1}
2408            set clist {}
2409            for {set i 1} {$i < 999} {incr i} {
2410                set key [format "LNCN%4d%4d" $number $i]
2411                if {![existsexp $key]} break
2412                set line [readexp $key]
2413                set j1 2
2414                set j2 17
2415                set seg [string range $line $j1 $j2]
2416                while {[string trim $seg] != ""} {
[544]2417                    set p [string range $seg 0 0]
2418                    if {$p == 1 && $mm} {
2419                        set atom [string trim [string range $seg 1 4]]
2420                        set var [string trim [string range $seg 5 7]]
2421                        if {$atom == "ALL"} {
2422                            set var UIS
2423                        } else {
2424                            scan $atom %x atom
2425                        }
2426                        lappend clist [list $p $atom $var \
2427                                [string trim [string range $seg 8 end]]]
2428                    } else {
2429                        lappend clist [list $p \
2430                                [string trim [string range $seg 1 3]] \
2431                                [string trim [string range $seg 4 7]] \
2432                                [string trim [string range $seg 8 end]]]
2433                    }
[129]2434                    incr j1 16
2435                    incr j2 16
2436                    set seg [string range $line $j1 $j2]
2437                }
2438            }
2439            return $clist
2440        }
2441        atom-set {
2442            # delete records for current constraint
2443            for {set i 1} {$i < 999} {incr i} {
2444                set key [format "LNCN%4d%4d" $number $i]
2445                if {![existsexp $key]} break
2446                delexp $key
2447            }
2448            set line {}
2449            set i 1
2450            foreach tuple $value {
[544]2451                set p [lindex $tuple 0]
2452                if {$p == 1 && $mm && \
2453                        [string toupper [lindex $tuple 1]] == "ALL"} {
2454                    set seg [format %1dALL UIS%8.4f \
2455                            [lindex $tuple 0] \
2456                            [lindex $tuple 3]]
2457                } elseif {$p == 1 && $mm} {
2458                    set seg [eval format %1d%.4X%-3s%8.4f $tuple]
2459                } elseif {[string toupper [lindex $tuple 1]] == "ALL"} {
[129]2460                    set seg [format %1dALL%-4s%8.4f \
2461                            [lindex $tuple 0] \
2462                            [lindex $tuple 2] \
2463                            [lindex $tuple 3]]
2464                } else {
2465                    set seg [eval format %1d%3d%-4s%8.4f $tuple]
2466                }
2467                append line $seg
2468                if {[string length $line] > 50} {
2469                    set key  [format "LNCN%4d%4d" $number $i]
2470                    makeexprec $key
2471                    setexp $key $line 3 68
2472                    set line {}
2473                    incr i
2474                }
2475            }
2476            if {$line != ""} {
2477                set key  [format "LNCN%4d%4d" $number $i]
2478                makeexprec $key
2479                setexp $key $line 3 68
2480            }
2481            return
2482        }
2483        atom-add {
2484            # loop over defined constraints
2485            for {set j 1} {$j < 9999} {incr j} {
2486                set key [format "LNCN%4d%4d" $j 1]
2487                if {![existsexp $key]} break
2488            }
2489            set number $j
2490            # save the constraint
2491            set line {}
2492            set i 1
2493            foreach tuple $value {
[544]2494                set p [lindex $tuple 0]
2495                if {$p == 1 && $mm && \
2496                        [string toupper [lindex $tuple 1]] == "ALL"} {
2497                    set seg [format %1dALL UIS%8.4f \
2498                            [lindex $tuple 0] \
2499                            [lindex $tuple 3]]
2500                } elseif {$p == 1 && $mm} {
2501                    set seg [eval format %1d%.4X%-3s%8.4f $tuple]
2502                } elseif {[string toupper [lindex $tuple 1]] == "ALL"} {
[129]2503                    set seg [format %1dALL%-4s%8.4f \
2504                            [lindex $tuple 0] \
2505                            [lindex $tuple 2] \
2506                            [lindex $tuple 3]]
2507                } else {
2508                    set seg [eval format %1d%3d%-4s%8.4f $tuple]
2509                }
2510                append line $seg
2511                if {[string length $line] > 50} {
2512                    set key  [format "LNCN%4d%4d" $number $i]
2513                    makeexprec $key
2514                    setexp $key $line 3 68
2515                    set line {}
2516                    incr i
2517                }
2518            }
2519            if {$line != ""} {
2520                set key  [format "LNCN%4d%4d" $number $i]
2521                makeexprec $key
2522                setexp $key $line 3 68
2523            }
2524            return
2525        }
2526        atom-delete {
2527            for {set j $number} {$j < 9999} {incr j} {
2528                # delete records for current constraint
2529                for {set i 1} {$i < 999} {incr i} {
2530                    set key [format "LNCN%4d%4d" $j $i]
2531                    if {![existsexp $key]} break
2532                    delexp $key
2533                }
2534                # now copy records, from the next entry, if any
2535                set j1 $j
2536                incr j1
2537                set key1 [format "LNCN%4d%4d" $j1 1]
2538                # if there is no record, there is nothing to copy -- done
2539                if {![existsexp $key1]} return
2540                for {set i 1} {$i < 999} {incr i} {
2541                    set key1 [format "LNCN%4d%4d" $j1 $i]
2542                    if {![existsexp $key1]} break
2543                    set key  [format "LNCN%4d%4d" $j  $i]
2544                    makeexprec $key
2545                    setexp $key [readexp $key1] 1 68
2546                }
2547            }
2548        }
[229]2549        profile*-delete {
2550            regsub profile $type {} term
2551            if {$term < 10} {
2552                set term " $term"
2553            }
2554            set key "LEQV PF$term   "
2555            # return nothing if no term exists
2556            if {![existsexp $key]} {return 0}
2557
2558            # number of constraint terms
2559            set nterms [string trim [string range [readexp ${key}] 0 4] ]
2560            # don't delete a non-existing entry
2561            if {$number > $nterms} {return 0}
[396]2562            set val [expr {$nterms - 1}]
[229]2563            validint val 5
2564            setexp $key $val 1 5
2565            for {set i1 $number} {$i1 < $nterms} {incr i1} {
[396]2566                set i2 [expr {1 + $i1}]
[229]2567                # move the contents of constraint #i2 -> i1
2568                if {$i1 > 9} {
[396]2569                    set k1 [expr {($i1+1)/10}]
[229]2570                    set l1 $i1
2571                } else {
2572                    set k1 " "
2573                    set l1 " $i1"
2574                }
2575                set key1 "LEQV PF$term  $k1"
2576                # number of constraint lines for #i1
2577                set n1 [string trim [string range [readexp ${key1}] \
[396]2578                        [expr {($i1%10)*5}] [expr {4+(($i1%10)*5)}]] ]
[229]2579                if {$i2 > 9} {
[396]2580                    set k2 [expr {($i2+1)/10}]
[229]2581                    set l2 $i2
2582                } else {
2583                    set k2 " "
2584                    set l2 " $i2"
2585                }
2586                set key2 "LEQV PF$term  $k2"
2587                # number of constraint lines for #i2
2588                set n2 [string trim [string range [readexp ${key2}] \
[396]2589                        [expr {($i2%10)*5}] [expr {4+(($i2%10)*5)}]] ]
[229]2590                set val $n2
2591                validint val 5
2592                # move the # of terms
[396]2593                setexp $key1 $val [expr {1+(($i1%10)*5)}] 5
[229]2594                # move the terms
2595                for {set j 1} {$j <= $n2} {incr j 1} {
2596                    set key "LEQV PF${term}${l1}$j"
2597                    makeexprec $key
2598                    setexp $key [readexp "LEQV PF${term}${l2}$j"] 1 68
2599                }
2600                # delete any remaining lines
[396]2601                for {set j [expr {$n2+1}]} {$j <= $n1} {incr j 1} {
[229]2602                    delexp "LEQV PF${term}${l1}$j"
2603                }
2604            }
2605
2606            # clear the last term
2607            if {$nterms > 9} {
[396]2608                set i [expr {($nterms+1)/10}]
[229]2609            } else {
2610                set i " "
2611            }
2612            set key "LEQV PF$term  $i"
[396]2613            set cb [expr {($nterms%10)*5}]
2614            set ce [expr {4+(($nterms%10)*5)}]
[229]2615            set n2 [string trim [string range [readexp ${key}] $cb $ce] ]
2616            incr cb
2617            setexp $key "     " $cb 5
2618            # delete any remaining lines
2619            for {set j 1} {$j <= $n2} {incr j 1} {
2620                delexp "LEQV PF${term}${nterms}$j"
2621            }
2622        }
2623        profile*-set {
2624            regsub profile $type {} term
2625            if {$term < 10} {
2626                set term " $term"
2627            }
2628            set key "LEQV PF$term   "
2629            # get number of constraint terms
2630            set nterms [string trim [string range [readexp ${key}] 0 4] ]
2631            # don't change a non-existing entry
2632            if {$number > $nterms} {return 0}
2633            if {$number > 9} {
[396]2634                set k1 [expr {($number+1)/10}]
[229]2635                set l1 $number
2636            } else {
2637                set k1 " "
2638                set l1 " $number"
2639            }
2640            set key1 "LEQV PF$term  $k1"
2641            # old number of constraint lines
2642            set n1 [string trim [string range [readexp ${key1}] \
[396]2643                    [expr {($number%10)*5}] [expr {4+(($number%10)*5)}]] ]
[229]2644            # number of new constraints
2645            set j2 [llength $value]
2646            # number of new constraint lines
[396]2647            set val [set n2 [expr {($j2 + 2)/3}]]
[229]2648            # store the new # of lines
2649            validint val 5
[396]2650            setexp $key1 $val [expr {1+(($number%10)*5)}] 5
[229]2651
2652            # loop over the # of lines in the old or new, whichever is greater
2653            set v0 0
[396]2654            for {set j 1} {$j <= [expr {($n1 > $n2) ? $n1 : $n2}]} {incr j 1} {
[229]2655                set key "LEQV PF${term}${l1}$j"
2656                # were there more lines in the old?
2657                if {$j > $n2} {
2658                    # this line is not needed
2659                    if {$j % 3 == 1} {
[1219]2660                        delexp $key
[229]2661                    }
2662                    continue
2663                }
2664                # are we adding new lines?
2665                if {$j > $n1} {
2666                    makeexprec $key
2667                }
2668                # add the three constraints to the line
2669                foreach s {3 23 43} \
[396]2670                        item [lrange $value $v0 [expr {2+$v0}]] {
[229]2671                    if {$item != ""} {
2672                        set val [format %-10s%9.3f \
2673                                [lindex $item 0],[lindex $item 1] \
2674                                [lindex $item 2]]
2675                        setexp $key $val $s 19
2676                    } else {
2677                        setexp $key " " $s 19
2678                    }
2679                }
2680                incr v0 3
2681            }
2682        }
2683        profile*-add {
2684            regsub profile $type {} term
2685            if {$term < 10} {
2686                set term " $term"
2687            }
2688            set key "LEQV PF$term   "
2689            if {![existsexp $key]} {makeexprec $key}
2690            set nterms [string trim [string range [readexp ${key}] 0 4] ]
2691            if {$nterms == ""} {
2692                set nterms 1
2693            } elseif {$nterms >= 99} {
2694                return 0
2695            } else {
2696                incr nterms
2697            }
2698            # store the new # of constraints
2699            set val $nterms
2700            validint val 5
2701            setexp $key $val 1 5
2702
2703            if {$nterms > 9} {
[396]2704                set k1 [expr {($nterms+1)/10}]
[229]2705                set l1 $nterms
2706            } else {
2707                set k1 " "
2708                set l1 " $nterms"
2709            }
2710            set key1 "LEQV PF$term  $k1"
2711
2712            # number of new constraints
2713            set j2 [llength $value]
2714            # number of new constraint lines
[396]2715            set val [set n2 [expr {($j2 + 2)/3}]]
[229]2716            # store the new # of lines
2717            validint val 5
[396]2718            setexp $key1 $val [expr {1+(($nterms%10)*5)}] 5
[229]2719
2720            # loop over the # of lines to be added
2721            set v0 0
2722            for {set j 1} {$j <= $n2} {incr j 1} {
2723                set key "LEQV PF${term}${l1}$j"
2724                makeexprec $key
2725                # add the three constraints to the line
2726                foreach s {3 23 43} \
[396]2727                        item [lrange $value $v0 [expr {2+$v0}]] {
[229]2728                    if {$item != ""} {
2729                        set val [format %-10s%9.3f \
2730                                [lindex $item 0],[lindex $item 1] \
2731                                [lindex $item 2]]
2732                        setexp $key $val $s 19
2733                    } else {
2734                        setexp $key " " $s 19
2735                    }
2736                }
2737                incr v0 3
2738            }
2739        }
2740        profile*-get {
2741            regsub profile $type {} term
2742            if {$term < 10} {
2743                set term " $term"
2744            }
2745            if {$number > 9} {
[396]2746                set i [expr {($number+1)/10}]
[229]2747            } else {
2748                set i " "
2749            }
2750            set key "LEQV PF$term  $i"
2751            # return nothing if no term exists
2752            if {![existsexp $key]} {return 0}
2753            # number of constraint lines
2754           
2755            set numline [string trim [string range [readexp ${key}] \
[396]2756                    [expr {($number%10)*5}] [expr {4+(($number%10)*5)}]] ]
[229]2757            if {$number == 0} {return $numline}
2758            set clist {}
2759            if {$number < 10} {
2760                set number " $number"
2761            }
2762            for {set i 1} {$i <= $numline} {incr i} {
2763                set key "LEQV PF${term}${number}$i"
2764                set line [readexp ${key}]
2765                foreach s {1 21 41} e {20 40 60} {
2766                    set seg [string range $line $s $e]
2767                    if {[string trim $seg] == ""} continue
2768                    # parse the string segment
2769                    set parse [regexp { *([0-9AL]+),([0-9AL]+) +([0-9.]+)} \
2770                            $seg junk phase hist mult]
2771                    # was parse successful
2772                    if {!$parse} {continue}
2773                    lappend clist [list $phase $hist $mult]
2774                }
2775            }
2776            return $clist
2777        }
[1219]2778        absorb*-delete {
2779            regsub absorb $type {} term
2780            set key "LEQV ABS$term   "
2781            if {! [existsexp $key]} {return 0}
2782            # current number of constraints
2783            set nterm [string trim [string range [readexp $key] 0 5]]
2784            if {$nterm == ""} {return 0}
2785            # does the entry exist?
2786            if {$nterm < $number} {
2787                puts "deleted!"
2788                return $nterm
2789            }
2790            for {set target $number} {$target < $nterm} {incr target} {
2791                set source [expr {$target + 1}]
2792                set recs [GetAbsCount $term $source]
2793                SetAbsCount $term $target [expr {3*$recs}]
2794                validint source 2
2795                validint target 2
2796                for {set i 1} {$i <= $recs} {incr i} {
2797                    set keyin "LEQV ABS${term}${source}$i"
2798                    set keyout "LEQV ABS${term}${target}$i"
2799                    set ::exparray($keyout) $::exparray($keyin)
2800                }
2801            }
2802            SetAbsCount $term $nterm 0
2803            # delete the last entry
2804            validint nterm 2
2805            foreach i {1 2 3 4 5 6 7 8 9} {
2806                set key "LEQV ABS${term}${nterm}$i"
2807                delexp $key
2808            }
2809            # decrease the count by one
2810            set nterm [expr {[string trim $nterm] - 1}]
2811            if {$nterm == 0} {
2812                delexp "LEQV ABS$term   "
2813            } else {
2814                validint nterm 5
2815                setexp "LEQV ABS$term   " $nterm 1 5                   
2816            }
2817            return [string trim $nterm]
2818
2819            if {$term < 10} {
2820                set term " $term"
2821            }
2822            set key "LEQV PF$term   "
2823            # return nothing if no term exists
2824            if {![existsexp $key]} {return 0}
2825
2826            # number of constraint terms
2827            set nterms [string trim [string range [readexp ${key}] 0 4] ]
2828            # don't delete a non-existing entry
2829            if {$number > $nterms} {return 0}
2830            set val [expr {$nterms - 1}]
2831            validint val 5
2832            setexp $key $val 1 5
2833            for {set i1 $number} {$i1 < $nterms} {incr i1} {
2834                set i2 [expr {1 + $i1}]
2835                # move the contents of constraint #i2 -> i1
2836                if {$i1 > 9} {
2837                    set k1 [expr {($i1+1)/10}]
2838                    set l1 $i1
2839                } else {
2840                    set k1 " "
2841                    set l1 " $i1"
2842                }
2843                set key1 "LEQV PF$term  $k1"
2844                # number of constraint lines for #i1
2845                set n1 [string trim [string range [readexp ${key1}] \
2846                        [expr {($i1%10)*5}] [expr {4+(($i1%10)*5)}]] ]
2847                if {$i2 > 9} {
2848                    set k2 [expr {($i2+1)/10}]
2849                    set l2 $i2
2850                } else {
2851                    set k2 " "
2852                    set l2 " $i2"
2853                }
2854                set key2 "LEQV PF$term  $k2"
2855                # number of constraint lines for #i2
2856                set n2 [string trim [string range [readexp ${key2}] \
2857                        [expr {($i2%10)*5}] [expr {4+(($i2%10)*5)}]] ]
2858                set val $n2
2859                validint val 5
2860                # move the # of terms
2861                setexp $key1 $val [expr {1+(($i1%10)*5)}] 5
2862                # move the terms
2863                for {set j 1} {$j <= $n2} {incr j 1} {
2864                    set key "LEQV PF${term}${l1}$j"
2865                    makeexprec $key
2866                    setexp $key [readexp "LEQV PF${term}${l2}$j"] 1 68
2867                }
2868                # delete any remaining lines
2869                for {set j [expr {$n2+1}]} {$j <= $n1} {incr j 1} {
2870                    delexp "LEQV PF${term}${l1}$j"
2871                }
2872            }
2873
2874            # clear the last term
2875            if {$nterms > 9} {
2876                set i [expr {($nterms+1)/10}]
2877            } else {
2878                set i " "
2879            }
2880            set key "LEQV PF$term  $i"
2881            set cb [expr {($nterms%10)*5}]
2882            set ce [expr {4+(($nterms%10)*5)}]
2883            set n2 [string trim [string range [readexp ${key}] $cb $ce] ]
2884            incr cb
2885            setexp $key "     " $cb 5
2886            # delete any remaining lines
2887            for {set j 1} {$j <= $n2} {incr j 1} {
2888                delexp "LEQV PF${term}${nterms}$j"
2889            }
2890        }
2891        absorb*-set {
2892            regsub absorb $type {} term
2893            if {$number < 1} return   
2894            # delete old records
2895            set l [GetAbsCount $term $number]
2896            set num $number
2897            validint num 2
2898            for {set i 1} {$i <= $l} {incr i} {
2899                delexp "LEQV ABS${term}${num}$i"
2900            }
2901            # record the new number of records
2902            SetAbsCount $term $number [llength $value]
2903            # save the new records
2904            set i 1
2905            set offh 2
2906            set offm 14
2907            foreach set $value {
2908                set hist [string trim [lindex $set 0]]
2909                set mult [string trim [lindex $set 1]]
2910                validreal mult 8 4
2911                set key "LEQV ABS${term}${num}$i"
2912                if {$offh == 2} {
2913                    makeexprec $key
2914                }
2915                setexp $key $hist [expr {$offh+1}] 11
2916                setexp $key $mult [expr {$offm+1}] 8
2917                incr offh 21
2918                incr offm 21
2919                if {$offm > 67} {
2920                    incr i
2921                    set offh 2
2922                    set offm 14
2923                }
2924            }
2925            return
2926        }
2927        absorb*-add {
2928            regsub absorb $type {} term
2929            set key "LEQV ABS$term   "
2930            if {! [existsexp $key]} {makeexprec $key}
2931            # current number of constraints
2932            set nterm [string trim [string range [readexp $key] 0 5]]
2933            if {$nterm == ""} {set nterm 0}
2934            if {$nterm >= 99} {
2935                return $nterm
2936            }
2937            incr nterm
2938            validint nterm 5
2939            setexp $key $nterm 1 5
2940            constrinfo $type set [string trim $nterm] $value
2941            return [string trim $nterm]
2942        }
2943        absorb*-get {
2944            regsub absorb $type {} term
2945            # no constraints, return blank
2946            set key "LEQV ABS$term   "
2947            if {! [existsexp $key]} {return ""}
2948            # requesting number of constraints
2949            if {$number == 0} {
2950                set l [string trim [string range [readexp ${key}] 0 5]]
2951                if {$l == ""} {return 0}
2952                return $l
2953            }
2954            #
2955            if {$number > 9} {
2956                set num $number
2957                set i [expr {($number+1)/10}]
2958                set off [expr {5*($number % 10)}]
2959                set key "LEQV ABS$term  $i"
2960            } else {
2961                set num " $number"
2962                set i " "
2963                set off [expr {5*($number % 10)}]
2964            }
2965            set off1 [expr {$off + 5}]
2966            set l [string trim [string range [readexp ${key}] $off $off1]]
2967            if {$l == ""} {return {}}
2968            # now look up those records
2969            set res {}
2970            for {set i 1} {$i <= $l} {incr i} {
2971                set key "LEQV ABS${term}${num}$i"
2972                for {set j 0} {$j < 3} {incr j} {
2973                    set off [expr {2 + 21*$j}]
2974                    set off1 [expr {$off + 11}]
2975                    set hist [string trim [string range [readexp ${key}] $off $off1]]
2976                    set off [expr {14 + 21*$j}]
2977                    set off1 [expr {$off + 7}]
2978                    set mult [string trim [string range [readexp ${key}] $off $off1]]
2979                    if {$mult == ""} break
2980                    lappend res [list $hist $mult]
2981                }
2982            }
2983            return $res
2984        }
[129]2985        default {
2986            set msg "Unsupported constrinfo access: type=$type action=$action"
[252]2987            tk_dialog .badexp "Error in readexp access" $msg error 0 OK
[129]2988        }
2989
2990    }
2991}
[1219]2992proc GetAbsCount {term number} {
2993    if {$number > 9} {
2994        set num $number
2995        set off [expr {5*($number % 10)}]
2996        set i [expr {($number+1)/10}]
2997        set key "LEQV ABS$term  $i"
2998    } else {
2999        set num " $number"
3000        set off [expr {5*($number % 10)}]
3001        set key "LEQV ABS$term   "
3002    }
3003    set off1 [expr {$off + 5}]
3004    set l [string trim [string range [readexp ${key}] $off $off1]]
3005    if {$l == ""} {set l 0}
3006    return $l
3007}
3008proc SetAbsCount {term number len} {
3009    if {$number > 9} {
3010        set num $number
3011        set off [expr {1 + 5*($number % 10)}]
3012        set i [expr {($number+1)/10}]
3013        set key "LEQV ABS$term  $i"
3014    } else {
3015        set num " $number"
3016        set off [expr {1 + 5*($number % 10)}]
3017        set key "LEQV ABS$term   "
3018    }
3019    set l [expr {($len + 2)/3}]
3020    set val $l
3021    validint val 5
3022    setexp $key $val $off 5
3023}
[129]3024
[229]3025# read the default profile information for a histogram
3026# use: profdefinfo hist set# parm action
3027
3028#     proftype -- profile function number
3029#     profterms -- number of profile terms
3030#     pdamp -- damping value for the profile (*)
3031#     pcut -- cutoff value for the profile (*)
3032#     pterm$n -- profile term #n
3033#     pref$n -- refinement flag value for profile term #n (*)
3034
3035proc profdefinfo {hist set parm "action get"} {
3036    global expgui
3037    if {$hist < 10} {
3038        set key "HST  $hist"
3039    } else {
3040        set key "HST $hist"
3041    }
3042    switch -glob ${parm}-$action {
3043        proftype-get {
3044            set val [string range [readexp "${key}PRCF$set"] 0 4]
3045            if {$val == " "} {return 0}
3046            return $val
3047        }
3048        profterms-get {
3049            set val [string range [readexp "${key}PRCF$set"] 5 9]
3050            if {$val == " "} {return 0}
3051            return $val
3052        }
3053        pcut-get {
3054            return [string trim [string range [readexp "${key}PRCF$set"] 10 19]]
3055        }
3056        pdamp-get {
3057                set val [string range [readexp "${key}PRCF$set"] 24 24]
3058            if {$val == " "} {return 0}
3059            return $val
3060        }
3061        pterm*-get {
3062            regsub pterm $parm {} num
[396]3063            set f1 [expr {15*(($num - 1) % 4)}]
3064            set f2 [expr {15*(1 + ($num - 1) % 4)-1}]
3065            set line  [expr {1 + ($num - 1) / 4}]
[229]3066            return [string trim [string range [\
3067                        readexp "${key}PRCF${set}$line"] $f1 $f2] ]
3068        }
3069        pref*-get {
3070            regsub pref $parm {} num
[396]3071            set f [expr {24+$num}]
[229]3072            if {[string toupper [string range [readexp "${key}PRCF$set"] $f $f]] == "Y"} {
3073                return 1
3074            }
3075            return 0
3076        }
3077        default {
3078            set msg "Unsupported profdefinfo access: parm=$parm action=$action"
3079            tk_dialog .badexp "Code Error" $msg error 0 Exit
3080        }
3081    }
3082}
3083
[236]3084# get March-Dollase preferred orientation information
3085# use MDprefinfo hist phase axis-number parm action value
3086#    ratio    -- ratio of xtallites in PO direction vs random (>1 for more)
3087#    fraction -- fraction in this direction, when more than one axis is used
3088#    h k & l  -- indices of P.O. axis
3089#    ratioref -- flag to vary ratio
3090#    fracref  -- flag to vary fraction
3091#    damp     -- damping value
3092#    type     -- model type (0 = P.O. _|_ to beam, 1 = || to beam)
3093#    new      -- creates a new record with default values (set only)
3094proc MDprefinfo {histlist phaselist axislist parm "action get" "value {}"} {
3095    foreach phase $phaselist hist $histlist axis $axislist {
3096        if {$phase == ""} {set phase [lindex $phaselist end]}
3097        if {$hist == ""} {set hist [lindex $histlist end]}
3098        if {$axis == ""} {set axis [lindex $axislist end]}
3099        if {$hist < 10} {
3100            set hist " $hist"
3101        }
3102        if {$axis > 9} {
3103            set axis "0"
3104        }
3105        set key "HAP${phase}${hist}PREFO${axis}"
3106        switch -glob ${parm}-$action {
3107            ratio-get {
3108                return [string trim [string range [readexp $key] 0 9]]
3109            }
3110            ratio-set {
3111                if ![validreal value 10 6] {return 0}
3112                setexp $key $value 1 10
3113            }
3114            fraction-get {
3115                return [string trim [string range [readexp $key] 10 19]]
3116            }
3117            fraction-set {
3118                if ![validreal value 10 6] {return 0}
3119                setexp $key $value 11 10
3120            }
3121            h-get {
3122                set h [string trim [string range [readexp $key] 20 29]]
3123                # why not allow negative h values?
3124                #               if {$h < 1} {return 0}
3125                return $h
3126            }
3127            h-set {
3128                if ![validreal value 10 2] {return 0}
3129                setexp $key $value 21 10
3130            }
3131            k-get {
3132                set k [string trim [string range [readexp $key] 30 39]]
3133                #               if {$k < 1} {return 0}
3134                return $k
3135            }
3136            k-set {
3137                if ![validreal value 10 2] {return 0}
3138                setexp $key $value 31 10
3139            }
3140            l-get {
3141                set l [string trim [string range [readexp $key] 40 49]]
3142                #if {$l < 1} {return 0}
3143                return $l
3144            }
3145            l-set {
3146                if ![validreal value 10 2] {return 0}
3147                setexp $key $value 41 10
3148            }
3149            ratioref-get {
3150                if {[string toupper \
3151                        [string range [readexp $key] 53 53]] == "Y"} {
3152                    return 1
3153                }
3154                return 0
3155            }
3156            ratioref-set {
3157                if $value {
3158                    setexp $key "Y" 54 1
3159                } else {
3160                    setexp $key "N" 54 1
3161                }
3162            }
3163            fracref-get {
3164                if {[string toupper \
3165                        [string range [readexp $key] 54 54]] == "Y"} {
3166                    return 1
3167                }
3168                return 0
3169            }
3170            fracref-set {
3171                if $value {
3172                    setexp $key "Y" 55 1
3173                } else {
3174                    setexp $key "N" 55 1
3175              }
3176            }
3177            damp-get {
3178                set val [string trim [string range [readexp $key] 59 59]]
3179                if {$val == " "} {return 0}
3180                return $val
3181            }
3182            damp-set {
3183                setexp $key $value 60 1
3184            }
3185            type-get {
3186                set val [string trim [string range [readexp $key] 64 64]]
3187                if {$val == " "} {return 0}
3188                return $val
3189            }
3190            type-set {
3191                # only valid settings are 0 & 1
3192                if {$value != "0" && $value != "1"} {set value "0"}
3193                setexp $key $value 65 1
3194            }
3195            new-set {
3196                makeexprec $key
3197                setexp $key \
3198                        {  1.000000  1.000000  0.000000  0.000000  1.000000   NN    0    0} \
3199                        1 68
3200            }
3201            default {
3202                set msg "Unsupported MDprefinfo access: parm=$parm action=$action"
[252]3203                tk_dialog .badexp "Error in readexp" $msg error 0 Exit
[236]3204            }
3205
3206        }
3207
3208    }
3209}
3210
[1025]3211# get list of defined atom types
3212proc AtmTypList {} {
3213    set natypes [readexp " EXPR  NATYP"]
3214    if {$natypes == ""} return
3215    set j 0
3216    set typelist {}
3217    for {set i 1} {$i <= $natypes} {incr i} {
3218        set key {this should never be matched}
3219        while {![existsexp $key]} {
3220            incr j
3221            if {$j > 99} {
3222                return $typelist
3223            } elseif {$j <10} {
3224                set key " EXPR ATYP $j"
3225            } else {
3226                set key " EXPR ATYP$j"
3227            }
3228        }
3229        lappend typelist [string trim [string range $::exparray($key) 2 9]]
3230    }
3231    return $typelist
3232}
3233
3234# read information about atom types
3235#     distrad    atomic distance search radius (get/set)
3236#     angrad     atomic angle search radius (get/set)
3237proc AtmTypInfo {parm atmtype "action get" "value {}"} {
3238    # first, search through the records to find the record matching the type
3239    set natypes [readexp " EXPR  NATYP"]
3240    if {$natypes == ""} return
3241    set j 0
3242    set typelist {}
3243    for {set i 1} {$i <= $natypes} {incr i} {
3244        set key {this should never be matched}
3245        while {![existsexp $key]} {
3246            incr j
3247            if {$j