source: branches/sandbox/export_shelx.tcl

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

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

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Revision Id
File size: 5.5 KB
Line 
1# Export coordinates to SHELX (.ins) format file
2# $Id: export_shelx.tcl 1250 2014-03-10 21:23:13Z toby $
3set label "export SHELX (.ins) format"
4set action export_SHELX
5proc export_SHELX {} {
6    global expmap expgui
7    # don't bother if there are no phases to write
8    if {[llength $expmap(phaselist)] == 0} {
9        MyMessageBox -parent . -title "No phases" \
10                -message "Sorry, no phases are present to write" \
11                -icon warning
12        return
13    }
14    MakeExportBox .export "Export coordinates in SHELX (.ins) format" \
15            "MakeWWWHelp expgui.html ExportSHELX"
16    # note, change export in the line above to the name anchor for a
17    # section documenenting the format added to expgui.html, if added
18    #
19    # force the window to stay on top
20    putontop .export
21    # Wait for the Write or Quit button to be pressed
22    tkwait window .export
23    afterputontop
24    # test for Quit
25    if {$expgui(export_phase) == 0} {return}
26
27    # now open the file and write it
28    set phase $expgui(export_phase)
29    if [catch {
30        set filnam [file rootname $expgui(expfile)]_${phase}.ins
31        set fp [open $filnam w]
32        # deal with macromolecular phases
33        if {[lindex $expmap(phasetype) [expr {$phase - 1}]] == 4} {
34            set mm 1
35            set cmd mmatominfo
36        } else {
37            set mm 0
38            set cmd atominfo
39        }
40        #==============================================================
41        # title info from GSAS title & phase title
42        puts $fp "TITL [expinfo title]"
43        # write out cell parameters with dummy (0.5A) wavelength
44        set line {CELL 0.5}
45        foreach p {a b c alpha beta gamma} {
46            lappend line [phaseinfo $phase $p]
47        }
48        puts $fp $line
49        # turn space group into lattice type and a list of unique symm opts
50        # (omit x,y,z, centering, center of sym=-x,-y,-z)
51        set sginfo [ParseSGROUP [phaseinfo $phase spacegroup]]
52        set centerlist { 
53            dummy primitive i-centered r-centered f-centered a-centered
54            b-centered c-centered
55        }
56        set L [lsearch $centerlist [string tolower [lindex $sginfo 1]]]
57        if {$L == -1} {
58            MyMessageBox -parent . -title "Parse error" \
59                    -message "Export error: could not parse SGROUP output for  [phaseinfo $phase spacegroup]" \
60                    -icon warning
61            set L 1
62        }
63        if {[string tolower [lindex $sginfo 0]] == "acentric"} {
64            set L "-$L"
65        }
66        puts $fp "LATT $L"
67        foreach s [lrange [lindex $sginfo 3] 1 end] {
68            puts $fp "SYMM [lindex $s 0], [lindex $s 1], [lindex $s 2]"
69        }
70        set maxmult 1
71        # loop over atoms to count types
72        foreach atom $expmap(atomlist_$phase) {
73            # count the unique atom types
74            set type [$cmd $phase $atom type]
75            # parse to element symbol
76            regexp {([a-zA-Z]+)} $type a type
77            set type [string range $type 0 1]
78            if {[catch {incr count($type)}]} {set count($type) 1}
79            # get maximum multiplicity
80            if {!$mm} {         
81                set m [atominfo $phase $atom mult]
82                if {$m > $maxmult} {set maxmult $m}
83            }
84        }
85        set elemlist [array names count] 
86        puts $fp "SFAC $elemlist"
87        set fmt %s%d
88        foreach n $elemlist {
89            if {$count($n) > 99} {set fmt %s%.2x}
90            set count($n) 0
91        }
92        foreach atom $expmap(atomlist_$phase) {
93            # count the unique atom types
94            set type [$cmd $phase $atom type]
95            # parse to element symbol
96            regexp {([a-zA-Z]+)} $type a type
97            set type [string range $type 0 1]       
98            # make a 4 character label
99            set lbl [format $fmt $type [incr count($type)]]
100            # find the scattering factor number
101            set sfac [lsearch $elemlist $type]
102            incr sfac
103            # determine SHELX occupancy
104            if {$mm} {
105                # for macromolecular phases assume all atoms on
106                # general positions
107                set m 1
108                set frac [mmatominfo $phase $atom frac]
109            } else {
110                set m [atominfo $phase $atom mult]
111                if {$m != $maxmult} {
112                    set m [expr {(1.*$m) / $maxmult}]
113                } else {
114                    set m 1
115                }
116                set frac [atominfo $phase $atom frac]
117            }
118            if {$frac == 1} {
119                set occ [expr {10 + $m}]
120            } else {
121                set occ [expr {$frac * $m}]
122            }
123            # prepare displacement parm string
124            set U {}
125            if {!$mm && [atominfo $phase $atom temptype] == "A"} {
126                foreach uij {U11 U22 U33 U23 U13 U12} {
127                    lappend U [atominfo $phase $atom $uij]
128                }
129            } else {
130                set U [$cmd $phase $atom Uiso]
131            }
132            foreach var {x y z} {
133                set $var [$cmd $phase $atom $var]
134            }
135            #write out the atom, tab delimited
136            puts $fp "$lbl $sfac $x $y $z $occ $U"
137        }
138        #==============================================================
139        close $fp
140    } errmsg] {
141        MyMessageBox -parent . -title "Export error" \
142                -message "Export error: $errmsg" -icon warning
143    } else {
144        MyMessageBox -parent . -title "Done" \
145                -message "File [file tail $filnam] was written"
146    }
147}
148
149proc ParseSGROUP {spg} {
150    # check the space group
151    global tcl_platform expgui
152    set fp [open spg.in w]
153    puts $fp "N"
154    puts $fp "N"
155    puts $fp $spg
156    puts $fp "Q"
157    close $fp
158    catch {
159        if {$tcl_platform(platform) == "windows"} {
160            exec [file join $expgui(gsasexe) spcgroup.exe] < spg.in >& spg.out
161        } else {
162            exec [file join $expgui(gsasexe) spcgroup] < spg.in >& spg.out
163        }
164    }
165    set fp [open spg.out r]
166    set out [read $fp]
167    close $fp
168    # look for errors -- there should not be any, but...
169    if {[regexp "space group symbol.*>(.*)Enter a new space group symbol" \
170            $out a b ] != 1} {set b $out}
171    if {[string first Error $b] != -1} {
172        return "error [list $b]"
173    }
174    set result "{} {} {}"
175    if {[regexp "he lattice is (.*) Laue" \
176            $out a result ] >= 1} {
177    }
178    set symlist {}
179    for {set i 1} {$i < 99} {incr i} {
180#       puts [format "(%2d) " $i]
181        set pos [string first [format "(%2d) " $i] $out]
182        if {$pos == -1} break
183        lappend symlist [string trim \
184                [string range $out [expr $pos+4] [expr $pos + 25]]]
185    }
186    lappend result $symlist
187    return $result
188}
Note: See TracBrowser for help on using the repository browser.