/usr/share/xcrysden/Tcl/groupSel.tcl is in xcrysden-data 1.5.60-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 | #############################################################################
# Author: #
# ------ #
# Anton Kokalj Email: Tone.Kokalj@ijs.si #
# Department of Physical and Organic Chemistry Phone: x 386 1 477 3523 #
# Jozef Stefan Institute Fax: x 386 1 477 3811 #
# Jamova 39, SI-1000 Ljubljana #
# SLOVENIA #
# #
# Source: $XCRYSDEN_TOPDIR/Tcl/groupSel.tcl
# ------ #
# Copyright (c) 1996-2014 by Anton Kokalj #
#############################################################################
proc group_sel { w type groups } {
global groupsel n_groupsel done but_press
# this Procedure "select" and return a GROUP (point, line, plane,
# space group)
#
# w - name of toplevel widget
# ^
# type - name for type of group (point, line, plane, space )
#
# groups - list of groups
# ^^^^^^
# groupsel - selected group
# ^^^^^^^^
# groupsel is global; proc group_sel wait unit $but_press is TRUE
# and then exit; gropusel is returned
if ![info exists groupsel ] {set groupsel {}}
set but_press 0
xcToplevel $w "Select a $type group" "Selection" . 120 70 1
# make a top_frame & bottom_frame
frame $w.top -relief raised -bd 1
pack $w.top -side top -fill both
frame $w.bot -relief raised -bd 1
pack $w.bot -side bottom -fill both
# name of widget goes in the top frame
label $w.top.lab -text "Select a $type group"
pack $w.top.lab -side top -expand 1 -fill both -padx 5m -pady 5m
# in the top of BOTTOM frame will be an ENTRY for selected group;
# bellow will be "selection listbox"
label $w.top.label -text "Group:" -padx 0
#------------------------------------------------------
# take care of this ENTRY and groupsel textvariable
#------------------------------------------------------
entry $w.top.entry -relief sunken -textvariable groupsel
focus $w.top.entry
# make LEFT & RIGHT frame in bottom frame;
# in LEFT goes LISTBOX;
# in RIGHT go OK & CANCEL buttons
frame $w.bot.left
frame $w.bot.right
frame $w.bot.right.ok
set ok [button $w.bot.right.ok.ok -text OK -command [list group_sel_ok $groups]]
set can [button $w.bot.right.can -text Cancel \
-command [list group_sel_cancel $w]]
# now we'll create LISTBOX; it's ScrolledListbox2 from the book of
# Brent B. Welch
ScrolledListbox2 $w.bot.left.lb -width 20 -height 20 -setgrid true
# now we'll pack what we create so far
pack $w.top.label -side left -pady 10 -padx 5
pack $w.top.entry -side left -fill x -expand true -pady 10 -padx 5
pack $w.bot.left -side left -fill both
pack $w.bot.right -side left -fill both
pack $w.bot.right.ok $can -side top -padx 10 -pady 5
pack $ok -padx 4 -pady 4
# now we'll create a bindings for ENTRY
bind $w.top.entry <Return> "set done 1"
# now we'll create BINDINGs for this LISTBOX
bind $w.bot.left.lb.list <ButtonPress-1> {GroupSelectStart %W %y}
bind $w.bot.left.lb.list <ButtonRelease-1> \
[list GroupSelectEnd %W %y]
# now we'll insert the GROUPS in the listbox;
# GROUPS variable holds all groups
eval {$w.bot.left.lb.list insert 0} $groups
# wait unit $done is specefied
tkwait variable but_press
destroy $w
return $groupsel
}
#-----------------------------
# END OF GROUP_SEL PROC
#-----------------------------
#------------------------------------
# here are auxiliary procs
#------------------------------------
proc GroupSelectStart { w y } {
$w select anchor [$w nearest $y]
}
proc GroupSelectEnd { w y } {
global groupsel
# $w is the name of listbox widget who contains groups
# $y is the vertical position of "selection"
$w select anchor [$w nearest $y]
# nline is index of selected line
set nline [$w curselection]
set groupsel [$w get $nline]
# now we must get rid of seq_num: (ex. 20: GROUP)
# ^^^^^^^ ^^^
# i=position/index of the first caracter og group which is 4 more than
# index of :
# j=lenght_of$groupsel
set i [expr [string first : $groupsel] + 4]
set j [string length $groupsel]
# assing "pure" group to groupsel
set groupsel [string range $groupsel $i $j]
}
proc group_sel_cancel { w } {
global groupsel but_press
set groupsel {}
set but_press 1
}
proc group_sel_ok { groups } {
global groupsel n_groupsel done but_press err
# $groups is a list of groups
# err is used by contrl_var variable
set err 0
# translate $groupsel to UPPER CASE
set groupsel [string toupper $groupsel]
# check if specified group is OK
# $groups contanins "inpurities" (ex.{ 5: P 1 1 2 }),
# but $groupsel could also contains white_space inpurity
set ok 0
set n 1
# pure the groupsel
# NOTE: this REGEXP is extremly complex, but it looks that it works
regexp {(([A-Z0-9] )|[A-Z0-9\/\-])+[A-Z0-9]} $groupsel groupsel
foreach word $groups {
# pure the $word
set last [ string length $word ]
set word [ string range $word 5 $last ]
regexp {(([A-Z0-9] )|[A-Z0-9\/\-])+[A-Z0-9]} $word word
if { $groupsel == $word } {
set ok 1
set n_groupsel $n
}
incr n
}
# if "ok" is still is still 0, it maybe not a standard group;
# but that is just for crystals
if { $ok == 0 } {
set ok [IsNotStandardGroup $groupsel]
set n_groupsel 999
}
if { $ok == 0} {
# specefied group is WRONG
dialog .group_sel_warning Warning \
"Group \"$groupsel\" is false. You probably mistype the group.\
Try again or select one from the list" warning 0 OK
set err 1
} else {
# group is OK
# we have selected; so $done will be set to 1
set done 1
#this is used for GROUP_SEL PROC
set but_press 1
}
}
#############################################################################
# this proc is used when non-standard group is used that is not on
# $space_group list; we check if it is valid and which parameters are needed
# for it!!!
proc IsNotStandardGroup {group} {
global class inp system
set par(1) 11.00111
set par(2) 22.00222
set par(3) 33.00333
set par(4) 44.00444
set par(5) 55.00555
set par(6) 66.00666
set cla {}
set cl(1) A
set cl(2) B
set cl(3) C
set cl(4) ALFA
set cl(5) BETA
set cl(6) GAMMA
set input "EOF"
append input "XCrySDen 1.0\n"
append input "CRYSTAL\n"
append input "1 0 0\n"
append input "$group\n"
append input "$par(1) $par(2) $par(3) $par(4) $par(5) $par(6)\n"
append input "1\n"
append input "1 0.0 0.0 0.0\n"
append input "STOP\n"
append input "XCrySDen 1.0\n"
append input "EOF"
set nlat 0
set num ""
cd $system(SCRDIR)
set output [RunAndGetC95Output $system(c95_integrals) {} $input]
xcDebug "output: \n$output"
# check if error occured
set is_error 0
if { [string match *ERROR* $output] } {
set is_error 1
if { ($system(c95_version) == "06" || $system(c95_version) == "09" || $system(c95_version) == "14" ) && [string match "*STOP KEYWORD - EXECUTION STOPS*" $output] } {
# OK, we don't have error
set is_error 0
}
}
if { $is_error } {
return 0
} else {
set output [split $output \n]
foreach line $output {
if [string match "*CRYSTAL FAMILY*" $line] {
set inp(CRY_FAM) [lrange $line 3 end]
}
if [string match "*CRYSTAL CLASS*" $line] {
set inp(CRY_CLASS) [lrange $line 6 end]
}
# LATTICE PARAMETERS
if { $nlat == 2 } {
for {set i 1} {$i <= 6} {incr i} {
set ii [expr $i - 1]
set re($i) [lindex $line $ii]
for {set j 1} {$j <= 6} {incr j} {
if { $re($i) == $par($j) } {
append cla "$cl($i) "
# delete element that was found from "par" array
set par($j) ""
}
}
}
incr nlat
}
if { $nlat == 1 } {
incr nlat
}
if { [string match "*ICE PAR*" $line] && $nlat == 0 } {
incr nlat
}
}
if { ! [info exists cla] } {
tk_messageBox -message "Ups! This is a bug in the program. Please
report it to: tone.kokalj@ijs.si with the detailed explanation what yoy were doing and if possible also Email the CRYSTAL input file you have been working on when the error occured !\n\nThe application will exit now." -type ok -icon info
exit_pr immediately
}
foreach item $cla {
if { $item == "A" || $item == "B" || $item == "C" } {
append class1 "$item "
} else {
append class2 "$item "
}
}
# get rid of last space-character in class1 & class2
set class1 [string trimright $class1 " "]
if [info exists class2] { set class2 [string trimright $class2 " "] }
set class ""
lappend class $class1
if [info exists class2] { lappend class $class2 }
#set class [list $class]
puts stdout "GROUP: $group CLASS: $class"
return 1
}
}
|