source: branches/sandbox/rigid.tcl @ 1111

Last change on this file since 1111 was 1111, checked in by toby, 10 years ago

work in progress add plotting, error on rb/phase plot

File size: 17.6 KB
Line 
1 #proc RB_Load_RBdata   loads rigid body data
2 #proc RB_Load_Mapdata  loads rigid body mapping data
3 #proc RB_Control_Panel
4 #proc RB_View_Matrix
5 #proc RB_Populate
6
7lappend auto_path c:/gsas/expgui
8package require Tk
9package require BWidget
10#package require La
11#namespace import La::*
12source c:/gsas/sandboxexpgui/readexp.tcl
13source c:/gsas/sandboxexpgui/gsascmds.tcl
14source c:/gsas/sandboxexpgui/rb.tcl
15
16
17expload rb6.exp
18mapexp
19
20############################################################
21#global variables generated by RB_Load (x = rigid body number
22#                                       y = matrix number
23#                                       z = coordinate number
24#          ::rb_number          number of rigid bodies.
25#          ::rb_map(x)          number of times rigid body is mapped.
26#          ::rb_matrix_num(x)   number of matrices in rigid body.
27#          ::rb_mult(x,y)       multiplier for matrix.
28#          ::rb_damp(x,y)       damping factor for matrix.
29#          ::rb_var(x,y)        variable for matrix.
30#          ::rb_coord_num(x,y)  number of coordinates associated with matrix.
31#          ::rb_coord(x,y,z)    coordinates
32#          ::rb_phase_list      list of phases
33
34proc RB_Load_RBdata {args} {
35     catch {unset ::rb}
36#Read the number of rigid bodies in EXP file
37     set ::rb_number [RigidBodyCount]
38
39#Read the Rigid Body Information
40     for {set i 1} {$i <= $::rb_number} {incr i} {
41             set rb($i) [ReadRigidBody $i]
42             #Set the number of times rigid body is mapped.
43             set ::rb_map($i) [lindex $rb($i) 0]
44             puts "rigid body $i was mapped $::rb_map($i) times"
45
46             #define the matrices
47             set rb_mat [lindex $rb($i) 1]
48             set ::rb_matrix_num($i) [llength $rb_mat]
49             puts "Number of matrices in rigid body $i = $::rb_matrix_num($i)"
50
51             for {set j 1} {$j <= $::rb_matrix_num($i)} {incr j} {
52                 set temp [lindex $rb_mat [expr $j - 1]]
53                 set ::rb_mult($i,$j) [lindex $temp 0]
54                 set ::rb_damp($i,$j) [lindex $temp 1]
55                 set ::rb_var($i,$j)  [lindex $temp 2]
56                 puts "mult = $::rb_mult($i,$j), damp = $::rb_damp($i,$j), variable = $::rb_var($i,$j)"
57                 set coords [lindex $temp 3]
58                 set ::rb_coord_num($i,$j) [llength $coords]
59                 puts "number of coordinates = $::rb_coord_num($i,$j)"
60                 for {set k 0} {$k < $::rb_coord_num($i,$j)} {incr k} {
61                     set ::rb_coord($i,$j,$k) [lindex $coords $k]
62                     puts "coordinate [expr $k +1] = $::rb_coord($i,$j,$k)"
63                 }
64
65             }
66     }
67}
68
69
70
71############################################
72#           ::rb_map_beginning(x,y,z)   first atom in list
73#           ::rb_map_origin(x,y,z)      origin of rigid body
74#           ::rb_map_euler(x,y,z)       euler angles of rigid body
75#           ::rb_map_positions(x,y,z)   positions
76#           ::rb_map_damping(x,y,z)     damping
77#           ::rb_map_tls(x,y,z)         tls
78#           ::rb_map_tls_var(x,y,z)
79#           ::rb_map_tls_damp(x,y,z)
80proc RB_Load_Mapdata {phase rb_type map_num args} {
81     set rb_map [ReadRigidBodyMapping $phase $rb_type $map_num]
82     set ::rb_map_beginning($phase,$rb_type,$map_num) [lindex $rb_map 0]
83     set ::rb_map_origin($phase,$rb_type,$map_num) [lindex $rb_map 1]
84     set ::rb_map_euler($phase,$rb_type,$map_num) [lindex $rb_map 2]
85     set ::rb_map_positions($phase,$rb_type,$map_num) [lindex $rb_map 3]
86     set ::rb_map_damping($phase,$rb_type,$map_num) [lindex $rb_map 4]
87     set ::rb_map_tls($phase,$rb_type,$map_num) [lindex $rb_map 5]
88     set ::rb_map_tls_var($phase,$rb_type,$map_num) [lindex $rb_map 6]
89     set ::rb_map_tls_damp($phase,$rb_type,$map_num) [lindex $rb_map 7]
90}
91
92
93proc RB_View_Matrix {x args} {
94     catch {destroy .viewmatrix}
95     set vm .viewmatrix
96     toplevel $vm
97     wm title $vm "View Matrices for Rigid Body $x"
98     grid [label $vm.lblm -text "Matrix Number"] -row 2 -column 0
99     grid [label $vm.lbldamp -text "Matrix Multiplier"] -row 3 -column 0
100     grid [label $vm.lblvar -text "Matrix Damping Factor"] -row 4 -column 0
101
102     set y 1
103     for {set z 0} {$z < $::rb_coord_num($x,$y)} {incr z} {
104         label $vm.lbls$z -text "Site [expr $z+ 1]"
105         grid $vm.lbls$z -row [expr $z+5] -column 0
106     }
107
108     for {set y 1} {$y <= $::rb_matrix_num($x)} {incr y} {
109         grid [label $vm.lblm$y -text "Matrix #$y"] -row 2 -column $y
110         grid [entry $vm.mult$y -textvariable ::rb_mult($x,$y)] -row 3 -column $y
111         grid [entry $vm.damp$y -textvariable ::rb_damp($x,$y)] -row 4 -column $y
112         for {set z 0} {$z < $::rb_coord_num($x,$y)} {incr z} {
113             label $vm.lblc$y$z -text $::rb_coord($x,$y,$z)
114             grid $vm.lblc$y$z -row [expr $z+5] -column $y
115         }
116     }
117
118     putontop $vm
119}
120
121proc RB_View_Parameters {phase x y args} {
122   set euler     $::rb_map_euler($phase,$x,$y)
123   set positions $::rb_map_positions($phase,$x,$y)
124   set damping   $::rb_map_damping($phase,$x,$y)
125   catch {destroy .viewparam}
126   set vp .viewparam
127   toplevel $vp
128   wm title $vp "Refinement Options"
129   frame $vp.con -bd 2 -relief groove
130   frame $vp.spa -bd 2 -relief groove
131   frame $vp.refflag -bd 2 -relief groove
132   grid $vp.con -row 0 -column 0
133
134   grid $vp.spa -row 2 -column 0
135   grid $vp.refflag -row 1 -column 0
136
137   set con $vp.con
138   label $con.lbl -text "Refine: "
139   button $con.tog -text "off"
140   grid $con.lbl -row 0 -column 0
141   grid $con.tog -row 0 -column 1
142
143   grid [label $vp.spa.lbl1 -text "Supplemental Position Angles"] row 0 -column 0 -columnspan 3
144   set ::e_angle1$y [lindex [lindex $euler 3] 0]
145
146   set ::e_angle2$y [lindex [lindex $euler 4] 0]
147   set ::e_angle3$y [lindex [lindex $euler 5] 0]
148   grid [label $vp.spa.angle1l -text "Sup. Angle 1"] -row 1 -column 0
149   grid [label $vp.spa.angle2l -text "Sup. Angle 2"] -row 2 -column 0
150   grid [label $vp.spa.angle3l -text "Sup. Angle 3"] -row 3 -column 0
151   grid [entry $vp.spa.angle1 -textvariable ::e_angle1$y] -row 1 -column 1
152   grid [entry $vp.spa.angle2 -textvariable ::e_angle2$y] -row 2 -column 1
153   grid [entry $vp.spa.angle3 -textvariable ::e_angle3$y] -row 3 -column 1
154
155   set e_axis1 [lindex [lindex $euler 3] 1]
156   set e_axis2 [lindex [lindex $euler 4] 1]
157   set e_axis3 [lindex [lindex $euler 5] 1]
158
159   grid [label $vp.refflag.lbl1 -text "Refinement Flags"] -row 0 -column 0 -columnspan 3
160   grid [label $vp.refflag.x_axis -text "X-axis"] -row 1 -column 0
161   grid [label $vp.refflag.y_axis -text "Y-axis"] -row 1 -column 1
162   grid [label $vp.refflag.z_axis -text "Z-axis"] -row 1 -column 2
163   grid [label $vp.refflag.euler1 -text "Euler Angle 1"] -row 3 -column 0
164   grid [label $vp.refflag.euler2 -text "Euler Angle 2"] -row 3 -column 1
165   grid [label $vp.refflag.euler3 -text "Euler Angle 3"] -row 3 -column 2
166   grid [label $vp.refflag.sup1 -text "Sup. Angle 1"] -row 5 -column 0
167   grid [label $vp.refflag.sup2 -text "Sup. Angle 2"] -row 5 -column 1
168   grid [label $vp.refflag.sup3 -text "Sup. Angle 3"] -row 5 -column 2
169
170   for {set j 0} {$j < 9} {incr j} {
171       label $vp.refflag.$j -text [lindex $positions $j]
172   }
173   grid $vp.refflag.0 -row 2 -column 0
174   grid $vp.refflag.1 -row 2 -column 1
175   grid $vp.refflag.2 -row 2 -column 2
176   grid $vp.refflag.3 -row 4 -column 0
177   grid $vp.refflag.4 -row 4 -column 1
178   grid $vp.refflag.5 -row 4 -column 2
179   grid $vp.refflag.6 -row 6 -column 0
180   grid $vp.refflag.7 -row 6 -column 1
181   grid $vp.refflag.8 -row 6 -column 2
182
183
184
185   putontop $vp
186
187
188}
189
190
191#########################################
192#   rcb     .a               initial rigid body control panel.
193
194proc RB_Control_Panel {panelnum args} {
195     set rcb .a
196     #destroy $rcb
197     catch {toplevel $rcb} err
198     eval destroy [winfo children $rcb]
199     wm title $rcb "Rigid Body Control Panel"
200     wm geometry $rcb 700x400+10+10
201 #    frame $rcb.con -bd 2 -relief groove
202 #    grid $rcb.con -row 0 -column 0 -pady 10
203 #    button $rcb.con.create -text "Create Rigid Body"
204 #    grid $rcb.con.create -row 2 -column 0 -columnspan 2
205     set rb_nb $rcb.nb
206
207     # Enable NoteBook from BWidget package
208
209     set rb_body_list [NoteBook $rb_nb -side top]
210     for {set x 1} {$x <= $::rb_number} {incr x} {
211         $rb_body_list insert $x rb_body$x -text "Rigid Body Type $x"  \
212         -raisecmd "RB_Populate $rb_body_list $x"
213     }
214     $rb_body_list insert 16 rb_body16 -text "Create Rigid Body"
215     grid $rb_body_list -sticky news -column 0 -row 1 -columnspan 2
216     grid columnconfig $rcb 1 -weight 1
217     grid rowconfig    $rcb 1 -weight 1
218     $rb_body_list raise rb_body$panelnum
219}
220
221
222proc RB_Populate {rb_body_list x args} {
223#arbitrary fixing of phase
224     set phase $::expmap(phaselist)
225     set pane [$rb_body_list getframe rb_body$x]
226     eval destroy [winfo children $pane]
227     set con $pane.con
228     grid [frame $con -bd 2 -relief groove] -row 0 -column 1 -pady 10
229
230     #Rigid body mapping control panel along with matrix multipliers and damping factor labels
231     grid [label  $con.rb_num -text "Rigid Body Type $x"] -row 0 -column 0 -padx 5 -pady 5
232     grid [button $con.rb_newmap -text "Map New Body" -command "RB_Map_New $x"] -row 0 -column 1 -padx 5 -pady 5
233
234     grid [label $con.rb_mlbl1 -text "Matrix"] -row 1 -column 0
235     grid [label $con.rb_mlbl2 -text "Multiplier"] -row 2 -column 0
236     grid [label $con.rb_mlbl3 -text "Damping Factor"] -row 3 -column 0
237     grid [button $con.plot -text "Plot Rigid Body" -command "PlotRBtype $x"] -row 4 -column 0
238
239     for {set a 1} {$a <= $::rb_matrix_num($x)} {incr a} {
240        grid [label $con.rb_mm$a   -text "$a"]                -row 1 -column $a
241        grid [label $con.rb_mult$a -text "$::rb_mult($x,$a)"] -row 2 -column $a
242        grid [label $con.rb_damp$a -text "$::rb_damp($x,$a)"] -row 3 -column $a
243     }
244
245     button $con.rb_vmatrix -text "Edit Matrix Info" -command "RB_View_Matrix $x"
246     grid   $con.rb_vmatrix -row 4 -column 1 -padx 5 -pady 5
247
248     foreach {top main side lbl} [MakeScrollTable $pane] {}
249     grid [label $main.rb_origin -text "Origin"] -row 0 -column 3 -columnspan 3
250     grid [label $main.rb_euler -text "Euler Angles"] -row 0 -column 6 -columnspan 3
251     grid [label $main.rb_ref -text "Refinement"] -row 1 -column 2
252     grid [label $main.rb_map -text "Map"] -row 1 -column 1
253     grid [label $main.rb_x   -text "x"] -row 1 -column 3
254     grid [label $main.rb_y   -text "y"] -row 1 -column 4
255     grid [label $main.rb_z   -text "z"] -row 1 -column 5
256     grid [label $main.rb_euler_x -text "x"] -row 1 -column 6
257     grid [label $main.rb_euler_y -text "y"] -row 1 -column 7
258     grid [label $main.rb_euler_z -text "z"] -row 1 -column 8
259     grid [label $main.rb_opt     -text "TLS Controls"] -row 1 -column 9 -columnspan 2
260
261     set col 11
262     set y $::rb_matrix_num($x)
263     for {set z 1} {$z <= $::rb_coord_num($x,$y)} {incr z} {
264        label $main.rb_site$z -text "site $z"
265        grid $main.rb_site$z -row 1 -column $col
266        incr col
267     }
268
269     set row 2
270     foreach p $phase {
271             incr row
272             set count [RigidBodyMappingCount $p $x]
273             for {set z 1} {$z <= $count} {incr z} {
274                      set row [expr $row + $z]
275                      RB_Load_Mapdata $p $x $z
276                      grid [label $main.rb_map$p$z -text "$z"] -row $row -column 1
277                      grid [button $main.rb_cb$p$z -text "off" -command "RB_View_Parameters $p $x $z"] -row $row -column 2
278                      set origin $::rb_map_origin($p,$x,$z)
279                      puts $origin
280                      grid [label $main.rb_x$p$z   -text [lindex $origin 0]] -row $row -column 3
281                      grid [label $main.rb_y$p$z   -text [lindex $origin 1]] -row $row -column 4
282                      grid [label $main.rb_z$p$z   -text [lindex $origin 2]] -row $row -column 5
283                      set euler $::rb_map_euler($p,$x,$z)
284                      for {set j 0} {$j < 3} {incr j} {
285                                  set euler1 [lindex $euler $j]
286                                  set angle  [lindex $euler1 0]
287                                  set axis   [lindex $euler1 1]
288                                  label $main.rb_euler_$p$z$axis -text $angle
289                      }
290                      grid [button $main.rb_tls$p$z -text "off" -width 7] -row $row -column 9
291                      set q 1
292                      grid $main.rb_euler_$p$z$q -row $row -column 6
293                      set q 2
294                      grid $main.rb_euler_$p$z$q -row $row -column 7
295                      set q 3
296                      grid $main.rb_euler_$p$z$q -row $row -column 8
297                      set col 11
298                      set atomnum $::rb_map_beginning($p,$x,$z)
299                      for {set j 1} {$j <=$::rb_coord_num($x,$y)} {incr j} {
300                          set atom [atominfo $p $atomnum type]
301                          grid [label $main.rb_site$p$z$j -text "$atom"] -row $row -column $col
302                          incr atomnum
303                          incr col
304                      }
305             }
306     incr row
307     }
308
309     ResizeScrollTable $pane
310}
311
312proc RB_Choose_Atom {phase args} {
313#     set ::rb_finput ""
314     catch {destroy .chooseatom}
315     set ca .chooseatom
316     toplevel $ca
317     wm title $ca "Choose Atom"
318     set atomlist $::expmap(atomlist_$phase)
319#     puts $atomlist
320     foreach {top main side lbl} [MakeScrollTable $ca] {}
321     set row 0
322     set column 0
323     foreach atom $atomlist {
324        set label "[atominfo $phase $atom label] \($atom\)"
325# fix next line need global variable to send.
326#        button $main.$atom -text "$label" -command "set ::rb_finput [list $label]; destroy $ca"
327        button $main.$atom -text $label -command "set ::rb_finput $atom; destroy $ca"
328        incr row
329        if {$row > 5} {
330           set row 1
331           incr column
332        }
333      grid $main.$atom -row $row -column $column -padx 5 -pady 5
334      }
335      ResizeScrollTable $ca
336      putontop $ca
337      tkwait window $ca
338      afterputontop
339}
340
341
342proc RB_Map_New {x args} {
343    catch {unset ::rb_finput}
344    set ::rb_finput ""
345    set ::body_type $x
346    catch {destroy .newmap}
347    set nm .newmap
348    toplevel $nm
349    wm title $nm "Rigid Body Mapping"
350    set ::phase 1
351    set nmap [expr $::rb_map($x) + 1]
352    eval tk_optionMenu $nm.pinput ::rb_phase $::expmap(phaselist)
353
354    grid [label $nm.phase -text "Phase: "] -row 3 -column 1
355    grid [label $nm.f_atom -text "Choose first atom Number"] -row 4 -column 1
356    grid [label $nm.origin -text "input origin in fractional coordinates: "] -row 6 -column 1
357    grid [label $nm.euler -text "input Euler angles: "] -row 7 -column 1
358
359
360    grid [entry $nm.finputm -textvariable ::rb_finput -width 8 -takefocus 1] -row 4 -column 2
361
362    foreach item [trace vinfo ::rb_finput] {
363            eval trace vdelete ::rb_finput $item
364    }
365    trace variable ::rb_finput w "RB_Atom_List \$::rb_phase \$::rb_finput $nm $x 1"
366
367    grid [button $nm.finput -text "list atoms" -command {RB_Choose_Atom $::rb_phase}] -row 4 -column 3
368    grid [label $nm.o1l -text "x"] -row 5 -column 2
369    grid [label $nm.o2l -text "y"] -row 5 -column 3
370    grid [label $nm.o3l -text "z"] -row 5 -column 4
371    grid [entry $nm.o1 -width 8 -textvariable ::origin1 -takefocus 1] -row 6 -column 2
372    grid [entry $nm.o2 -width 8 -textvariable ::origin2 -takefocus 1] -row 6 -column 3
373    grid [entry $nm.o3 -width 8 -textvariable ::origin3 -takefocus 1] -row 6 -column 4
374    grid [entry $nm.e1 -width 8 -textvariable ::euler1 -takefocus 1] -row 7 -column 2
375    grid [entry $nm.e2 -width 8 -textvariable ::euler2 -takefocus 1] -row 7 -column 3
376    grid [entry $nm.e3 -width 8 -textvariable ::euler3 -takefocus 1] -row 7 -column 4
377
378    grid $nm.pinput -row 3 -column 3
379
380
381
382    grid [button $nm.plot -text "Plot Rigid Body & Phase" -command "PlotStrBody $x"] -row 8 -column 2 -columnspan 3
383    button $nm.save -text "Save" -width 6 -command {RB_Write_Map}
384
385
386    grid $nm.save -row 9 -column 3
387}
388
389proc PlotStrBody {rbtype} {
390     set Euler [list "1 $::euler1" "2 $::euler2" "3 $::euler3"]
391     set origin "$::origin1 $::origin2 $::origin3"
392     set phase $::rb_phase
393     set cell {}
394     foreach p {a b c alpha beta gamma} {
395        lappend cell [phaseinfo $phase $p]
396    }
397    set coords [RB2cart [lindex [ReadRigidBody $rbtype] 1]]
398    set frcoords [CalcBody $Euler $cell $coords $origin]
399    #puts "CalcBody $Euler $cell $coords $origin"
400    #puts $coords
401    #puts $frcoords
402    DRAWxtlPlotRBFit $frcoords $phase $::rb_finput 0
403 }
404#
405
406proc RB_Write_Map {args} {
407   set origin "$::origin1 $::origin2 $::origin3"
408   set euler "$::euler1 $::euler2 $::euler3"
409   puts "phase = $::rb_phase"
410   puts "bodytyp = $::body_type"
411   puts "firstatom = $::rb_finput"
412   puts "position = $origin"
413   puts "Euler = $euler"
414   MapRigidBody $::rb_phase $::body_type $::rb_finput $origin $euler
415   incr ::rb_map($::body_type)
416   RB_Control_Panel $::body_type
417   destroy .newmap
418}
419
420proc RB_Atom_List {phase atomnum address x y args} {
421     foreach w [winfo children $address] {
422             if {[string first ".atom" $w] != -1} {destroy $w}
423     }
424     set col 8
425     grid [label $address.atomlbl -text "Atoms Mapped to Rigid Body"] -row 3 -column 8 -columnspan $::rb_coord_num($x,$y)
426     for {set j 1} {$j <=$::rb_coord_num($x,$y)} {incr j} {
427         set atom [atominfo $phase $atomnum type]
428         grid [label $address.atom$phase$x$j -text "$atom"] -row 4 -column $col
429         incr atomnum
430         incr col
431     }
432}
433
434
435RB_Load_RBdata
436RB_Control_Panel 1
Note: See TracBrowser for help on using the repository browser.