[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 "*name*elem*x *y *z*x *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 | } |
---|