Changeset 540
 Timestamp:
 Dec 4, 2009 5:07:53 PM (11 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/widplt
 Property rcs:date changed from 2000/12/22 19:44:07 to 2002/01/22 22:45:19
 Property rcs:lines changed from +4 4 to +622 311
 Property rcs:rev changed from 1.8 to 1.9
r363 r540 9 9 } 10 10 } 11 set program [file tail $argv0] 12 11 13 if [catch {package require BLT} errmsg] { 12 14 tk_dialog .err "BLT Error" "Error  Unable to load the BLT package" \ … … 55 57 if {$expnam != ""} {waitmsg "Loading $expnam, Please wait"} 56 58 57 # get profile information out from aEXP file59 # get profile/absorption information out from an EXP file 58 60 proc getprofiles {expnam} { 59 global datalist wave XY UVWP lblarr ttrange61 global WidSetList absSetList wave XY UVWP lblarr ttrange 60 62 61 63 if {[expload $expnam] == 1} { … … 71 73 set lambda1 [histinfo $hist lam1] 72 74 # data range 73 set drange [readexp "HST $hist TRNGE"] 74 foreach phase $expmap(phaselist_$hist) { 75 set ptype [hapinfo $hist $phase proftype] 76 set pterms [hapinfo $hist $phase profterms] 77 set key "H${hist}P${phase}" 78 # make sure the key is not present already 79 if {[lsearch $datalist $key] == 1} { 80 lappend datalist $key 75 set drange [string trim [readexp "HST $hist TRNGE"]] 76 global program 77 if {$program == "absplt"} { 78 global ABS 79 set ABS($hist) [list \ 80 [histinfo $hist abscor1] \ 81 [histinfo $hist abscor2] \ 82 [histinfo $hist abstype] \ 83 $drange \ 84 "Hist $hist" \ 85 $expmap(htype_$hist)] 86 lappend absSetList $hist 87 } else { 88 foreach phase $expmap(phaselist_$hist) { 89 set ptype [hapinfo $hist $phase proftype] 90 set pterms [hapinfo $hist $phase profterms] 91 set key "H${hist}P${phase}" 92 # make sure the key is not present already 93 if {[lsearch $WidSetList $key] == 1} { 94 lappend WidSetList $key 95 } 96 set lblarr($key) "Histogram $hist Phase $phase" 97 set wave($key) $lambda1 98 set ttrange($key) $drange 99 if {$ptype == 1} { 100 set UVWP($key) [list [hapinfo $hist $phase pterm1] \ 101 [hapinfo $hist $phase pterm2] \ 102 [hapinfo $hist $phase pterm3] 0] 103 set XY($key) {0 0} 104 } elseif {$ptype == 2} { 105 set UVWP($key) [list [hapinfo $hist $phase pterm1] \ 106 [hapinfo $hist $phase pterm2] \ 107 [hapinfo $hist $phase pterm3] \ 108 [hapinfo $hist $phase pterm9]] 109 set XY($key) [list [hapinfo $hist $phase pterm4] \ 110 [hapinfo $hist $phase pterm5]] 111 } elseif {$ptype == 3  $ptype == 4} { 112 set UVWP($key) [list [hapinfo $hist $phase pterm1] \ 113 [hapinfo $hist $phase pterm2] \ 114 [hapinfo $hist $phase pterm3] \ 115 [hapinfo $hist $phase pterm4]] 116 if {$ptype == 3} { 117 set XY($key) [list [hapinfo $hist $phase pterm5] \ 118 [hapinfo $hist $phase pterm6]] 119 } else { 120 set XY($key) [list [hapinfo $hist $phase pterm5] 0] 121 } 122 } 81 123 } 82 set lblarr($key) "Histogram $hist Phase $phase" 83 set wave($key) $lambda1 84 set ttrange($key) $drange 85 if {$ptype == 1} { 86 set UVWP($key) "[hapinfo $hist $phase pterm1] [hapinfo $hist $phase pterm2] [hapinfo $hist $phase pterm3] 0" 87 set XY($key) {0 0} 88 } elseif {$ptype == 2} { 89 set UVWP($key) "[hapinfo $hist $phase pterm1] [hapinfo $hist $phase pterm2] [hapinfo $hist $phase pterm3] [hapinfo $hist $phase pterm9]" 90 set XY($key) "[hapinfo $hist $phase pterm4] [hapinfo $hist $phase pterm5]" 91 } elseif {$ptype == 3  $ptype == 4} { 92 set UVWP($key) "[hapinfo $hist $phase pterm1] [hapinfo $hist $phase pterm2] [hapinfo $hist $phase pterm3] [hapinfo $hist $phase pterm4]" 93 set XY($key) "[hapinfo $hist $phase pterm5] [hapinfo $hist $phase pterm6]" 94 } 95 } 96 } 124 } 125 } 126 MakeCascadeMenus 97 127 } 98 128 … … 196 226 GSAS\n\ 197 227 A. C. Larson and\n R. B. Von Dreele,\n LANSCE, Los Alamos\n\n\ 198 WIDPLT \nB. Toby, NIST\nNot subject to copyright\n\n\228 WIDPLT/ABSPLT\nB. Toby, NIST\nNot subject to copyright\n\n\ 199 229 $Revision\n\ 200 230 " {} 0 OK … … 206 236 } 207 237 208 proc newmenu{} {238 proc NewProfileValues {} { 209 239 global newmenu datanum 210 240 incr datanum 211 set base . new241 set base .edit 212 242 catch {destroy $base} 213 243 toplevel $base … … 215 245 grab $base 216 246 wm title $base {Enter a new profile} 217 label $base.label#7 text Gaussian 218 label $base.label#8 text Lorentz 219 label $base.label#1 text U 220 label $base.label#2 text V 221 label $base.label#3 text W 222 label $base.label#4 text P 223 label $base.label#5 text X 224 label $base.label#6 text Y 225 entry $base.entry#1 textvariable newmenu(U) width 8 226 entry $base.entry#2 textvariable newmenu(V) width 8 227 entry $base.entry#3 textvariable newmenu(W) width 8 228 entry $base.entry#4 textvariable newmenu(P) width 8 229 entry $base.entry#5 textvariable newmenu(X) width 8 230 entry $base.entry#6 textvariable newmenu(Y) width 8 231 232 label $base.label#9 text label 233 entry $base.entry#7 textvariable newmenu(label) 234 235 label $base.label#11 text {2Theta Min} 236 entry $base.entry#9 textvariable newmenu(min) width 6 237 label $base.label#12 text {2Theta Max} 238 entry $base.entry#10 textvariable newmenu(max) width 6 239 240 label $base.label#13 text Wavelength 241 242 entry $base.entry#11 textvariable newmenu(wave) width 8 243 244 button $base.button#1 text Add command "addopt; destroy $base" 245 button $base.button#2 text Quit command "destroy $base" 246 247 # Geometry management 248 249 grid $base.label#7 in $base row 2 column 1 columnspan 4 250 grid $base.label#8 in $base row 2 column 6 columnspan 2 251 grid $base.label#1 in $base row 3 column 1 252 grid $base.label#2 in $base row 3 column 2 253 grid $base.label#3 in $base row 3 column 3 254 grid $base.label#4 in $base row 3 column 4 255 grid $base.label#5 in $base row 3 column 6 256 grid $base.label#6 in $base row 3 column 7 257 grid $base.entry#1 in $base row 4 column 1 258 grid $base.entry#2 in $base row 4 column 2 259 grid $base.entry#3 in $base row 4 column 3 260 grid $base.entry#4 in $base row 4 column 4 261 grid $base.entry#5 in $base row 4 column 6 262 grid $base.entry#6 in $base row 4 column 7 263 grid $base.label#9 in $base row 5 column 1 264 grid $base.entry#7 in $base row 5 column 2 columnspan 3 265 grid $base.label#13 in $base row 5 column 5 columnspan 2 266 grid $base.entry#11 in $base row 5 column 7 267 grid $base.label#11 in $base row 6 column 1 268 grid $base.entry#9 in $base row 6 column 2 269 grid $base.label#12 in $base row 6 column 3 270 grid $base.entry#10 in $base row 6 column 4 271 grid $base.button#1 in $base row 6 column 6 272 grid $base.button#2 in $base row 6 column 7 273 274 # Resize behavior management 275 276 grid rowconfigure $base 2 weight 1 minsize 17 277 grid rowconfigure $base 3 weight 0 minsize 19 278 grid rowconfigure $base 4 weight 0 minsize 30 279 grid rowconfigure $base 5 weight 0 minsize 30 280 grid rowconfigure $base 6 weight 0 minsize 30 281 grid columnconfigure $base 1 weight 0 minsize 26 282 grid columnconfigure $base 2 weight 0 minsize 30 283 grid columnconfigure $base 3 weight 0 minsize 30 284 grid columnconfigure $base 4 weight 0 minsize 65 285 grid columnconfigure $base 5 weight 1 minsize 26 286 grid columnconfigure $base 6 weight 0 minsize 30 287 grid columnconfigure $base 7 weight 0 minsize 30 247 MakeEditProfileBox $base 248 grid [button $base.bttn1 text Add \ 249 command "AddProfileValues; destroy $base"] row 6 column 6 250 grid [button $base.bttn2 text Quit \ 251 command "destroy $base"] row 6 column 7 288 252 set newmenu(U) 0 289 253 set newmenu(V) 0 … … 298 262 } 299 263 300 proc addopt{} {301 global newmenu datanum lblarr display UVWP XY datalist ttrange wave264 proc AddProfileValues {} { 265 global newmenu datanum lblarr WidDisplay UVWP XY WidSetList ttrange wave 302 266 set key new$datanum 303 267 set UVWP($key) [list $newmenu(U) $newmenu(V) $newmenu(W) $newmenu(P)] … … 306 270 set ttrange($key) "$newmenu(min) $newmenu(max)" 307 271 set wave($key) $newmenu(wave) 308 lappend datalist $key309 .a.plot.menu add checkbutton label $lblarr($key) \310 command {plotdata $box} variable display($key) 311 } 312 313 proc editmenu {} { 314 global newmenu datalist lblarr 272 lappend WidSetList $key 273 MakeCascadeMenus 274 } 275 276 proc editProfileValues {key} { 277 global newmenu WidSetList lblarr 278 315 279 set base .edit 316 280 catch {destroy $base} 317 281 toplevel $base 318 focus $base319 grab $base320 282 wm title $base {Edit a profile} 321 label $base.label#7 text Gaussian 322 label $base.label#8 text Lorentz 323 label $base.label#1 text U 324 label $base.label#2 text V 325 label $base.label#3 text W 326 label $base.label#4 text P 327 label $base.label#5 text X 328 label $base.label#6 text Y 329 entry $base.entry#1 textvariable newmenu(U) width 8 330 entry $base.entry#2 textvariable newmenu(V) width 8 331 entry $base.entry#3 textvariable newmenu(W) width 8 332 entry $base.entry#4 textvariable newmenu(P) width 8 333 entry $base.entry#5 textvariable newmenu(X) width 8 334 entry $base.entry#6 textvariable newmenu(Y) width 8 335 336 label $base.label#9 text {Select an option} 337 set llist {} 338 foreach item $datalist {lappend llist $lblarr($item)} 339 eval tk_optionMenu $base.entry#7 newmenu(opt) $llist 340 341 label $base.label#11 text {2Theta Min} 342 entry $base.entry#9 textvariable newmenu(min) width 6 343 label $base.label#12 text {2Theta Max} 344 entry $base.entry#10 textvariable newmenu(max) width 6 345 346 label $base.label#13 text Wavelength 347 348 entry $base.entry#11 textvariable newmenu(wave) width 8 349 350 button $base.button#1 text Save command "saveopt" 351 button $base.button#2 text Quit command "destroy $base" 352 353 # Geometry management 354 355 grid $base.label#9 in $base row 1 column 1 columnspan 2 \ 356 sticky e 357 grid $base.entry#7 in $base row 1 column 3 columnspan 3 \ 358 sticky w 359 grid $base.label#7 in $base row 2 column 1 columnspan 4 360 grid $base.label#8 in $base row 2 column 6 columnspan 2 361 grid $base.label#1 in $base row 3 column 1 362 grid $base.label#2 in $base row 3 column 2 363 grid $base.label#3 in $base row 3 column 3 364 grid $base.label#4 in $base row 3 column 4 365 grid $base.label#5 in $base row 3 column 6 366 grid $base.label#6 in $base row 3 column 7 367 grid $base.entry#1 in $base row 4 column 1 368 grid $base.entry#2 in $base row 4 column 2 369 grid $base.entry#3 in $base row 4 column 3 370 grid $base.entry#4 in $base row 4 column 4 371 grid $base.entry#5 in $base row 4 column 6 372 grid $base.entry#6 in $base row 4 column 7 373 grid $base.label#13 in $base row 5 column 5 columnspan 2 374 grid $base.entry#11 in $base row 5 column 7 375 grid $base.label#11 in $base row 6 column 1 376 grid $base.entry#9 in $base row 6 column 2 377 grid $base.label#12 in $base row 6 column 3 378 grid $base.entry#10 in $base row 6 column 4 379 grid $base.button#1 in $base row 6 column 6 380 grid $base.button#2 in $base row 6 column 7 381 382 # Resize behavior management 383 384 grid rowconfigure $base 1 weight 0 minsize 30 385 grid rowconfigure $base 2 weight 1 minsize 17 386 grid rowconfigure $base 3 weight 0 minsize 19 387 grid rowconfigure $base 4 weight 0 minsize 30 388 grid rowconfigure $base 5 weight 0 minsize 30 389 grid rowconfigure $base 6 weight 0 minsize 30 390 grid columnconfigure $base 1 weight 0 minsize 26 391 grid columnconfigure $base 2 weight 0 minsize 30 392 grid columnconfigure $base 3 weight 0 minsize 30 393 grid columnconfigure $base 4 weight 0 minsize 65 394 grid columnconfigure $base 5 weight 1 minsize 26 395 grid columnconfigure $base 6 weight 0 minsize 30 396 grid columnconfigure $base 7 weight 0 minsize 30 397 set newmenu(U) {} 398 set newmenu(V) {} 399 set newmenu(W) {} 400 set newmenu(P) {} 401 set newmenu(X) {} 402 set newmenu(Y) {} 403 set newmenu(min) {} 404 set newmenu(max) {} 405 set newmenu(label) {} 406 set newmenu(wave) {} 407 set newmenu(opt) {} 408 } 409 410 proc saveopt {} { 411 global newmenu datanum lblarr display UVWP XY datalist ttrange wave box 412 set key {} 413 foreach item $datalist { 414 if {$lblarr($item) == $newmenu(opt)} {set key $item; break} 415 } 416 if {$key == ""} return 417 set UVWP($key) [list $newmenu(U) $newmenu(V) $newmenu(W) $newmenu(P)] 418 set XY($key) [list $newmenu(X) $newmenu(Y)] 419 set ttrange($key) "$newmenu(min) $newmenu(max)" 420 set wave($key) $newmenu(wave) 421 plotdata $box 422 } 423 424 proc loadopt {a1 a2 a3} { 425 global newmenu lblarr display UVWP XY datalist ttrange newmenu wave 426 set key {} 427 foreach item $datalist { 428 if {$lblarr($item) == $newmenu(opt)} {set key $item; break} 429 } 430 if {$key == ""} return 283 MakeEditProfileBox $base 284 grid [button $base.bttn1 text Apply \ 285 command "SaveProfileEdits $key"] row 6 column 6 286 grid [button $base.bttn2 text Close \ 287 command "destroy $base"] row 6 column 7 288 289 global UVWP XY ttrange wave lblarr 290 set newmenu(label) $lblarr($key) 431 291 set newmenu(U) [lindex $UVWP($key) 0] 432 292 set newmenu(V) [lindex $UVWP($key) 1] … … 440 300 } 441 301 302 proc SaveProfileEdits {key} { 303 global newmenu datanum lblarr WidDisplay UVWP XY WidSetList ttrange wave box 304 set UVWP($key) [list $newmenu(U) $newmenu(V) $newmenu(W) $newmenu(P)] 305 set XY($key) [list $newmenu(X) $newmenu(Y)] 306 set ttrange($key) [list $newmenu(min) $newmenu(max)] 307 set wave($key) $newmenu(wave) 308 set lblarr($key) $newmenu(label) 309 MakeCascadeMenus 310 plotdata $box 311 } 312 313 proc MakeEditProfileBox {base} { 314 grid [label $base.lb7 text Gaussian] row 2 column 1 columnspan 4 315 grid [label $base.lb8 text Lorentz] row 2 column 6 columnspan 2 316 grid [label $base.lb1 text U] row 3 column 1 317 grid [label $base.lb2 text V] row 3 column 2 318 grid [label $base.lb3 text W] row 3 column 3 319 grid [label $base.lb4 text P] row 3 column 4 320 grid [label $base.lb5 text X] row 3 column 6 321 grid [label $base.lb6 text Y] row 3 column 7 322 grid [entry $base.ent1 textvariable newmenu(U) width 12] \ 323 row 4 column 1 324 grid [entry $base.ent2 textvariable newmenu(V) width 12] \ 325 row 4 column 2 326 grid [entry $base.ent3 textvariable newmenu(W) width 12] \ 327 row 4 column 3 328 grid [entry $base.ent4 textvariable newmenu(P) width 12] \ 329 row 4 column 4 330 grid [entry $base.ent5 textvariable newmenu(X) width 12] \ 331 row 4 column 6 332 grid [entry $base.ent6 textvariable newmenu(Y) width 12] \ 333 row 4 column 7 334 335 grid [label $base.lb9 text label] row 5 column 1 sticky e 336 grid [entry $base.ent7 textvariable newmenu(label)]\ 337 row 5 column 2 columnspan 3 sticky ew 338 339 grid [label $base.lb13 text Wavelength] row 5 column 5 columnspan 2 340 grid [entry $base.ent11 textvariable newmenu(wave) width 8] \ 341 row 5 column 7 342 343 grid [label $base.lb11 text {2Theta Min}] row 6 column 1 344 grid [entry $base.ent9 textvariable newmenu(min) width 9] \ 345 row 6 column 2 346 grid [label $base.lb12 text {2Theta Max}] row 6 column 3 347 grid [entry $base.ent10 textvariable newmenu(max) width 9] \ 348 row 6 column 4 349 grid rowconfigure $base 5 weight 0 pad 40 350 grid columnconfigure $base 5 weight 0 minsize 25 351 } 352 353 proc editAbsValues {key} { 354 global newmenu absSetList lblarr 355 356 set base .edit 357 catch {destroy $base} 358 toplevel $base 359 wm title $base {Edit Absorption Values} 360 MakeEditAbsBox $base 361 grid [button $base.bttn1 text Apply \ 362 command "SaveAbsorptionEdits $key"] row 8 column 6 363 grid [button $base.bttn2 text Close \ 364 command "destroy $base"] row 8 column 7 365 366 global ABS 367 foreach v {1 2 opt range label htype} val $ABS($key) { 368 set newmenu($v) $val 369 } 370 foreach {newmenu(min) newmenu(max)} $newmenu(range) {} 371 if {[string range $newmenu(htype) 2 2] == "T"} { 372 set newmenu(units) "TOF (ms):" 373 } elseif {[string range $newmenu(htype) 2 2] == "C"} { 374 set newmenu(units) "2Theta (deg):" 375 } elseif {[string range $newmenu(htype) 2 2] == "E"} { 376 set newmenu(units) "Energy (KeV):" 377 } 378 } 379 380 proc SaveAbsorptionEdits {key} { 381 global ABS newmenu 382 set ABS($key) [list \ 383 $newmenu(1) $newmenu(2) $newmenu(opt) \ 384 [list $newmenu(min) $newmenu(max)] \ 385 $newmenu(label) \ 386 [lindex $ABS($key) 5]] 387 } 388 389 proc MakeEditAbsBox {base} { 390 grid [label $base.lb1 text "Absorption Coefficients"] \ 391 row 2 column 1 columnspan 2 392 grid [label $base.lb1a text "1"] row 3 column 1 393 grid [label $base.lb2a text "2"] row 3 column 2 394 grid [label $base.lb3 text Absorption] row 2 column 6 columnspan 2 395 grid [label $base.lb3a text Function] row 3 column 6 columnspan 2 396 grid [entry $base.ent1 textvariable newmenu(1) width 12] \ 397 row 4 column 1 398 grid [entry $base.ent2 textvariable newmenu(2) width 12] \ 399 row 4 column 2 400 eval tk_optionMenu $base.m1 newmenu(opt) 0 1 2 3 4 401 grid $base.m1 row 4 column 6 columnspan 2 402 403 grid [label $base.lb8 textvariable newmenu(opttxt) \ 404 wrap 180 justify left] row 5 column 1 sticky e columnspan 7 405 grid [label $base.lb9 text label] row 7 column 1 sticky e 406 grid [entry $base.ent7 textvariable newmenu(label)]\ 407 row 7 column 2 columnspan 3 sticky ew 408 409 grid [frame $base.f] row 8 column 1 columnspan 4 410 grid [label $base.f.1 textvariable newmenu(units)] row 0 column 1 411 grid [label $base.f.2 text {Min}] row 0 column 2 412 grid [entry $base.f.3 textvariable newmenu(min) width 9] \ 413 row 0 column 3 414 grid [label $base.f.4 text {Max}] row 0 column 4 415 grid [entry $base.f.5 textvariable newmenu(max) width 9] \ 416 row 0 column 5 417 grid rowconfigure $base 6 min 15 418 } 419 442 420 proc plotdata {top} { 443 global UVWP XY wave lblarr datalist display \ 444 graph ttrange 421 global program graph 422 global UVWP XY wave lblarr WidSetList WidDisplay ttrange 423 global ABS absSetList AbsDisplay 445 424 if {$graph(plotunits) == "d"} { 446 425 $top xaxis configure title "d (A)" … … 452 431 $top xaxis configure title "2Theta @ $graph(equivwave)" 453 432 } 433 if {$program == "absplt"} { 434 $top yaxis config title {Abs. Corr.} 435 } else { 436 $top yaxis config title {FWHM} 437 } 454 438 $top yaxis configure min 0 455 439 $top xaxis configure min 0 … … 457 441 eval $top element delete [$top element names] 458 442 set num 1 459 foreach item $datalist { 460 if {$display($item)} { 461 if {[expr [lindex $XY($item) 0] + [lindex $XY($item) 1]] != 0} { 462 set lflag 1 463 } else { 464 set lflag 0 443 if {$program == "absplt"} { 444 foreach item $absSetList { 445 if {$AbsDisplay($item)} { 446 set ttlist {} 447 set abscor1 [lindex $ABS($item) 0] 448 set abscor2 [lindex $ABS($item) 1] 449 set abstype [lindex $ABS($item) 2] 450 set abslbl [lindex $ABS($item) 4] 451 set htype [lindex $ABS($item) 5] 452 set ttmin [lindex [lindex $ABS($item) 3] 0] 453 set ttmax [lindex [lindex $ABS($item) 3] 1] 454 set ttstep [expr {($ttmax  $ttmin)/50.}] 455 if {$graph(equivwave) == ""} { 456 if {[string range $htype 2 2] == "T"} { 457 $top xaxis configure title "TOF (ms)" 458 } elseif {[string range $htype 2 2] == "E"} { 459 $top xaxis configure title "Energy (KeV)" 460 } 461 } 462 for {set tt $ttmin} \ 463 {$tt <= $ttmax} \ 464 {set tt [expr {$tt + $ttstep}]} { 465 catch { 466 lappend abslist [AbsorbCalc \ 467 $item $tt $abscor1 $abscor2 $abstype] 468 lappend ttlist $tt 469 } 470 } 471 if {[llength $ttlist] == 0} continue 472 if {$graph(plotunits) == "d"} { 473 set ttlist [tod $ttlist $item] 474 } elseif {$graph(plotunits) == "q"} { 475 set ttlist [toQ $ttlist $item] 476 } 477 catch { 478 $top element create $item 479 } 480 $top element config $item label $abslbl \ 481 xdata $ttlist ydata $abslist linewidth 3 \ 482 color [nextcolor num] 465 483 } 466 set ttlist {} 467 set fwhmlist {} 468 set lfwhmlist {} 469 set tfwhmlist {} 470 # loop over twotheta 471 for {set tt [lindex $ttrange($item) 0]} \ 472 {$tt <= [lindex $ttrange($item) 1]} \ 473 {set tt [expr $tt + 4]} { 474 set lfwhm 0 475 catch { 476 if {$graph(plotunits) == "d"} { 477 lappend ttlist [tt2d $wave($item) $tt ] 478 set gfwhm [deltad $wave($item) $tt \ 479 [eval FWHM $tt $UVWP($item)]] 480 lappend fwhmlist $gfwhm 481 if $lflag { 482 set lfwhm [deltad $wave($item) $tt \ 483 [eval LFWHM $tt $XY($item)]] 484 lappend lfwhmlist $lfwhm 485 } 486 } elseif {$graph(plotunits) == "q"} { 487 lappend ttlist [tt2Q $wave($item) $tt ] 488 set gfwhm [deltaQ $wave($item) $tt \ 489 [eval FWHM $tt $UVWP($item)]] 490 lappend fwhmlist $gfwhm 491 if $lflag { 492 set lfwhm [deltaQ $wave($item) $tt \ 493 [eval LFWHM $tt $XY($item)]] 494 lappend lfwhmlist $lfwhm 495 } 496 } elseif {$graph(equivwave) == ""} { 497 lappend ttlist $tt 498 set gfwhm [eval FWHM $tt $UVWP($item)] 499 lappend fwhmlist $gfwhm 500 if $lflag { 501 set lfwhm [eval LFWHM $tt $XY($item)] 502 lappend lfwhmlist $lfwhm 503 } 504 } else { 505 set tteq [ttequiv $wave($item) $tt $graph(equivwave)] 506 if {$tteq != ""} { 507 lappend ttlist $tteq 508 set gfwhm [delta2teq $wave($item) $tt \ 509 [eval FWHM $tt $UVWP($item)] $graph(equivwave)] 484 } 485 } else { 486 foreach item $WidSetList { 487 if {$WidDisplay($item)} { 488 if {[expr [lindex $XY($item) 0] + [lindex $XY($item) 1]] != 0} { 489 set lflag 1 490 } else { 491 set lflag 0 492 } 493 set ttlist {} 494 set fwhmlist {} 495 set lfwhmlist {} 496 set tfwhmlist {} 497 # loop over twotheta 498 for {set tt [lindex $ttrange($item) 0]} \ 499 {$tt <= [lindex $ttrange($item) 1]} \ 500 {set tt [expr $tt + 4]} { 501 set lfwhm 0 502 catch { 503 if {$graph(plotunits) == "d"} { 504 lappend ttlist [tt2d $wave($item) $tt ] 505 set gfwhm [deltad $wave($item) $tt \ 506 [eval FWHM $tt $UVWP($item)]] 510 507 lappend fwhmlist $gfwhm 511 508 if $lflag { 512 set lfwhm [delta 2teq$wave($item) $tt \513 [eval LFWHM $tt $XY($item)] $graph(equivwave)]509 set lfwhm [deltad $wave($item) $tt \ 510 [eval LFWHM $tt $XY($item)]] 514 511 lappend lfwhmlist $lfwhm 515 512 } 513 } elseif {$graph(plotunits) == "q"} { 514 lappend ttlist [tt2Q $wave($item) $tt ] 515 set gfwhm [deltaQ $wave($item) $tt \ 516 [eval FWHM $tt $UVWP($item)]] 517 lappend fwhmlist $gfwhm 518 if $lflag { 519 set lfwhm [deltaQ $wave($item) $tt \ 520 [eval LFWHM $tt $XY($item)]] 521 lappend lfwhmlist $lfwhm 522 } 523 } elseif {$graph(equivwave) == ""} { 524 lappend ttlist $tt 525 set gfwhm [eval FWHM $tt $UVWP($item)] 526 lappend fwhmlist $gfwhm 527 if $lflag { 528 set lfwhm [eval LFWHM $tt $XY($item)] 529 lappend lfwhmlist $lfwhm 530 } 531 } else { 532 set tteq [ttequiv $wave($item) $tt $graph(equivwave)] 533 if {$tteq != ""} { 534 lappend ttlist $tteq 535 set gfwhm [delta2teq $wave($item) $tt \ 536 [eval FWHM $tt $UVWP($item)] $graph(equivwave)] 537 lappend fwhmlist $gfwhm 538 if $lflag { 539 set lfwhm [delta2teq $wave($item) $tt \ 540 [eval LFWHM $tt $XY($item)] $graph(equivwave)] 541 lappend lfwhmlist $lfwhm 542 } 543 } 516 544 } 545 # assume FWHM add as square roots 546 lappend tfwhmlist \ 547 [expr sqrt($gfwhm*$gfwhm + $lfwhm*$lfwhm)] 517 548 } 518 # assume FWHM add as square roots519 lappend tfwhmlist \520 [expr sqrt($gfwhm*$gfwhm + $lfwhm*$lfwhm)]521 549 } 522 } 523 if $lflag { 550 if $lflag { 551 catch { 552 $top element create ${item}G label "$lblarr($item) G" 553 } 554 $top element config ${item}G \ 555 xdata $ttlist ydata $fwhmlist linewidth 3 \ 556 color [nextcolor num] 557 catch { 558 $top element create ${item}L label "$lblarr($item) L" 559 } 560 $top element config ${item}L \ 561 xdata $ttlist ydata $lfwhmlist linewidth 3 \ 562 color [nextcolor num] 563 } 524 564 catch { 525 $top element create $ {item}G label "$lblarr($item) G"565 $top element create $item label $lblarr($item) 526 566 } 527 $top element config ${item}G \ 528 xdata $ttlist ydata $fwhmlist linewidth 3 \ 529 color [nextcolor num] 530 catch { 531 $top element create ${item}L label "$lblarr($item) L" 532 } 533 $top element config ${item}L \ 534 xdata $ttlist ydata $lfwhmlist linewidth 3 \ 567 $top element config $item \ 568 xdata $ttlist ydata $tfwhmlist linewidth 3 \ 535 569 color [nextcolor num] 536 570 } 537 catch { 538 $top element create $item label $lblarr($item) 571 } 572 } 573 } 574 proc AbsorbCalc {hst ttof abscor1 abscor2 mode} { 575 global expmap 576 set htype $expmap(htype_$hst) 577 set pi [expr {2.*acos(0.)}] 578 # determine sin(theta) & lambda 579 if {[string range $htype 2 2] == "T"} { 580 set sth [expr {sin($pi * abs([histinfo $hst tofangle])/360.)}] 581 set lamb [expr {2 * [toftod $ttof $hst] * $sth}] 582 } elseif {[string range $htype 2 2] == "C"} { 583 set lamb [histinfo $hst lam1] 584 set sth [expr {sin($pi * ($ttof  [histinfo $hst zero]/100.)/360.)}] 585 } elseif {[string range $htype 2 2] == "E"} { 586 set lamb [expr { 12.398 / $ttof}] 587 set sth [expr {sin($pi * [histinfo $hst lam1] / 360.)}] 588 } 589 set sth2 [expr $sth*$sth] 590 set cth2 [expr {1  $sth2}] 591 set cth [expr {sqrt($cth2)}] 592 593 if {$mode == 0} { 594 set murl [expr {$abscor1 * $lamb}]; # Lobanov & Alte da Veiga 595 if {$murl <= 3} { 596 set TERM0 [expr { 16.0/(3*$pi) }] 597 set TERM1 [expr { (25.999780.01911*pow($sth2,0.25)) * \ 598 exp(0.024551*$sth2) + 0.109561*sqrt($sth2)26.04556 }] 599 set TERM2 [expr {0.02489  0.39499*$sth2 + \ 600 1.219077*pow($sth2,1.5)  1.31268*pow($sth2,2) + \ 601 0.871081*pow($sth2,2.5)  0.2327*pow($sth2,3) }] 602 set TERM3 [expr { 0.003045+0.018167*$sth2  0.03305*pow($sth2,2) }] 603 set TRANS [expr { $TERM0*$murl  $TERM1*pow($murl,2)  \ 604 $TERM2*pow($murl,3)  $TERM3*pow($murl,4) }] 605 if {$TRANS <= 20.0} { 606 set TRANS 2.06E9 607 } elseif {$TRANS >= 20.0} { 608 set TRANS 4.85E8 609 } else { 610 set TRANS [expr {exp($TRANS)}] 539 611 } 540 $top element config $item \ 541 xdata $ttlist ydata $tfwhmlist linewidth 3 \ 542 color [nextcolor num] 543 } 544 } 612 } else { 613 set TERM1 [expr { 1.433902 + 11.07504*$sth2  \ 614 8.77629*pow($sth2,2) + 10.02088*pow($sth2,3)  \ 615 3.36778*pow($sth2,4) }] 616 set TERM2 [expr { (0.013869  0.01249*$sth2) * \ 617 exp(3.27094*$sth2) + \ 618 (0.337894 + 13.77317*$sth2) / \ 619 pow((1.0+11.53544*$sth2),1.555039) }] 620 set TERM3 [expr { 1.933433 / pow((1.0+23.12967*$sth2),1.686715)  \ 621 0.13576*sqrt($sth2) + 1.163198}] 622 set TERM4 [expr { 0.044365  0.4259 / \ 623 pow((1.0+0.41051*$sth2),148.4202) }] 624 set TRANS [expr { ($TERM1$TERM4) / \ 625 pow((1.0+$TERM2*($murl3.0)),$TERM3) + $TERM4 }] 626 set TRANS [expr { $TRANS/100.0}] 627 } 628 } elseif {$mode == 1} { 629 #!Simple linear absorption 630 set TRANS [expr { $abscor1*$lamb }] 631 set TRANS [expr { exp($TRANS) }] 632 } elseif {$mode == 2} { 633 #!Pitschke, Hermann & Muttern  surface roughness 634 set TERM1 [expr { 1.0/$sth$abscor2/$sth2 }] 635 set TERM2 [expr { 1.0$abscor1*(1.0+$abscor2) }] 636 set TRANS [expr { (1.0$abscor1*$TERM1)/$TERM2 }] 637 } elseif {$mode == 3} { 638 #!Suortti  surface roughness 639 set TERM1 [expr { exp($abscor2/$sth) }] 640 set TERM2 [expr { $abscor1 + (1.0$abscor1) * exp($abscor2) }] 641 set TRANS [expr { ($abscor1 +(1.0$abscor1) * $TERM1)/$TERM2 }] 642 } elseif {$mode == 4} { 643 #!Plate transmission absorption 644 if {abs($abscor2) < 1} { 645 #!Use symmetric fxn. if phi 1 deg or less 646 set TRANS [expr { $abscor1*$lamb/$cth }] 647 set TRANS [expr { exp($TRANS) }] 648 } else { 649 #!Bigger tilts 650 set SPH [expr { sin($pi/180. * $abscor2) }] 651 set CPH [expr { cos($pi/180. * $abscor2) }] 652 set CTPP [expr { $CPH*$cth  $SPH*$sth }] 653 set CTMP [expr { $CPH*$cth + $SPH*$sth }] 654 set T [expr { $abscor1*$lamb }] 655 set T1 [expr { $T / $CTPP }] 656 set TRANS1 [expr { exp($T1) }] 657 set T2 [expr { $T/$CTMP }] 658 set TRANS2 [expr { exp($T2) }] 659 set TB [expr { $T * (1.0  $CTMP / $CTPP) }] 660 set TRANS [expr { ($TRANS1  $TRANS2) / $TB }] 661 } 662 } 663 return $TRANS 545 664 } 546 665 … … 557 676 close $fp 558 677 } 678 679 proc MakeCascadeMenus {} { 680 global WidSetList lblarr box absSetList ABS 681 .a.plot.menu delete 0 end 682 .a.file.menu.edit delete 0 end 683 global program 684 if {$program != "absplt"} { 685 foreach item $WidSetList { 686 .a.plot.menu add checkbutton label $lblarr($item) \ 687 command "plotdata $box" variable WidDisplay($item) 688 .a.file.menu.edit add command label $lblarr($item) \ 689 command "editProfileValues $item" 690 } 691 } else { 692 foreach item $absSetList { 693 .a.plot.menu add checkbutton label [lindex $ABS($item) 4] \ 694 command "plotdata $box" variable AbsDisplay($item) 695 .a.file.menu.edit add command label [lindex $ABS($item) 4] \ 696 command "editAbsValues $item" 697 } 698 } 699 } 559 700 # 560 701 # converts 2theta(deg) to Q (A1) … … 616 757 return [expr [Q2tt $lambda_eq [tt2Q $lambda $twotheta+($FWHM/2.)]]  \ 617 758 [Q2tt $lambda_eq [tt2Q $lambda $twotheta($FWHM/2.)]] ] 759 } 760 761 # convert x values to dspace 762 proc tod {xlist hst} { 763 global expmap 764 if {[string range $expmap(htype_$hst) 2 2] == "T"} { 765 return [toftod $xlist $hst] 766 } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} { 767 return [tttod $xlist $hst] 768 } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} { 769 return [engtod $xlist $hst] 770 } else { 771 return {} 772 } 773 } 774 775 # convert tof to dspace 776 proc toftod {toflist hst} { 777 set difc [expr {[histinfo $hst difc]/1000.}] 778 set difc2 [expr {$difc*$difc}] 779 set difa [expr {[histinfo $hst difa]/1000.}] 780 set zero [expr {[histinfo $hst zero]/1000.}] 781 set ans {} 782 foreach tof $toflist { 783 if {$tof == 0.} { 784 lappend ans 0. 785 } elseif {$tof == 1000.} { 786 lappend ans 1000. 787 } else { 788 set td [expr {$tof$zero}] 789 lappend ans [expr {$td*($difc2+$difa*$td)/ \ 790 ($difc2*$difc+2.0*$difa*$td)}] 791 } 792 } 793 return $ans 794 } 795 796 # convert twotheta to dspace 797 proc tttod {twotheta hst} { 798 set lamo2 [expr {0.5 * [histinfo $hst lam1]}] 799 set zero [expr [histinfo $hst zero]/100.] 800 set ans {} 801 set cnv [expr {acos(0.)/180.}] 802 foreach tt $twotheta { 803 if {$tt == 0.} { 804 lappend ans 99999. 805 } elseif {$tt == 1000.} { 806 lappend ans 0. 807 } else { 808 lappend ans [expr {$lamo2 / sin($cnv*($tt$zero))}] 809 } 810 } 811 return $ans 812 } 813 814 # convert energy (edxray) to dspace 815 # (note that this ignores the zero correction) 816 proc engtod {eng hst} { 817 set lam [histinfo $hst lam1] 818 set zero [histinfo $hst zero] 819 set ans {} 820 set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}] 821 foreach e $eng { 822 if {$e == 0.} { 823 lappend ans 1000. 824 } elseif {$e == 1000.} { 825 lappend ans 0. 826 } else { 827 lappend ans [expr {$v/$e}] 828 } 829 } 830 return $ans 831 } 832 833 # convert x values to Q 834 proc toQ {xlist hst} { 835 global expmap 836 if {[string range $expmap(htype_$hst) 2 2] == "T"} { 837 return [toftoQ $xlist $hst] 838 } elseif {[string range $expmap(htype_$hst) 2 2] == "C"} { 839 return [tttoQ $xlist $hst] 840 } elseif {[string range $expmap(htype_$hst) 2 2] == "E"} { 841 return [engtoQ $xlist $hst] 842 } else { 843 return {} 844 } 845 } 846 # convert tof to Q 847 proc toftoQ {toflist hst} { 848 set difc [expr {[histinfo $hst difc]/1000.}] 849 set difc2 [expr {$difc*$difc}] 850 set difa [expr {[histinfo $hst difa]/1000.}] 851 set zero [expr {[histinfo $hst zero]/1000.}] 852 set 2pi [expr {4.*acos(0.)}] 853 set ans {} 854 foreach tof $toflist { 855 if {$tof == 0.} { 856 lappend ans 99999. 857 } elseif {$tof == 1000.} { 858 lappend ans 0. 859 } else { 860 set td [expr {$tof$zero}] 861 lappend ans [expr {$2pi * \ 862 ($difc2*$difc+2.0*$difa*$td)/($td*($difc2+$difa*$td))}] 863 } 864 } 865 return $ans 866 } 867 868 # convert twotheta to Q 869 proc tttoQ {twotheta hst} { 870 set lamo2 [expr {0.5 * [histinfo $hst lam1]}] 871 set zero [expr [histinfo $hst zero]/100.] 872 set ans {} 873 set cnv [expr {acos(0.)/180.}] 874 set 2pi [expr {4.*acos(0.)}] 875 foreach tt $twotheta { 876 if {$tt == 0.} { 877 lappend ans 0. 878 } elseif {$tt == 1000.} { 879 lappend ans 1000. 880 } else { 881 lappend ans [expr {$2pi * sin($cnv*($tt$zero)) / $lamo2}] 882 } 883 } 884 return $ans 885 } 886 # convert energy (edxray) to Q 887 # (note that this ignores the zero correction) 888 proc engtoQ {eng hst} { 889 set lam [histinfo $hst lam1] 890 set zero [histinfo $hst zero] 891 set ans {} 892 set v [expr {12.398/(2.0*[sind[expr ($lam/2.0)]])}] 893 set 2pi [expr {4.*acos(0.)}] 894 foreach e $eng { 895 if {$e == 0.} { 896 lappend ans 0. 897 } elseif {$e == 1000.} { 898 lappend ans 1000. 899 } else { 900 lappend ans [expr {$2pi * $e / $v}] 901 } 902 } 903 return $ans 904 } 905 proc sind {angle} { 906 return [expr {sin($angle*acos(0.)/90.)}] 618 907 } 619 908 … … 654 943 } 655 944 656 trace variable newmenu(opt) w loadopt657 658 945 set graph(legend) 0 659 946 set graph(equivwave) {} … … 666 953 set graph(outname) out.ps 667 954 set graph(outcmd) lpr 668 set datalist {} 955 set WidSetList {} 956 set absSetList {} 669 957 670 958 # … … 702 990 # 703 991 704 if {$expnam != ""} { 705 # OK now go get the profile info 706 getprofiles $expnam 707 } 708 709 # 992 set datalist {} 710 993 foreach file [glob nocomplain [file join $expgui(scriptdir) widplt_*]] { 711 994 source $file 712 995 } 996 set WidSetList $datalist 713 997 714 998 # create the graph … … 735 1019 } 736 1020 $box config title {} 737 $box yaxis config title {FWHM}738 1021 setlegend $box $graph(legend) 739 1022 … … 750 1033 command "getprofiles $expnam; plotdata $box" 751 1034 } 752 .a.file.menu add command label "Add New Curve" command newmenu 753 .a.file.menu add command label "Edit Curve" command editmenu 1035 if {$program == "absplt"} { 1036 .a.file.menu add cascade label "Edit Abs Params" menu .a.file.menu.edit 1037 } else { 1038 .a.file.menu add command label "Add New Curve" command NewProfileValues 1039 .a.file.menu add cascade label "Edit Curve" menu .a.file.menu.edit 1040 } 1041 menu .a.file.menu.edit 754 1042 .a.file.menu add command label "Make PostScript" command makepostscriptout 755 1043 .a.file.menu add command label Quit command "destroy ." … … 757 1045 side left 758 1046 menu .a.options.menu 759 .a.options.menu add radiobutton label "2Theta" value tt \ 760 variable graph(plotunits) \ 761 command "plotdata $box" 762 .a.options.menu add command label "Set Equiv. Wavelength" \ 763 command "seteqwave $box" 1047 if {$program == "absplt"} { 1048 .a.options.menu add radiobutton label "2Theta/Tof/Eng" value tt \ 1049 variable graph(plotunits) \ 1050 command "plotdata $box" 1051 } else { 1052 .a.options.menu add radiobutton label "2Theta" value tt \ 1053 variable graph(plotunits) \ 1054 command "plotdata $box" 1055 .a.options.menu add command label "Set Equiv. Wavelength" \ 1056 command "seteqwave $box" 1057 } 764 1058 .a.options.menu add radiobutton label "dspace" value d \ 765 1059 variable graph(plotunits) \ … … 780 1074 .a.help.menu add command command aboutwidplot label About 781 1075 782 foreach item $datalist {783 .a.plot.menu add checkbutton label $lblarr($item) \784 command "plotdata $box" variable display($item)785 }786 787 1076 pack .a side top fill both 788 1077 pack $box fill both expand yes 1078 1079 # 1080 # OK now go get the profile info 1081 if {$expnam != ""} { 1082 getprofiles $expnam 1083 } 1084 # 1085 1086 trace variable newmenu(opt) w setoptmsg 1087 1088 proc setoptmsg {args} { 1089 global newmenu 1090 array set opttxt { 1091 0 "Cylindrical samples, Lobanov & Alte da Veiga (TOF, CW, synch.)" 1092 1 "Simple linear (TOF)" 1093 2 "Surface Roughness, Pitschke, Hermann & Muttern (BraggBrentano)" 1094 3 "Surface Roughness, Suortti (BraggBrentano)" 1095 4 "Flat plate, transmission mode" 1096 } 1097 set newmenu(opttxt) "" 1098 catch {set newmenu(opttxt) [set opttxt($newmenu(opt))]} 1099 } 789 1100 set datanum 0 790 1101 donewaitmsg
Note: See TracChangeset
for help on using the changeset viewer.