source: trunk/export_shelx.tcl @ 528

Last change on this file since 528 was 528, checked in by toby, 11 years ago

# on 2002/01/22 21:45:59, toby did:
export coordinates in SHELX .INS format

  • Property rcs:author set to toby
  • Property rcs:date set to 2002/01/22 21:45:59
  • Property rcs:rev set to 1.1
  • Property rcs:state set to Exp
  • 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 528 2009-12-04 23:07:41Z 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                set m 1
106            } else {
107                # for macromolecular phases assume all atoms on
108                # general positions
109                set m [atominfo $phase $atom mult]
110                if {$m != $maxmult} {
111                    set m [expr {(1.*$m) / $maxmult}]
112                } else {
113                    set m 1
114                }
115            }
116            set frac [atominfo $phase $atom frac]
117            if {$frac == 1} {
118                set occ [expr {10 + $m}]
119            } else {
120                set occ [expr {$frac * $m}]
121            }
122            # prepare displacement parm string
123            set U {}
124            if {!$mm && [atominfo $phase $atom temptype] == "A"} {
125                foreach uij {U11 U22 U33 U23 U13 U12} {
126                    lappend U [atominfo $phase $atom $uij]
127                }
128            } else {
129                set U [$cmd $phase $atom Uiso]
130            }
131            foreach var {x y z} {
132                set $var [$cmd $phase $atom $var]
133            }
134            #write out the atom, tab delimited
135            puts $fp "$lbl $sfac $x $y $z $occ $U"
136        }
137        #==============================================================
138        close $fp
139    } errmsg] {
140        MyMessageBox -parent . -title "Export error" \
141                -message "Export error: $errmsg" -icon warning
142    } else {
143        MyMessageBox -parent . -title "Done" \
144                -message "File [file tail $filnam] was written"
145    }
146}
147
148proc ParseSGROUP {spg} {
149    # check the space group
150    global tcl_platform expgui
151    set fp [open spg.in w]
152    puts $fp "N"
153    puts $fp "N"
154    puts $fp $spg
155    puts $fp "Q"
156    close $fp
157    catch {
158        if {$tcl_platform(platform) == "windows"} {
159            exec [file join $expgui(gsasexe) spcgroup.exe] < spg.in >& spg.out
160        } else {
161            exec [file join $expgui(gsasexe) spcgroup] < spg.in >& spg.out
162        }
163    }
164    set fp [open spg.out r]
165    set out [read $fp]
166    close $fp
167    # look for errors -- there should not be any, but...
168    if {[regexp "space group symbol.*>(.*)Enter a new space group symbol" \
169            $out a b ] != 1} {set b $out}
170    if {[string first Error $b] != -1} {
171        return "error [list $b]"
172    }
173    set result "{} {} {}"
174    if {[regexp "he lattice is (.*) Laue" \
175            $out a result ] >= 1} {
176    }
177    set symlist {}
178    for {set i 1} {$i < 99} {incr i} {
179#       puts [format "(%2d) " $i]
180        set pos [string first [format "(%2d) " $i] $out]
181        if {$pos == -1} break
182        lappend symlist [string trim \
183                [string range $out [expr $pos+4] [expr $pos + 25]]]
184    }
185    lappend result $symlist
186    return $result
187}
Note: See TracBrowser for help on using the repository browser.