Context Navigation

source: trunk/readexp.tcl @ 931

Last change on this file since 931 was 930, checked in by toby, 11 years ago
rcs:* properties removed
Property svn:keywords set to `Author Date Revision Id`
File size: 82.5 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: