Context Navigation

← Previous Revision
Next Revision →
Normal
Revision Log

source: trunk/export_drawxtl.tcl

Last change on this file was 1251, checked in by toby, 7 years ago
use svn ps svn:eol-style "native" * to change line ends
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Revision Id`
File size: 26.4 KB

Rev	Line
[807]	1	# export a phase to DRAWXTL
	2	#
	3	# $Id: export_drawxtl.tcl 1251 2014-03-10 22:17:29Z toby $
	4	# set local variables that define the proc to execute and the menu label
	5	set label "export to DRAWXTL (.str) file"
	6	set action export_drawxtl
[1225]	7	set ::DXTLcolorlist "White Red Green Blue Yellow Cyan Magenta Black Orange Brown Grey Silver White"
	8	set ::DXTL(bonds) 0
	9	set ::DXTL(coords) 1
	10	set ::DXTL(blackarrow) Green
	11	set ::DXTL(redarrow) Red
	12	foreach a {X Y Z} {
	13	set ::DXTL(${a}dispMin) 0.0
	14	set ::DXTL(${a}dispMax) 1.0
	15	}
	16	set ::DXTL(mtype) ""
	17	set ::DXTL(mfil) ""
	18	set ::DXTL(FourierRange) ""
	19
[807]	20	proc export_drawxtl {} {
	21	global expmap expgui
	22	# don't bother if there are no phases to write
	23	if {[llength $expmap(phaselist)] == 0} {
	24	MyMessageBox -parent . -title "No phases" \
	25	-message "Sorry, no phases are present to write" \
	26	-icon warning
	27	return
	28	}
[1225]	29	foreach t [trace vinfo ::expgui(export_phase)] {
	30	eval trace vdelete ::expgui(export_phase) $t
[807]	31	}
[1225]	32	MakeExportBox .export "Export coordinates to program DRAWXTL" ""
[807]	33	# "MakeWWWHelp expgui.html export"
	34
[846]	35	# trigger a quit on window delete
	36	wm protocol .export WM_DELETE_WINDOW {set expgui(export_phase) 0; destroy .export }
[807]	37	set bx .export.special
	38	set row 1
	39	grid [label $bx.1 -text "Title:"] -column 1 -row $row -sticky e
[1225]	40	grid [entry $bx.2 -textvariable ::DXTL(title) -width 40] \
[807]	41	-row $row -column 2 -columnspan 5 -sticky w
[1225]	42	set ::DXTL(title) [expinfo title]
[807]	43	incr row
	44	grid [checkbutton $bx.3 -text "Include coordinates in .str file" \
[1225]	45	-variable ::DXTL(coords)] \
[807]	46	-row $row -column 1 -columnspan 5 -sticky w
	47	incr row
[1225]	48	set ::DXTL(arrowbox) $bx.4
[846]	49	grid [checkbutton $bx.4 -text "Display arrows for magnetic atoms" \
[1225]	50	-variable ::DXTL(genarrows) -state disabled] \
[836]	51	-row $row -column 1 -columnspan 5 -sticky w
	52	incr row
[1225]	53	set ::DXTL(arrowcolorbox) $bx.4a
	54	set ::DXTL(arrowcolorbox_row) $row
	55	grid [frame $bx.4a] -sticky ew -row $::DXTL(arrowcolorbox_row) \
[846]	56	-column 1 -columnspan 5
	57	grid [label $bx.4a.h -text "Arrow colors: "] -column 0 -row 1 -sticky w
	58	grid [label $bx.4a.bll -text " generated by Black operator "] -column 0 -row 2
[1225]	59	eval tk_optionMenu $bx.4a.bl ::DXTL(blackarrow) $::DXTLcolorlist
[846]	60	grid $bx.4a.bl -column 2 -row 2
	61	grid [label $bx.4a.redl -text " generated by Red operator "] -column 0 -row 3
[1225]	62	eval tk_optionMenu $bx.4a.red ::DXTL(redarrow) $::DXTLcolorlist
[846]	63	grid $bx.4a.red -column 2 -row 3
[836]	64	incr row
[846]	65	# is DRAWxtl installed?
	66	set app {}
	67	if {![catch {set fp [open [file join $::env(HOME) .drawxtlrc] r]}]} {
	68	# line 12 is name of executable
	69	set i 0
	70	while {$i < 12} {
	71	incr i
	72	gets $fp appname
	73	}
	74	close $fp
[836]	75	set app [auto_execok $appname]
	76	}
	77	if {$app != ""} {
	78	set show normal
[1225]	79	set ::DXTL(app) $appname
	80	set ::DXTL(launch) 1
[836]	81	} else {
	82	set show disabled
[1225]	83	set ::DXTL(launch) 0
[836]	84	}
	85	grid [checkbutton $bx.l -text "Launch DRAWxtl" \
[1225]	86	-variable ::DXTL(launch) -state $show] \
[836]	87	-row $row -column 1 -columnspan 5 -sticky w
	88	incr row
[807]	89	grid [frame $bx.c -relief groove -bd 4] -row $row -column 0 -columnspan 5
	90	grid [label $bx.c.0 -text "Range of fractional coordinates to include" \
	91	-anchor center] -row 0 -column 0 -columnspan 8
	92	foreach v {x y z} V {X Y Z} {
	93	incr row
	94	grid [label $bx.c.${v}1 -text "${V} min:"] -column 1 -row $row
[1225]	95	grid [entry $bx.c.${v}2 -textvariable ::DXTL(${v}min) -width 4] -column 2 -row $row
	96	grid [scale $bx.c.${v}3 -resolution 0.1 -variable ::DXTL(${v}min) \
[807]	97	-showvalue 0 -orient h -from -2 -to 1] -column 3 -row $row
[1225]	98	set ::DXTL(${v}min) -0.1
[807]	99	grid [label $bx.c.${v}4 -text " max:"] -column 4 -row $row
[1225]	100	grid [entry $bx.c.${v}5 -textvariable ::DXTL(${v}max) -width 4] -column 5 -row $row
	101	grid [scale $bx.c.${v}6 -resolution 0.1 -variable ::DXTL(${v}max) \
[807]	102	-showvalue 0 -orient h -from 0 -to 3] -column 6 -row $row
[1225]	103	set ::DXTL(${v}max) 1.1
[807]	104	}
	105	# atom type box
[846]	106	grid [frame $bx.s -relief groove -bd 4] -row $row -column 0 -columnspan 5 -sticky nsew
[1225]	107	grid rowconfigure $bx $row -weight 1
[807]	108	grid [label $bx.s.0 -text "Atom representation" \
	109	-anchor w] -row 0 -column 0 -sticky w
	110	grid [canvas $bx.s.canvas -relief sunk -bd 2 \
	111	-scrollregion {0 0 5000 500} -width 250 -height 70 \
	112	-yscrollcommand "$bx.s.scroll set" ] \
	113	-column 0 -row [incr row] -sticky nsew
[1225]	114	grid rowconfigure $bx.s $row -weight 1
[807]	115	grid columnconfig $bx.s 0 -weight 1
[1225]	116	frame [set ::DXTL(lb) $bx.s.canvas.fr]
	117	$bx.s.canvas create window 0 0 -anchor nw -window $::DXTL(lb)
[807]	118	grid [scrollbar $bx.s.scroll \
	119	-command "$bx.s.canvas yview"] -sticky ns -row $row -column 1
	120	# bond box
	121	incr row
	122	grid [frame $bx.b -relief groove -bd 4] -row $row -column 0 -columnspan 5 -sticky ew
[1225]	123	grid rowconfigure $bx $row -weight 1
[807]	124	grid [frame $bx.b.0] -row 0 -column 0 -columnspan 7 -sticky ew
	125	grid [label $bx.b.0.1 -text "Bond List" \
	126	-anchor w] -row 0 -column 0 -sticky w
	127	grid columnconfig $bx.b.0 0 -weight 1
	128	grid [button $bx.b.0.b -text "Add Bond" -command DXTLaddBond \
	129	] -row 0 -column 1 -sticky e
	130	grid [canvas $bx.b.canvas -relief sunk -bd 2 \
	131	-scrollregion {0 0 5000 500} -width 250 -height 70 \
	132	-yscrollcommand "$bx.b.scroll set" ] \
	133	-column 0 -row [incr row] -sticky nsew
[1225]	134	grid rowconfigure $bx.b $row -weight 1
[807]	135	grid columnconfig $bx.b 0 -weight 1
[1225]	136	frame [set ::DXTL(Blst) $bx.b.canvas.fr]
	137	$bx.b.canvas create window 0 0 -anchor nw -window $::DXTL(Blst)
[807]	138	grid [scrollbar $bx.b.scroll \
	139	-command "$bx.b.canvas yview"] -sticky ns -row $row -column 1
[1225]	140	# Fourier Box
	141	incr row
	142	grid [frame $bx.f -relief groove -bd 4] -row $row -column 0 -columnspan 5 -sticky nsew
	143	grid [frame $bx.f.0] -column 0 -columnspan 3 -row 0 -sticky news
	144	grid columnconfig $bx.f.0 0 -weight 1
	145	grid [label $bx.f.0.l1 -text "Fourier display" \
	146	-anchor w] -row 0 -column 0 -sticky w
	147	set ::DXTL(FourierRange) "Range: unknown"
	148	grid [label $bx.f.0.l2 -textvariable ::DXTL(FourierRange) \
	149	-anchor w] -row 0 -column 1 -sticky e
	150	grid [frame $bx.f.1] -column 0 -columnspan 3 -row 1 -sticky news
	151	grid [frame $bx.f.2] -column 0 -columnspan 3 -row 2 -sticky news
	152	grid [canvas $bx.f.canvas -relief sunk -bd 2 \
	153	-scrollregion {0 0 5000 500} -width 250 -height 70 \
	154	-yscrollcommand "$bx.f.scroll set" ] \
	155	-column 0 -row 3 -sticky nsew
	156	grid rowconfigure $bx $row -weight 1
	157	grid rowconfigure $bx.f 3 -weight 1
	158	grid columnconfig $bx.f 0 -weight 1
	159	frame [set ::DXTL(fb) $bx.f.canvas.fr]
	160	$bx.f.canvas create window 0 0 -anchor nw -window $::DXTL(fb)
	161	grid [scrollbar $bx.f.scroll \
	162	-command "$bx.f.canvas yview"] -sticky ns -row 3 -column 2
	163	grid [button $bx.f.1.1 -text "Setup\nFourier" \
	164	-command {EditFourier $::expgui(export_phase); SetupFourierButtons} \
	165	] -column 0 -row 0
	166	grid [button [set ::DXTL(FourCompute) $bx.f.1.2] -text "Compute\nFourier" \
	167	-command {DXTLwritegrd $expgui(export_phase)}] -column 1 -row 0
	168	grid [label $bx.f.1.3 -text "Select\nMap"] -column 3 -row 0
	169	set ::DXTL(fmenu) [tk_optionMenu $bx.f.1.4 ::DXTL(mtype) test]
	170	grid $bx.f.1.4 -column 4 -row 0
	171	grid [button [set ::DXTL(AddContour) $bx.f.1.5] -text "Add\nContour" \
	172	-command AddContour] -column 5 -row 0
	173	grid [frame $bx.f.1.f] -column 0 -columnspan 9 -row 1
	174	grid [label $bx.f.1.f.0 -text "display\nlimits"] -column 0 -row 0
	175	set col 0
	176	foreach a {X Y Z} {
	177	incr col
	178	grid [label $bx.f.1.f.$col -text $a] -column $col -row 0
	179	incr col
	180	grid [entry $bx.f.1.f.$col -textvariable ::DXTL(${a}dispMin) \
	181	-width 6] -column $col -row 0
	182	incr col
	183	grid [entry $bx.f.1.f.$col -textvariable ::DXTL(${a}dispMax) \
	184	-width 6] -column $col -row 0
	185	}
	186	set ::DXTL(contours) 0
	187	trace variable ::expgui(export_phase) w OnNewFourierPhase
	188	OnNewFourierPhase
[807]	189	# this appears to be needed by OSX
	190	ResizeWin .export
[1225]	191	# force the window to stay on top
	192	putontop .export
	193	SetDXTLatoms
[807]	194
	195	# Wait for the Write or Quit button to be pressed
	196	tkwait window .export
	197	afterputontop
	198	# test for Quit
	199	if {$expgui(export_phase) == 0} {return}
	200
	201	# now open the file and write it
	202	set phase $expgui(export_phase)
	203	if [catch {
	204	set filnam [file rootname $expgui(expfile)]_${phase}.str
	205	set fp [open $filnam w]
	206	# deal with macromolecular phases
	207	if {[lindex $expmap(phasetype) [expr {$phase - 1}]] == 4} {
	208	MyMessageBox -parent . -title "MM phase" \
	209	-message "Sorry, macromolecular phases cannot be processed" \
	210	-icon warning
	211	return
	212	}
	213	catch {unset typelist}
	214	foreach atom $expmap(atomlist_$phase) {
	215	set typelist([atominfo $phase $atom type]) 1
	216	}
	217	# title info from GSAS title & phase title
	218	puts $fp "REM created by EXPGUI from $expgui(expfile) on [clock format [clock seconds]]"
[1225]	219	puts $fp "title \"$::DXTL(title)\""
	220	puts $fp "pack $::DXTL(xmin) $::DXTL(xmax) $::DXTL(ymin) $::DXTL(ymax) $::DXTL(zmin) $::DXTL(zmax)"
[807]	221	puts $fp "edges 0.02 Black"
	222	puts $fp "phong 1.0 30."
	223	foreach type [array names typelist] {
[1225]	224	if {$::DXTL(display_$type) == "sphere"} {
	225	puts $fp "sphere $type $::DXTL(radius_$type) $::DXTL(color_$type)"
	226	} elseif {$::DXTL(display_$type) == "polyhedron"} {
	227	puts $fp "polysz $type $::DXTL(radius_$type) $::DXTL(color_$type)"
	228	} elseif {$::DXTL(display_$type) == "ellipsoid"} {
	229	puts $fp "ellipcolor $type * $::DXTL(color_$type)"
[807]	230	}
	231	}
[1225]	232	if {$::DXTL(coords)} {
[807]	233	# write out cell parameters
	234	puts -nonewline $fp "cell"
	235	foreach p {a b c alpha beta gamma} {
	236	puts -nonewline $fp " [phaseinfo $phase $p]"
	237	}
	238	puts $fp ""
	239	# write out GSAS spacegroup
	240	puts $fp "spgp [phaseinfo $phase spacegroup]"
	241	# now loop over atoms
	242	foreach atom $expmap(atomlist_$phase) {
	243	puts -nonewline $fp "atom [atominfo $phase $atom type] $atom "
	244	foreach v {x y z} {
	245	puts -nonewline $fp "[atominfo $phase $atom $v] "
	246	}
	247	puts $fp ""
	248
	249	set uiso [atominfo $phase $atom Uiso]
	250	# are there anisotropic atoms? If so convert them to Uequiv
	251	if {[atominfo $phase $atom temptype] == "A"} {
	252	puts -nonewline $fp "Uij [atominfo $phase $atom type] $atom "
	253	foreach v {U11 U22 U33 U12 U13 U23} {
	254	puts -nonewline $fp "[atominfo $phase $atom $v] "
	255	}
	256	puts $fp ""
	257	}
	258	}
	259	} else {
	260	puts $fp "import gsas [file tail $expgui(expfile)] $phase"
	261	}
[1225]	262	for {set i 1} {$i <= $::DXTL(bonds)} {incr i} {
	263	puts $fp "bond $::DXTL(ba_$i) $::DXTL(bb_$i) $::DXTL(bw_$i) $::DXTL(bmin_$i) $::DXTL(bmax_$i) $::DXTL(bc_$i)"
[807]	264	}
[836]	265	# list arrows, when requested
	266	if {[lindex $expmap(phasetype) [expr {$phase - 1}]] != 1 && \
[1225]	267	$::DXTL(genarrows)} {
[836]	268	DXTLwriteArrows $fp $phase
	269	}
[1225]	270	DXTLwriteFourierCommands $fp
[807]	271	puts $fp "END"
	272	close $fp
[1225]	273	if {$::DXTL(launch)} {
	274	exec $::DXTL(app) $filnam &
[836]	275	}
[807]	276	} errmsg] {
	277	MyMessageBox -parent . -title "Export error" \
	278	-message "Export error: $errmsg" -icon warning
	279	} else {
	280	MyMessageBox -parent . -title "Done" \
	281	-message "File [file tail $filnam] was written"
	282	}
[1225]	283	#catch {unset DXTL}
[807]	284	foreach t [trace vinfo expgui(export_phase)] {
	285	eval trace vdelete expgui(export_phase) $t
	286	}
	287	}
	288
	289	# resize windows -- this appears to be needed by OSX 10.2
	290	proc ResizeWin {win} {
	291	update
	292	wm geom $win [winfo reqwidth $win]x[winfo reqheight $win]
	293	# center the EXPGUI window
	294	wm withdraw $win
	295	set x [expr [winfo screenwidth $win]/2 - [winfo reqwidth $win]/2 ]
	296	set y [expr [winfo screenheight $win]/2 - [winfo reqheight $win]/2]
	297	wm geom $win +$x+$y
	298	wm deiconify $win
	299	}
	300
	301
	302	# add atoms to atom representation list
	303	proc SetDXTLatoms {args} {
[1225]	304	global expgui expmap
	305	eval destroy [winfo children $::DXTL(lb)]
	306	eval destroy [winfo children $::DXTL(Blst)]
	307	set ::DXTL(bonds) 0
[807]	308	if {$expgui(export_phase) == 0} {return}
	309	set phase $expgui(export_phase)
	310	if {[lindex $expmap(phasetype) [expr {$phase - 1}]] == 4} {
	311	MyMessageBox -parent . -title "MM phase" \
	312	-message "Sorry, macromolecular phases cannot be processed" \
	313	-icon warning
	314	return
	315	}
[836]	316	if {[lindex $expmap(phasetype) [expr {$phase - 1}]] == 1} {
[1225]	317	set ::DXTL(genarrows) 0
	318	$::DXTL(arrowbox) configure -state disabled
	319	grid forget $::DXTL(arrowcolorbox)
[836]	320	} else {
[1225]	321	set ::DXTL(genarrows) 1
	322	$::DXTL(arrowbox) configure -state normal
	323	grid $::DXTL(arrowcolorbox) -sticky ew -row $::DXTL(arrowcolorbox_row) \
[846]	324	-column 1 -columnspan 5
[836]	325	}
[807]	326	catch {unset typelist}
[1225]	327	set ::DXTL(title) [phaseinfo $phase name]
[807]	328	foreach atom $expmap(atomlist_$phase) {
	329	set typelist([atominfo $phase $atom type]) 1
	330	}
[1225]	331	set ::DXTL(typelist) [array names typelist]
[807]	332	set row 0
[1225]	333	grid [label $::DXTL(lb).l$row -text "type " -bg yellow\
[807]	334	] -column 0 -row $row -sticky ew
[1225]	335	grid [label $::DXTL(lb).d$row -text " representation " -bg yellow
[807]	336	] -column 1 -row $row -sticky ew
[1225]	337	grid [label $::DXTL(lb).e$row -text " radius " -bg yellow\
[807]	338	] -column 2 -row $row -sticky ew
[1225]	339	grid [label $::DXTL(lb).c$row -text " color " -bg yellow\
[807]	340	] -column 3 -row $row -sticky ew
	341	foreach type [array names typelist] {
	342	incr row
[1225]	343	grid [label $::DXTL(lb).l$row -text $type] -column 0 -row $row
	344	tk_optionMenu $::DXTL(lb).d$row ::DXTL(display_$type) sphere polyhedron ellipsoid none
	345	grid $::DXTL(lb).d$row -column 1 -row $row
	346	grid [entry $::DXTL(lb).e$row -textvariable ::DXTL(radius_$type) \
[807]	347	-width 5] -column 2 -row $row
[1225]	348	eval tk_optionMenu $::DXTL(lb).c$row ::DXTL(color_$type) $::DXTLcolorlist
	349	grid $::DXTL(lb).c$row -column 3 -row $row
	350	set ::DXTL(display_$type) sphere
	351	set ::DXTL(radius_$type) 0.2
	352	set ::DXTL(color_$type) [lindex $::DXTLcolorlist $row]
[807]	353	}
	354	# Resize the list
[1225]	355	update idletasks
	356	foreach i {lb Blst fb} {
	357	set sizes [grid bbox $::DXTL($i)]
	358	[winfo parent $::DXTL($i)] config -scrollregion $sizes \
	359	-width [lindex $sizes 2]
	360	}
	361	wm geom [winfo toplevel $::DXTL(Blst)] {}
[807]	362	}
	363
	364	# add bonds to bond list
	365	proc DXTLaddBond {} {
[1225]	366	if {$::DXTL(bonds) == 0} {
[807]	367	# insert header
	368	set row 0
[1225]	369	grid [label $::DXTL(Blst).a$row -text "from " -bg yellow\
[807]	370	] -column 1 -row $row -sticky ew
[1225]	371	grid [label $::DXTL(Blst).b$row -text " to " -bg yellow\
[807]	372	] -column 2 -row $row -sticky ew
[1225]	373	grid [label $::DXTL(Blst).c$row -text " width " -bg yellow\
[807]	374	] -column 3 -row $row -sticky ew
[1225]	375	grid [label $::DXTL(Blst).d$row -text " min " -bg yellow\
[807]	376	] -column 4 -row $row -sticky ew
[1225]	377	grid [label $::DXTL(Blst).e$row -text " max " -bg yellow\
[807]	378	] -column 5 -row $row -sticky ew
[1225]	379	grid [label $::DXTL(Blst).f$row -text " color " -bg yellow\
[807]	380	] -column 6 -row $row -sticky ew
	381	}
[1225]	382	set row [incr ::DXTL(bonds)]
	383	eval tk_optionMenu $::DXTL(Blst).ta$row ::DXTL(ba_$row) $::DXTL(typelist)
	384	grid $::DXTL(Blst).ta$row -column 1 -row $row
	385	eval tk_optionMenu $::DXTL(Blst).tb$row ::DXTL(bb_$row) $::DXTL(typelist)
	386	grid $::DXTL(Blst).tb$row -column 2 -row $row
	387	grid [entry $::DXTL(Blst).w$row -textvariable ::DXTL(bw_$row) \
[807]	388	-width 5] -column 3 -row $row
[1225]	389	grid [entry $::DXTL(Blst).mi$row -textvariable ::DXTL(bmin_$row) \
[807]	390	-width 5] -column 4 -row $row
[1225]	391	grid [entry $::DXTL(Blst).mx$row -textvariable ::DXTL(bmax_$row) \
[807]	392	-width 5] -column 5 -row $row
[1225]	393	eval tk_optionMenu $::DXTL(Blst).c$row ::DXTL(bc_$row) $::DXTLcolorlist
	394	grid $::DXTL(Blst).c$row -column 6 -row $row
	395	set ::DXTL(bw_$row) 0.02
	396	set ::DXTL(bmin_$row) 1.0
	397	set ::DXTL(bmax_$row) 2.0
	398	set ::DXTL(bc_$row) [lindex $::DXTLcolorlist $row]
[807]	399	# Resize the list
	400	update
[1225]	401	set sizes [grid bbox $::DXTL(Blst)]
	402	[winfo parent $::DXTL(Blst)] config -scrollregion $sizes \
[807]	403	-width [lindex $sizes 2]
[1225]	404	#set can [winfo parent $::DXTL($i)]
	405	#set scroll [winfo parent $can].scroll
	406	#[winfo parent $::DXTL($i)] config -scrollregion $sizes
[836]	407	}
	408
	409	proc DXTLwriteArrows {out phase} {
[1225]	410	global expgui expmap
[836]	411	set fp [open geom.in w]
	412	puts $fp "N"
	413	puts $fp "M"
	414	if {[llength $expmap(phaselist)] > 1} {
	415	puts $fp "$phase"
	416	}
	417	puts $fp "N"
	418	puts $fp "X"
	419	close $fp
	420	catch {
	421	if {$::tcl_platform(platform) == "windows"} {
	422	exec [file join $expgui(gsasexe) geometry.exe] \
	423	[file root $expgui(expfile)] < geom.in >& geom.out
	424	} else {
	425	exec [file join $expgui(gsasexe) geometry] \
	426	[file root $expgui(expfile)] < geom.in >& geom.out
	427	}
	428	set fp [open geom.out r]
	429	while {[gets $fp line] >= 0} {
[846]	430	if {[string match "Geometry,L,N,*" $line]} {
	431	MyMessageBox -parent . -title "Old GSAS" \
	432	-message "Old GEOMETRY program: You are using an old version of GSAS that cannot export magnetic vectors. Upgrade GSAS to generate arrows." -icon warning
	433	break
	434	}
[836]	435	if {[string match "nameelemx y zx y z*" $line]} {break}
	436	}
	437	set i 0
	438	while {[gets $fp line] >= 0} {
	439	if {[string match "Enter Geometry option" $line]} {break}
	440	incr i
	441	if {$i == 2} {
	442	set name [string trim [string range $line 5 12]]
	443	set tail [string trim [string range $line 22 end]]
	444	set pos [lrange $tail 0 2]
	445	set spin [lindex $tail end]
	446	} elseif {$i == 5} {
	447	set vec [string trim [string range $line 22 end]]
	448	if {[catch {set count($name)}]} {set count($name) 0}
	449	catch {
	450	set k ?
	451	incr count($name)
	452	set k $count($name)
	453	}
	454	puts $out "rem spin for atom $name # $k ($spin)"
	455	if {$spin == "Red"} {
[1225]	456	puts $out "arrow $pos $vec 1. 0.15 $::DXTL(redarrow)"
[836]	457	} else {
[1225]	458	puts $out "arrow $pos $vec 1. 0.15 $::DXTL(blackarrow)"
[836]	459	}
	460	} elseif {$i == 6} {
	461	set i 1
	462	}
	463	}
	464	}
	465	catch {close $fp}
	466	catch {file delete -force geom.in geom.out}
	467	puts $out "mag_trans 1. 0 0 0 1. 0 0 0 1."
[1225]	468	}
	469
	470	# Computes a Fourier map(s) and converts the maps from binary to ascii
	471	# returns a list of Fourier map types
	472	proc DXTLwritegrd {phase} {
	473	global expgui expmap
	474	set lst [listFourier]
	475	if {[llength $lst] < 1} {
	476	MyMessageBox -parent . -title "No Fourier" \
	477	-message "You have not set up to compute a Fourier map." \
	478	-icon warning
	479	return
	480	}
	481	set typelist {}
	482	foreach l $lst {
	483	lappend typelist [Fourierinfo $l type]
	484	}
	485	set hists [FourierHists $phase]
	486	# make sure we have default limits
	487	getFourierLimits $phase
	488	if {[llength $hists] < 1} {
	489	MyMessageBox -parent . -title "No Fourier" \
	490	-message "You have not set up to compute a Fourier map for phase $phase." \
	491	-icon warning
	492	return
	493	}
	494	if {$::tcl_platform(platform) == "windows"} {
	495	set map [file join $expgui(gsasexe) gsas2map.exe]
	496	set fourier [file join $expgui(gsasexe) fourier.exe]
	497	} else {
	498	set map [file join $expgui(gsasexe) gsas2map]
	499	set fourier [file join $expgui(gsasexe) fourier]
	500	}
	501	if {![file exists $map]} {
	502	MyMessageBox -parent . -title "No Map Converter prog" \
	503	-message "Error Fourier map converter program ($map) not found." \
	504	-icon warning
	505	return
	506	}
	507	if {![file exists $fourier]} {
	508	MyMessageBox -parent . -title "No Fourier prog" \
	509	-message "Error Fourier program ($fourier) not found." \
	510	-icon warning
	511	return
	512	}
	513	set fp [open f.in w]
	514	if {[OutputFourierType]} {
	515	puts $fp [lindex $typelist 0]
	516	}
	517	puts $fp "E"
	518	foreach t [lrange $typelist 1 end] {
	519	puts $fp "F $t"
	520	puts $fp "E"
	521	}
	522	puts $fp "q"
	523	close $fp
	524	# delete any old grd files
	525	foreach f [glob -nocomplain "[file root $expgui(expfile)]*.grd"] {
	526	catch {file delete -force $f}
	527	}
	528	set deleteerror 0
	529	if {[llength [glob -nocomplain "[file root $expgui(expfile)]*.grd"]] >0} {
	530	MyMessageBox -parent . -title "Old grd files?" \
	531	-message "Warning: Could not delete old .grd files; it will probably not be possible to overwrite them either. Be aware that map results may be out of date." \
	532	-icon warning
	533	set deleteerror 1
	534	}
	535	# Save the current exp file
	536	savearchiveexp
	537	# disable the file changed monitor
	538	set expgui(expModifiedLast) 0
	539	catch {
	540	exec $fourier [file root $expgui(expfile)] >& f.out
	541	exec $map [file root $expgui(expfile)] < f.in >>& f.out
	542	}
	543	# reset the file changed monitor
	544	#loadexp $expgui(expfile)
	545	set expgui(expModifiedLast) [file mtime $expgui(expfile)]
	546
	547	if {[llength [glob -nocomplain "[file root $expgui(expfile)]*.grd"]] == 0} {
	548	set fp [open f.out r]
	549	set lines {}
	550	while {[gets $fp line] >= 0} {
	551	append lines $line "\n"
	552	}
	553	close $fp
	554	MyMessageBox -parent . -title "No grd files" \
	555	-message "Error: no .grd files were created. See log file below\n\n$lines" \
	556	-icon error
	557	return {}
	558	} else {
	559	catch {close $fp}
	560	catch {file delete -force f.in f.out}
	561	SetupFourierButtons
	562	return $typelist
	563	}
	564	}
	565
	566	# called when the phase # is set or changed
	567	# clean up old Fourier maps
	568	proc OnNewFourierPhase {args} {
	569	SetDXTLatoms
	570	if {[llength $::expmap(phaselist)] > 1} {
	571	# there is more than one phase; delete any .grd files to make sure
	572	# generate ones for the current phase
	573	foreach f [glob -nocomplain "[file root $::expgui(expfile)]*.grd"] {
	574	catch {file delete -force $f}
	575	}
	576	}
	577	SetupFourierButtons
	578	eval destroy [winfo children $::DXTL(fb)]
	579	set ::DXTL(contours) 0
	580	}
	581
	582	# this enables/disables Fourier buttons based on the Fourier setup
	583	# and the files that are present
	584	proc SetupFourierButtons {} {
	585	if {[catch {
	586	set phase $::expgui(export_phase)
	587	$::DXTL(FourCompute) config -state disabled
	588	$::DXTL(AddContour) config -state disabled
	589	$::DXTL(fmenu) delete 0 end
	590	}]} return
	591	set ::DXTL(mtype) ""
	592	set ::DXTL(mfil) ""
	593	set ::DXTL(FourierRange) ""
	594	# if the Fourier is not set up; return here
	595	if {[llength [set nF [listFourier]]] < 1} return
	596	# check that all phases are set to current phase
	597	foreach i $nF {
	598	set ph [Fourierinfo $i phase]
	599	if {$ph != $phase} return
	600	}
	601	if {[llength [FourierHists $phase]] < 1} return
	602	# make sure we have default limits
	603	getFourierLimits $phase
	604	$::DXTL(FourCompute) config -state normal
	605	# if there are no maps, return now
	606	set maps [glob -nocomplain "[file root $::expgui(expfile)]*.grd"]
	607	if {[llength $maps] < 1} return
	608	set types {}
	609	foreach fil $maps {
	610	lappend types [lindex [split [file root [file tail $fil]] "_"] end]
	611	}
	612	set i 0
	613	foreach fil $maps lbl $types {
	614	$::DXTL(fmenu) add command -label $lbl \
	615	-command "set DXTL(mtype) $lbl; set DXTL(mfil) $fil; GetFourierRange"
	616	if {$i == 0} {
	617	$::DXTL(fmenu) invoke 0
	618	$::DXTL(AddContour) config -state normal
	619	}
	620	incr i
	621	}
	622	}
	623
	624	proc AddContour {} {
	625	# set a header
	626	if {$::DXTL(contours) == 0} {
	627	set row 0
	628	grid [label $::DXTL(fb).a$row -text "Type" -bg yellow \
	629	] -column 1 -row $row -sticky ew
	630	grid [label $::DXTL(fb).b$row -text "Contour Level" -bg yellow \
	631	] -column 2 -row $row -sticky ew
	632	grid [label $::DXTL(fb).c$row -text "Color" -bg yellow \
	633	-anchor center] -column 3 -row $row -sticky ew
	634	}
	635	set row [incr ::DXTL(contours)]
	636	eval tk_optionMenu $::DXTL(fb).ta$row ::DXTL(fb_type_$row) {mesh solid}
	637	grid $::DXTL(fb).ta$row -column 1 -row $row
	638	grid [entry $::DXTL(fb).w$row -width 10 -textvariable ::DXTL(fb_val_$row) \
	639	] -column 2 -row $row
	640	set menu [eval tk_optionMenu $::DXTL(fb).tb$row \
	641	::DXTL(fb_color_$row) $::DXTLcolorlist]
	642	$menu invoke $row
	643	grid $::DXTL(fb).tb$row -column 3 -row $row
	644	grid [button $::DXTL(fb).del$row -text "Delete"\
	645	-command "DeleteFourierContour $row"] -column 4 -row $row
	646	update idletasks
	647	set sizes [grid bbox $::DXTL(fb)]
	648	[winfo parent $::DXTL(fb)] config -scrollregion $sizes \
	649	-width [lindex $sizes 2]
	650	}
	651
	652	proc DeleteFourierContour {row} {
	653	foreach i "$::DXTL(fb).ta$row $::DXTL(fb).w$row $::DXTL(fb).tb$row \
	654	$::DXTL(fb).tb$row $::DXTL(fb).del$row" {
	655	catch {destroy $i}
	656	}
	657	set ::DXTL(fb_val_$i) ""
	658	if {$::DXTL(contours) == $row} {incr ::DXTL(contours) -1}
	659	}
	660
	661	proc GetFourierRange {} {
	662	set fp [open f.in w]
	663	set lst [listFourier]
	664	if {[llength $lst] < 1} {
	665	MyMessageBox -parent . -title "No Fourier" \
	666	-message "You have not set up to compute a Fourier map." \
	667	-icon warning
	668	return
	669	}
	670	set typelist {}
	671	foreach l $lst {
	672	lappend typelist [Fourierinfo $l type]
	673	}
	674	if {[OutputFourierType]} {
	675	puts $fp $::DXTL(mtype)
	676	}
	677	close $fp
	678	if {$::tcl_platform(platform) == "windows"} {
	679	set map [file join $::expgui(gsasexe) forsrh.exe]
	680	} else {
	681	set map [file join $::expgui(gsasexe) forsrh]
	682	}
	683	catch {
	684	exec $map [file root $::expgui(expfile)] < f.in >& f.out
	685	}
	686	foreach {min max} {{} {}} {}
	687	catch {
	688	set fp [open "f.out" r]
	689	while {[gets $fp line] >= 0} {
	690	if {[string first "range of map values" $line] != -1} {
	691	set off [expr 4 + [string first " is " $line]]
	692	foreach {min to max} [string trim [string range $line $off end]] {}
	693	break
	694	}
	695	}
	696	}
	697	catch {
	698	close $fp
	699	}
	700	if {$min != ""} {set ::DXTL(FourierRange) "Range: $min to $max"}
	701	}
	702
	703	# is output of the current Fourier map type required as input to a program?
	704	# answer is yes when more than one map file is present
	705	proc OutputFourierType {} {
	706	set i 0
	707	foreach ext {DEL FCL FOB PTS DPT} {
	708	if {[file exists [file root $::expgui(expfile)].$ext]} {
	709	incr i
	710	}
	711	for {set i 2} {$i <= 9} {incr i} {
	712	if {[file exists [file root $::expgui(expfile)].${i}FD]} {
	713	incr i
	714	}
	715	}
	716	}
	717	if {$i > 1} {
	718	return 1
	719	}
	720	return 0
	721	}
	722
	723	proc DXTLwriteFourierCommands {fp} {
	724	if {$::DXTL(mfil) == ""} return
	725	if {![file exists $::DXTL(mfil)]} {
	726	puts "file not found $::DXTL(mfil)"
	727	return
	728	}
	729	set cntlist {}
	730	for {set i 1} {$i <= $::DXTL(contours)} {incr i} {
	731	set val ""
	732	catch {set val $::DXTL(fb_val_$i)}
	733	if {[catch {set val [expr 1.*$val]}]} continue
	734	lappend cntlist [list $val $::DXTL(fb_type_$i) $::DXTL(fb_color_$i)] }
	735	if {[llength $cntlist] <= 0} return
	736	puts $fp "mapread grd [file tail $::DXTL(mfil)] 4"
	737	foreach item $cntlist {
	738	puts $fp "mapcontour $item"
	739	}
	740	set s {}
	741	foreach a {X Y Z} {
	742	lappend s $::DXTL(${a}dispMin)
	743	lappend s $::DXTL(${a}dispMax)
	744	}
	745	puts $fp "mapregion $s"
	746	}

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

Context Navigation

source: trunk/export_drawxtl.tcl

Download in other formats: