Context Navigation

source: branches/sandbox/readexp.tcl @ 1020

Last change on this file since 1020 was 1020, checked in by toby, 12 years ago
fix string to work with older Tcl/Tk?
Property svn:keywords set to `Author Date Revision Id`
File size: 92.5 KB

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

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

Download in other formats: