1774 lines
52 KiB
Tcl
1774 lines
52 KiB
Tcl
#----------------------------------------------------------
|
|
# This is a file full of support functions for four
|
|
# circle diffraction in the new four circle system. This
|
|
# is the common, shared stuff. There should be another
|
|
# file which contains the instrument specific adaptions.
|
|
#
|
|
# Mark Koennecke, August 2008, November 2008, February 2009
|
|
#----------------------------------------------------------
|
|
if { [info exists __singlexinit] == 0 } {
|
|
set __singlexinit 1
|
|
MakeSingleX
|
|
Publish projectdir Spy
|
|
Publish cell Spy
|
|
Publish ub Spy
|
|
Publish spgrp Spy
|
|
Publish calcang Spy
|
|
Publish calchkl Spy
|
|
Publish calctth Spy
|
|
Publish refclear User
|
|
Publish reflist Spy
|
|
# Publish refang User
|
|
Publish refdel User
|
|
Publish refhkl User
|
|
Publish refang User
|
|
# Publish refhklang User
|
|
Publish refadd User
|
|
Publish refindex User
|
|
Publish calcub User
|
|
Publish recoub User
|
|
Publish centerlist User
|
|
Publish indexhkl Spy
|
|
Publish coneconf User
|
|
Publish tablist Spy
|
|
Publish tabclear User
|
|
Publish tabadd User
|
|
Publish tabdel User
|
|
Publish tabsave User
|
|
Publish tabload user
|
|
Publish loadx User
|
|
Publish testx User
|
|
Publish collconf User
|
|
Publish hkllimit Spy
|
|
Publish hklgen User
|
|
Publish indw User
|
|
Publish indsave Spy
|
|
Publish indsort User
|
|
Publish indlist Spy
|
|
Publish indexconf User
|
|
Publish index User
|
|
Publish indexub User
|
|
Publish indexdirax User
|
|
Publish ubrefine User
|
|
Publish refshow User
|
|
Publish loadub User
|
|
Publish refload User
|
|
Publish refsave User
|
|
Publish confsearch User
|
|
Publish confsearchnb User
|
|
Publish search User
|
|
Publish findpeaksinscan User
|
|
Publish psiscan User
|
|
MakeConfigurableMotor psi
|
|
psi drivescript noop
|
|
psi readscript noopr
|
|
Publish messprepare User
|
|
Publish messcollect User
|
|
Publish psidrive User
|
|
Publish psiprepare User
|
|
Publish psicollect User
|
|
Publish bitonb User
|
|
Publish savexxx Spy
|
|
set __collectrun 0
|
|
Publish ubrefinehdb User
|
|
Publish runindex user
|
|
SicsAlias refshow ubshow
|
|
SicsAlias loadub ubload
|
|
SicsAlias calcub ubcalc
|
|
SicsAlias recoub ubrecover
|
|
}
|
|
#---------------------------------------------------------
|
|
# support function for handling ranges in measuring
|
|
# reflections. This is tricky: When calculating if a
|
|
# reflection is scannable one has to take the range of
|
|
# the scan into account. SICS goes to great pain to calculate
|
|
# reflections in spite of restrictions. It tweaks ome, searches
|
|
# psi etc. In order to arrive at a scannable position for
|
|
# calculations and initial driving, the ranges in om and stt
|
|
# have to be corrected to include the scan range. These support
|
|
# functions take care of this.
|
|
#----------------------------------------------------------
|
|
set __fmessomup 0
|
|
set __fmessomlow 0
|
|
set __fmsttup 0
|
|
set __fmsttlow 0
|
|
#-----------------------------------------------------------
|
|
proc savefmesslim {} {
|
|
global __fmessomup __fmessomlow __fmsttup __fmsttlow
|
|
set ommot [singlex motnam om]
|
|
set __fmessomup [string trim [SplitReply [$ommot softupperlim]]]
|
|
set __fmessomlow [string trim [SplitReply [$ommot softlowerlim]]]
|
|
set sttmot [singlex motnam stt]
|
|
set __fmsttup [string trim [SplitReply [$sttmot softupperlim]]]
|
|
set __fmsttlow [string trim [SplitReply [$sttmot softlowerlim]]]
|
|
}
|
|
#------------------------------------------------------------
|
|
proc setfmesslim {h k l } {
|
|
global __fmessomup __fmessomlow __fmsttup __fmsttlow
|
|
set ommot [singlex motnam om]
|
|
set sttmot [singlex motnam stt]
|
|
set status [catch {singlex sttub $h $k $l} refstt]
|
|
if {$status != 0} {
|
|
error "Failed to calculate two-theta"
|
|
}
|
|
set scanlist [split [fmess scanpar $refstt] ,]
|
|
set range [expr ([lindex $scanlist 2]/2.) * [lindex $scanlist 1]]
|
|
$ommot softlowerlim [expr $__fmessomlow + $range]
|
|
$ommot softupperlim [expr $__fmessomup - $range]
|
|
if {[string first o2t [lindex $scanlist 0]] >= 0} {
|
|
$sttmot softlowerlim [expr $__fmsttlow + 2.*$range]
|
|
$sttmot softupperlim [expr $__fmsttup - 2.*$range]
|
|
} else {
|
|
$sttmot softlowerlim $__fmsttlow
|
|
$sttmot softupperlim $__fmsttup
|
|
}
|
|
}
|
|
#----------------------------------------------------------
|
|
proc restorefmesslim {} {
|
|
global __fmessomup __fmessomlow __fmsttup __fmsttlow
|
|
set ommot [singlex motnam om]
|
|
set sttmot [singlex motnam stt]
|
|
$ommot softlowerlim $__fmessomlow
|
|
$ommot softupperlim $__fmessomup
|
|
$sttmot softlowerlim $__fmsttlow
|
|
$sttmot softupperlim $__fmsttup
|
|
}
|
|
#----------------------------------------------------------
|
|
proc projectdir { {dir NULL} } {
|
|
if {[string compare $dir NULL] == 0} {
|
|
set dir [SplitReply [exe batchpath]]
|
|
return "projectdir = $dir"
|
|
} else {
|
|
exe batchpath $dir
|
|
return OK
|
|
}
|
|
}
|
|
#-----------------------------------------------------------
|
|
proc cell args {
|
|
if {[llength $args] < 6} {
|
|
set val [SplitReply [singlex cell]]
|
|
return "cell = $val"
|
|
} else {
|
|
singlex cell $args
|
|
return OK
|
|
}
|
|
}
|
|
#-----------------------------------------------------------
|
|
proc ub args {
|
|
if {[llength $args] < 9} {
|
|
set val [SplitReply [singlex ub]]
|
|
return "ub = $val"
|
|
} else {
|
|
singlex ub $args
|
|
return OK
|
|
}
|
|
}
|
|
#-----------------------------------------------------------
|
|
proc spgrp args {
|
|
if {[llength $args] < 1} {
|
|
set val [SplitReply [singlex spacegroup]]
|
|
return "spgrp = $val"
|
|
} else {
|
|
singlex spacegroup [join $args]
|
|
return OK
|
|
}
|
|
}
|
|
#------------------------------------------------------------
|
|
proc calcang {h k l} {
|
|
set status [catch {hkl calc $h $k $l} res]
|
|
if {$status != 0} {
|
|
error $res
|
|
}
|
|
return $res
|
|
}
|
|
#-----------------------------------------------------------
|
|
proc getsetangles {} {
|
|
set mo [string trim [SplitReply [singlex mode]]]
|
|
switch $mo {
|
|
bi {
|
|
lappend res [singlex motval stt]
|
|
lappend res [singlex motval om]
|
|
lappend res [singlex motval chi]
|
|
lappend res [singlex motval phi]
|
|
}
|
|
nb {
|
|
lappend res [singlex motval stt]
|
|
lappend res [singlex motval om]
|
|
lappend res [singlex motval nu]
|
|
}
|
|
tas {
|
|
lappend res [singlex motval om]
|
|
lappend res [singlex motval stt]
|
|
lappend res [singlex motval sgu]
|
|
lappend res [singlex motval sgl]
|
|
}
|
|
}
|
|
return $res
|
|
}
|
|
#------------------------------------------------------------
|
|
proc calchkl args {
|
|
set mo [string trim [SplitReply [singlex mode]]]
|
|
switch $mo {
|
|
bi {
|
|
if {[llength $args] < 4} {
|
|
set stt [singlex motval stt]
|
|
set om [singlex motval om]
|
|
set chi [singlex motval chi]
|
|
set phi [singlex motval phi]
|
|
} else {
|
|
set stt [lindex $args 0]
|
|
set om [lindex $args 1]
|
|
set chi [lindex $args 2]
|
|
set phi [lindex $args 3]
|
|
}
|
|
}
|
|
nb {
|
|
if {[llength $args] < 3} {
|
|
set stt [singlex motval stt]
|
|
set om [singlex motval om]
|
|
set chi [singlex motval nu]
|
|
set phi 0
|
|
} else {
|
|
set stt [lindex $args 0]
|
|
set om [lindex $args 1]
|
|
set chi [lindex $args 2]
|
|
set phi 0
|
|
}
|
|
}
|
|
tas {
|
|
if {[llength $args] < 4} {
|
|
set stt [singlex motval om]
|
|
set om [singlex motval stt]
|
|
set chi [singlex motval sgu]
|
|
set phi [singlex motval sgl]
|
|
} else {
|
|
set stt [lindex $args 0]
|
|
set om [lindex $args 1]
|
|
set chi [lindex $args 2]
|
|
set phi [lindex $args 3]
|
|
}
|
|
}
|
|
}
|
|
return [hkl fromangles $stt $om $chi $phi]
|
|
}
|
|
#----------------------------------------------------------------
|
|
proc calctth {h k l} {
|
|
return [hkl calctth $h $k $l]
|
|
}
|
|
#---------------------------------------------------------------
|
|
proc refclear {} {
|
|
ref clear
|
|
return OK
|
|
}
|
|
#--------------------------------------------------------------
|
|
proc reflist {} {
|
|
ref print
|
|
}
|
|
#----------------------------------------------------------------------------
|
|
proc refload {filename} {
|
|
append fname [string trim [SplitReply [exe batchpath]]] / $filename
|
|
set status [catch {open $fname r} in]
|
|
if {$status != 0} {
|
|
error "Failed to open $fname"
|
|
}
|
|
ref clear
|
|
set count 0
|
|
while {[gets $in line] > 0} {
|
|
eval ref addax $line
|
|
incr count
|
|
}
|
|
close $in
|
|
return "$count reflections loaded from $fname"
|
|
}
|
|
#------------------------------------------------------------
|
|
proc refsave {filename} {
|
|
append fname [string trim [SplitReply [exe batchpath]]] / $filename
|
|
set status [catch {open $fname w} in]
|
|
if {$status != 0} {
|
|
error "Failed to open $fname"
|
|
}
|
|
set reflist [split [ref names] \n]
|
|
foreach ref $reflist {
|
|
if {[string length $ref] < 2} {
|
|
continue
|
|
}
|
|
set txt [ref show [string trim $ref]]
|
|
set txtlist [split $txt]
|
|
set outlist [lrange $txtlist 2 end]
|
|
puts $in [join $outlist]
|
|
}
|
|
close $in
|
|
return "Saved"
|
|
}
|
|
#-------------------------------------------------------------
|
|
proc refadd args {
|
|
if {[llength $args] < 1} {
|
|
error "ERROR: need at lest keyword for refadd"
|
|
}
|
|
set key [lindex $args 0]
|
|
switch $key {
|
|
ang { return [eval refadang [lrange $args 1 end]]}
|
|
idx { return [eval refidx [lrange $args 1 end]]}
|
|
idxang {return [eval refhklang [lrange $args 1 end]]}
|
|
}
|
|
}
|
|
#--------------------------------------------------------------
|
|
proc refadang args {
|
|
if {[llength $args] < 3} {
|
|
set ang [getsetangles]
|
|
} else {
|
|
set ang $args
|
|
}
|
|
eval ref adda $ang
|
|
return OK
|
|
}
|
|
#---------------------------------------------------------------
|
|
proc refidx {h k l} {
|
|
ref addx $h $k $l
|
|
return OK
|
|
}
|
|
#-------------------------------------------------------------
|
|
proc refdel {id} {
|
|
return [ref del $id]
|
|
}
|
|
#--------------------------------------------------------------
|
|
proc refhkl {id h k l } {
|
|
return [ref setx $id $h $k $l]
|
|
}
|
|
#-------------------------------------------------------------
|
|
proc refang args {
|
|
set len [llength $args]
|
|
if {$len < 1} {
|
|
error "Need at least id to set angles"
|
|
}
|
|
set mo [string trim [SplitReply [singlex mode]]]
|
|
switch $mo {
|
|
tas -
|
|
bi {
|
|
set reflen 4
|
|
}
|
|
nb {
|
|
set reflen 3
|
|
}
|
|
}
|
|
if {$len >= $reflen +1} {
|
|
set anglist [lrange $args 1 end]
|
|
} else {
|
|
set anglist [getsetangles]
|
|
}
|
|
return [eval ref seta [lindex $args 0] $anglist]
|
|
}
|
|
#-------------------------------------------------------------
|
|
proc refhklang args {
|
|
set len [llength $args]
|
|
if {$len < 3} {
|
|
error "Need at least hkl"
|
|
}
|
|
set mo [string trim [SplitReply [singlex mode]]]
|
|
switch $mo {
|
|
bi {
|
|
set reflen 4
|
|
}
|
|
nb {
|
|
set reflen 3
|
|
}
|
|
tas {
|
|
set reflen 4
|
|
}
|
|
}
|
|
if {$len >= $reflen +3} {
|
|
set anglist [lrange $args 3 end]
|
|
} else {
|
|
set anglist [getsetangles]
|
|
}
|
|
return [eval ref addax [lindex $args 0] [lindex $args 1] [lindex $args 2] \
|
|
$anglist]
|
|
}
|
|
#-------------------------------------------------------------
|
|
proc refindex {} {
|
|
return [simidx idxref]
|
|
}
|
|
#-------------------------------------------------------------
|
|
proc calcub args {
|
|
set len [llength $args]
|
|
if {$len < 2} {
|
|
error "Not enough indices to calculate UB"
|
|
}
|
|
if {$len == 2} {
|
|
set status [catch {ubcalcint ub2ref [lindex $args 0] \
|
|
[lindex $args 1]} msg]
|
|
} else {
|
|
set status [catch {ubcalcint ub3ref [lindex $args 0] \
|
|
[lindex $args 1] [lindex $args 2]} msg]
|
|
}
|
|
if {$status == 0} {
|
|
ubcalcint activate
|
|
return OK
|
|
} else {
|
|
error $msg
|
|
}
|
|
}
|
|
#----------------------------------------------------------------
|
|
proc recoub {} {
|
|
return [singlex recoverub]
|
|
}
|
|
#-----------------------------------------------------------------
|
|
proc centerlist {preset {mode monitor} {skip 0} } {
|
|
set reflist [split [ref names] \n]
|
|
foreach refid $reflist {
|
|
if {[string length $refid] < 1} {
|
|
continue
|
|
}
|
|
if {$skip > 0} {
|
|
incr skip -1
|
|
continue
|
|
}
|
|
set val [split [ref show $refid]]
|
|
set h [lindex $val 2]
|
|
set k [lindex $val 3]
|
|
set l [lindex $val 4]
|
|
clientput "Processing reflection $refid = $h $k $l"
|
|
set stt [lindex $val 5]
|
|
if {$stt > .0} {
|
|
set mo [string trim [SplitReply [singlex mode]]]
|
|
switch $mo {
|
|
bi {
|
|
set om [lindex $val 6]
|
|
set chi [lindex $val 7]
|
|
set phi [lindex $val 8]
|
|
set status [catch {drive stt $stt om $om chi $chi phi $phi} msg]
|
|
}
|
|
nb {
|
|
set om [lindex $val 6]
|
|
set nu [lindex $val 7]
|
|
set status [catch {drive stt $stt om $om nu $nu} msg]
|
|
}
|
|
}
|
|
} else {
|
|
set status [catch {drive h $h k $k l $l} msg]
|
|
}
|
|
if { $status == 0} {
|
|
set status [catch {centerref $preset $mode} msg]
|
|
if {$status == 0} {
|
|
refang $refid
|
|
set ompos [string trim [SplitReply [om]]]
|
|
cscan om $ompos .1 20 $preset
|
|
drive om $ompos
|
|
} else {
|
|
set rupt [getint]
|
|
if {[string compare $rupt abortop] == 0} {
|
|
setint "continue"
|
|
clientput "WARNING: aborted reflection $refid because of driving problem"
|
|
continue
|
|
}
|
|
if {[string compare $rupt continue] != 0} {
|
|
error $msg
|
|
}
|
|
clientput "ERROR: failed to center $refid with $msg"
|
|
continue
|
|
}
|
|
} else {
|
|
set rupt [getint]
|
|
if {[string compare $rupt abortop] == 0} {
|
|
clientput "WARNING: aborted reflection $refid because of driving problem"
|
|
setint "continue"
|
|
continue
|
|
}
|
|
if {[string compare $rupt continue] != 0} {
|
|
error $msg
|
|
}
|
|
clientput "ERROR: failed to drive $refid with $msg"
|
|
continue
|
|
}
|
|
}
|
|
return "Done centering [expr [llength $reflist] -1] reflections"
|
|
}
|
|
#----------------------------------------------------------------------
|
|
proc indexhkl args {
|
|
if {[llength $args] > 0} {
|
|
ubcalcint index [lindex $args 0]
|
|
} else {
|
|
ubcalcint index
|
|
}
|
|
}
|
|
#-----------------------------------------------------------------------
|
|
proc coneconf args {
|
|
if {[llength $args] < 4} {
|
|
append result "coneconf = " [SplitReply [cone center]]
|
|
append result " " [SplitReply [cone target]]
|
|
append result " " [SplitReply [cone qscale]]
|
|
return $result
|
|
}
|
|
set cid [lindex $args 0]
|
|
set h [lindex $args 1]
|
|
set k [lindex $args 2]
|
|
set l [lindex $args 3]
|
|
if {[llength $args] > 4} {
|
|
set qscale [lindex $args 4]
|
|
} else {
|
|
set qscale 1.0
|
|
}
|
|
cone center $cid
|
|
cone target $h $k $l
|
|
cone qscale $qscale
|
|
return OK
|
|
}
|
|
#---------------------------------------------------------------------------
|
|
proc tablist {} {
|
|
return [fmess table print]
|
|
}
|
|
#---------------------------------------------------------------------------
|
|
proc tabclear {} {
|
|
return [fmess table clear]
|
|
}
|
|
#---------------------------------------------------------------------------
|
|
proc tabadd {sttend scanvar step np preset } {
|
|
return [fmess table addrow $sttend $scanvar $step $np $preset]
|
|
}
|
|
#---------------------------------------------------------------------------
|
|
proc tabdel {no} {
|
|
set id [format "%4.4d" $no]
|
|
[return fmess del $id]
|
|
}
|
|
#----------------------------------------------------------------------------
|
|
proc tabsave {filename} {
|
|
append fname [string trim [SplitReply [exe batchpath]]] / $filename
|
|
set status [catch {open $fname w} out]
|
|
if {$status != 0} {
|
|
error "Failed to open $fname"
|
|
}
|
|
set table [fmess table print]
|
|
set tblist [split $table "\n"]
|
|
for {set i 1} {$i < [llength $tblist]} {incr i} {
|
|
set line [lindex $tblist $i]
|
|
set line [string trim [regsub -all "\\s+" $line " "]]
|
|
set l [split $line]
|
|
puts $out [join [lrange $l 1 end]]
|
|
}
|
|
close $out
|
|
return Done
|
|
}
|
|
#---------------------------------------------------------------------------
|
|
proc tabload {filename} {
|
|
append fname [string trim [SplitReply [exe batchpath]]] / $filename
|
|
set status [catch {open $fname r} in]
|
|
if {$status != 0} {
|
|
error "Failed to open $fname"
|
|
}
|
|
fmess table clear
|
|
while {[gets $in line] > 0} {
|
|
eval fmess table addrow $line
|
|
}
|
|
close $in
|
|
return Done
|
|
}
|
|
#----------------------------------------------------------------------------
|
|
proc loadx {filename} {
|
|
global __collectrun
|
|
|
|
if {$__collectrun == 1} {
|
|
error "Cannot load reflections while data collection running"
|
|
}
|
|
append fname [string trim [SplitReply [exe batchpath]]] / $filename
|
|
set status [catch {open $fname r} in]
|
|
if {$status != 0} {
|
|
error "Failed to open $fname"
|
|
}
|
|
messref clear
|
|
set count 0
|
|
while {[gets $in line] > 0} {
|
|
set status [stscan $line " %f %f %f" h k l]
|
|
if {$status >= 3} {
|
|
messref addx $h $k $l
|
|
incr count
|
|
} else {
|
|
clientput "Skipped invalid entry $line"
|
|
}
|
|
}
|
|
close $in
|
|
return "$count reflections loaded from $fname"
|
|
}
|
|
#-----------------------------------------------------------
|
|
proc testRef {h k l} {
|
|
#-- first test: can I calculate the reflection
|
|
set status [catch {hkl calc $h $k $l} msg]
|
|
if {$status != 0} {
|
|
return 0
|
|
}
|
|
#--- second test: is the scan range accessible
|
|
set l1 [split $msg ,]
|
|
set stt [string trim [SplitReply [lindex $l1 0]]]
|
|
set om [string trim [SplitReply [lindex $l1 1]]]
|
|
set scanpar [fmess scanpar $stt]
|
|
set scanlist [split $scanpar ,]
|
|
set range [expr ([lindex $scanlist 2]/2.) * [lindex $scanlist 1]]
|
|
set sttmot [singlex motnam stt]
|
|
set ommot [singlex motnam om]
|
|
set status [catch {sicsbounds $ommot [expr $om - $range]} msg]
|
|
if {$status != 0} {
|
|
# clientput "om scanbounds broken"
|
|
return 0
|
|
}
|
|
set status [catch {sicsbounds $ommot [expr $om + $range]} msg]
|
|
if {$status != 0} {
|
|
# clientput "om scanbounds broken"
|
|
return 0
|
|
}
|
|
if {[string first o2t [lindex $scanlist 0]] >= 0} {
|
|
set status [catch {sicsbounds $sttmot [expr $stt - $range*2.]} msg]
|
|
if {$status != 0} {
|
|
# clientput "stt scanbounds broken"
|
|
return 0
|
|
}
|
|
set status [catch {sicsbounds $sttmot [expr $stt + $range*2.]} msg]
|
|
if {$status != 0} {
|
|
# clientput "stt scanbounds broken"
|
|
return 0
|
|
}
|
|
}
|
|
set status [catch {sicsbounds $sttmot $stt} msg]
|
|
if {$status != 0} {
|
|
# clientput "stt violated: $stt"
|
|
return 0
|
|
}
|
|
set status [catch {sicsbounds $ommot $om} msg]
|
|
if {$status != 0} {
|
|
# clientput "om violated"
|
|
return 0
|
|
}
|
|
set mo [string trim [SplitReply [singlex mode]]]
|
|
switch $mo {
|
|
bi {
|
|
set chi [string trim [SplitReply [lindex $l1 2]]]
|
|
set chimot [singlex motnam chi]
|
|
set status [catch {sicsbounds $chimot $chi} msg]
|
|
if {$status != 0} {
|
|
# clientput "chi violated"
|
|
return 0
|
|
}
|
|
set phi [string trim [SplitReply [lindex $l1 3]]]
|
|
set phimot [singlex motnam phi]
|
|
set status [catch {sicsbounds $phimot $phi} msg]
|
|
if {$status != 0} {
|
|
# clientput "phi violated"
|
|
return 0
|
|
}
|
|
}
|
|
nb {
|
|
set nu [string trim [SplitReply [lindex $l1 2]]]
|
|
set numot [singlex motnam nu]
|
|
set status [catch {sicsbounds $numot $nu} msg]
|
|
if {$status != 0} {
|
|
# clientput "nu violated"
|
|
return 0
|
|
}
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
#------------------------------------------------------------
|
|
proc testRefNew {h k l } {
|
|
return [catch {hkl calc $h $k $l} msg]
|
|
}
|
|
#------------------------------------------------------------
|
|
proc testx args {
|
|
set delete 0
|
|
set symsearch 0
|
|
foreach txt $args {
|
|
if {[string compare $txt del] == 0} {
|
|
set delete 1
|
|
}
|
|
if {[string compare $txt sym] == 0} {
|
|
set symsearch 1
|
|
}
|
|
}
|
|
set reflist [split [messref names] \n]
|
|
savefmesslim
|
|
|
|
foreach ref $reflist {
|
|
if {[string length $ref] < 1} {
|
|
continue
|
|
}
|
|
set data [split [messref show $ref]]
|
|
set h [lindex $data 2]
|
|
set k [lindex $data 3]
|
|
set l [lindex $data 4]
|
|
catch {setfmesslim $h $k $l} message
|
|
|
|
if {[testRefNew $h $k $l] == 1} {
|
|
if {$symsearch == 1} {
|
|
set test [catch {singlex symref $h $k $l} msg]
|
|
if {$test == 0} {
|
|
set hkllist [split $msg ,]
|
|
set hn [lindex $hkllist 0]
|
|
set kn [lindex $hkllist 1]
|
|
set ln [lindex $hkllist 2]
|
|
if {[testRefNew $hn $kn $ln] == 0} {
|
|
messref setx $ref $hn $kn $ln
|
|
clientput "$h $k $l replaced by reachable $hn $kn $ln"
|
|
} else {
|
|
lappend badref $ref
|
|
clientput "Nor reflection $h $k $l or equivalent scannable"
|
|
}
|
|
} else {
|
|
lappend badref $ref
|
|
clientput "Nor reflection $h $k $l or equivalent scannable"
|
|
}
|
|
} else {
|
|
lappend badref $ref
|
|
clientput "Reflection $h $k $l not scannable"
|
|
}
|
|
}
|
|
}
|
|
set total [llength $reflist]
|
|
if {[info exists badref] == 1} {
|
|
set bad [llength $badref]
|
|
} else {
|
|
set bad 0
|
|
}
|
|
incr total -1
|
|
clientput "$bad out of $total reflections are bad"
|
|
if {$delete == 1 && $bad > 0} {
|
|
foreach ref $badref {
|
|
messref del $ref
|
|
}
|
|
clientput "$bad reflections deleted"
|
|
set total [expr $total - $bad]
|
|
}
|
|
restorefmesslim
|
|
return "Still $total reflections in list"
|
|
}
|
|
#-----------------------------------------------------
|
|
proc collconf args {
|
|
set modelist [list monitor timer]
|
|
if {[llength $args] < 4} {
|
|
append res [SplitReply [fmess mode]]
|
|
append res [SplitReply [fmess fast]]
|
|
append res " " [SplitReply [fmess weak]]
|
|
append res " " [SplitReply [fmess weakthreshold]]
|
|
return $res
|
|
} else {
|
|
set mode [lindex $args 0]
|
|
if {[lsearch $modelist $mode] < 0} {
|
|
error "CountMode $mode not recognized"
|
|
}
|
|
fmess mode $mode
|
|
fmess fast [lindex $args 1]
|
|
fmess weak [lindex $args 2]
|
|
fmess weakthreshold [lindex $args 3]
|
|
return OK
|
|
}
|
|
}
|
|
#---------------------------------------------------------------------------
|
|
proc messprepare {obj userdata} {
|
|
global stdscangraph
|
|
fmess prepare $obj $userdata
|
|
catch {hupdate $stdscangraph/dim}
|
|
}
|
|
#--------------------------------------------------------------------------
|
|
proc messcollect {obj userdata np} {
|
|
global stdscangraph
|
|
stdscan silentcollect $obj $userdata $np
|
|
catch {hupdate $stdscangraph/scan_variable}
|
|
catch {hupdate $stdscangraph/counts}
|
|
}
|
|
#----------------------------------------------------------------------------
|
|
proc configuremessscan {} {
|
|
xxxscan configure script
|
|
xxxscan function writeheader donothing
|
|
xxxscan function prepare messprepare
|
|
set fast [hval /sics/fmess/fast]
|
|
if {$fast == 1} {
|
|
xxxscan function drive stdscan fastdrive
|
|
} else {
|
|
xxxscan function drive stdscan drive
|
|
}
|
|
xxxscan function count stdscan count
|
|
xxxscan function collect messcollect
|
|
xxxscan function writepoint donothing
|
|
xxxscan function finish donothing
|
|
}
|
|
#------------------------------------------------------------
|
|
proc scanref {ref} {
|
|
set ommot [singlex motnam om]
|
|
set sttmot [singlex motnam stt]
|
|
set stt [SplitReply [eval $sttmot]]
|
|
set om [SplitReply [eval $ommot]]
|
|
set scanpar [split [fmess scanpar $stt] ,]
|
|
if {[string first "Not" $scanpar] >= 0} {
|
|
error "Scan parameters not found"
|
|
}
|
|
set scanvar [lindex $scanpar 0]
|
|
set step [lindex $scanpar 1]
|
|
set np [lindex $scanpar 2]
|
|
set preset [lindex $scanpar 3]
|
|
xxxscan clear
|
|
set range [expr $np/2. *$step]
|
|
set start [expr $om - $range]
|
|
xxxscan add $ommot $start $step
|
|
if {[string first o2t $scanvar] >= 0} {
|
|
set start [expr $stt - 2*$range]
|
|
xxxscan add $sttmot $start [expr $step * 2.]
|
|
}
|
|
set mode [string trim [SplitReply [fmess mode]]]
|
|
xxxscan run $np $mode $preset
|
|
# set weak [string trim [SplitReply [fmess weak]]]
|
|
# if {$weak == 1} {
|
|
# xxxscan run $np $mode [expr $preset*4]
|
|
# }
|
|
}
|
|
#-------------------------------------------------------------
|
|
proc hkllimit args {
|
|
if {[llength $args] < 8} {
|
|
append res "indconf = "
|
|
append res [SplitReply [fmess hkllim]] " "
|
|
append res [SplitReply [fmess sttlim]]
|
|
return $res
|
|
} else {
|
|
fmess hkllim [lrange $args 0 5]
|
|
fmess sttlim [lrange $args 6 end]
|
|
return OK
|
|
}
|
|
}
|
|
#-------------------------------------------------------------
|
|
proc hklgen { {sup no} } {
|
|
global __collectrun
|
|
|
|
if {$__collectrun == 1} {
|
|
error "Cannot generate reflection while data collection running"
|
|
}
|
|
append res "Generating Indices with the Parameters:\n"
|
|
append res "Spacegroup = " [SplitReply [spgrp]] \n
|
|
append res "Cell = " [SplitReply [singlex cell]] \n
|
|
append res "HKL Limits = " [SplitReply [fmess hkllim]] \n
|
|
append res "Two Theta Limits = " [SplitReply [fmess sttlim]] \n
|
|
switch $sup {
|
|
no {
|
|
set suppress 0
|
|
}
|
|
opp {
|
|
set suppress 2
|
|
}
|
|
default {
|
|
set suppress 1
|
|
}
|
|
}
|
|
append res [fmess indgen $suppress]
|
|
# fmess indsort
|
|
return $res
|
|
}
|
|
#----------------------------------------------------------------
|
|
proc indw {hw kw lw} {
|
|
return [fmess genw $hw $kw $lw]
|
|
}
|
|
#----------------------------------------------------------------
|
|
proc indsave {filename} {
|
|
set fullname [string trim [SplitReply [exe batchpath]]]/$filename
|
|
set out [open $fullname w]
|
|
set reflist [split [messref names] \n]
|
|
foreach ref $reflist {
|
|
if {[string length $ref] < 1} {
|
|
continue
|
|
}
|
|
set idxlist [split [messref show $ref]]
|
|
puts $out [format " %12.6f %12.6f %12.6f" [lindex $idxlist 2] \
|
|
[lindex $idxlist 3] [lindex $idxlist 4]]
|
|
|
|
}
|
|
close $out
|
|
return "Done"
|
|
}
|
|
#---------------------------------------------------------------
|
|
proc indsort {} {
|
|
return [fmess indsort]
|
|
}
|
|
#---------------------------------------------------------------
|
|
proc indlist {} {
|
|
return [messref print]
|
|
}
|
|
#--------------------------------------------------------------
|
|
proc indexconf args {
|
|
if {[llength $args] < 2} {
|
|
append res "simidxconf = "
|
|
append res [SplitReply [simidx sttlim]] ", "
|
|
append res [SplitReply [simidx anglim]] " "
|
|
return $res
|
|
} else {
|
|
simidx sttlim [lindex $args 0]
|
|
simidx anglim [lindex $args 1]
|
|
ubcalcint difftheta [lindex $args 0]
|
|
}
|
|
return OK
|
|
}
|
|
#---------------------------------------------------------------
|
|
proc index {} {
|
|
simidx run
|
|
return Done
|
|
}
|
|
#---------------------------------------------------------------
|
|
proc indexub {idx} {
|
|
return [simidx choose $idx]
|
|
}
|
|
#-------------------------------------------------------------
|
|
proc indexdirax {} {
|
|
set path [SplitReply [exe batchpath]]
|
|
simidx dirax $path/sics.idx
|
|
}
|
|
#----------------------------------------------------------
|
|
proc writerafincell {out cellflag} {
|
|
set lat [string trim [SplitReply [singlex lattice]]]
|
|
set cell [string trim [SplitReply [singlex cell]]]
|
|
set cellist [split $cell]
|
|
set a [lindex $cellist 0]
|
|
set b [lindex $cellist 1]
|
|
set c [lindex $cellist 2]
|
|
set alpha [lindex $cellist 3]
|
|
set beta [lindex $cellist 4]
|
|
set gamma [lindex $cellist 5]
|
|
#----------- by default: do not refine cell constants
|
|
if {[string compare $cellflag NULL] == 0} {
|
|
puts $out "0 $a 0 $b 0 $c 0 $alpha 0 $beta 0 $gamma"
|
|
return
|
|
}
|
|
switch $lat {
|
|
0 -
|
|
1 {
|
|
puts $out "1 $a 1 $b 1 $c 1 $alpha 1 $beta 1 $gamma"
|
|
}
|
|
2 {
|
|
puts $out "1 $a 1 $b 1 $c 0 90 1 $beta 0 90"
|
|
}
|
|
3 {
|
|
puts $out "1 $a 1 $b 1 $c 0 90 0 90 0 90"
|
|
}
|
|
4 {
|
|
puts $out "1 $a 2 $b 1 $c 0 90 0 90 0 90"
|
|
}
|
|
5 {
|
|
puts $out "1 $a 2 $b 2 $c 1 $alpha 2 $beta 2 $gamma"
|
|
}
|
|
6 {
|
|
puts $out "1 $a 2 $b 1 $c 0 90 0 90 0 120"
|
|
}
|
|
7 {
|
|
puts $out "1 $a 2 $b 2 $c 0 90 0 90 0 90"
|
|
}
|
|
}
|
|
}
|
|
#----------------------------------------------------------
|
|
proc writerafinref {out} {
|
|
set ref [ref names]
|
|
set idlist [split $ref \n]
|
|
foreach id $idlist {
|
|
if {[string length $id] < 1} {
|
|
continue
|
|
}
|
|
set status [catch {ref show $id} refdat]
|
|
if {$status != 0} {
|
|
continue
|
|
}
|
|
set refli [split $refdat]
|
|
set rd [lrange $refli 2 end]
|
|
if {[llength $rd] > 6} {
|
|
puts $out [format "%9.4f %9.4f %9.4f %8.3f %8.3f %8.3f %8.3f" \
|
|
[lindex $rd 0] [lindex $rd 1] [lindex $rd 2] \
|
|
[lindex $rd 3] [lindex $rd 4] \
|
|
[lindex $rd 5] [lindex $rd 6]]
|
|
} else {
|
|
puts $out [format "%9.4f %9.4f %9.4f %8.3f %8.3f %8.3f" \
|
|
[lindex $rd 0] [lindex $rd 1] [lindex $rd 2] \
|
|
[lindex $rd 3] [lindex $rd 4] \
|
|
[lindex $rd 5]]
|
|
}
|
|
}
|
|
}
|
|
#-----------------------------------------------------------
|
|
proc writerafinfile {filename cell} {
|
|
set out [open $filename w]
|
|
set tit [SplitReply [title]]
|
|
set sam [SplitReply [sample]]
|
|
puts $out "$tit, $sam"
|
|
puts $out "2 1 0 0 45 3 4 1 .5 0"
|
|
set wav [SplitReply [singlex lambda]]
|
|
puts $out "0 $wav"
|
|
puts $out "0 .0 0 .0 0 .0"
|
|
writerafincell $out $cell
|
|
writerafinref $out
|
|
puts $out ""
|
|
puts $out "-1"
|
|
close $out
|
|
catch {file attributes $filename -permissions 00664}
|
|
}
|
|
#-----------------------------------------------------------
|
|
proc writerafnbfile {filename cell} {
|
|
set out [open $filename w]
|
|
set tit [SplitReply [title]]
|
|
set sam [SplitReply [sample]]
|
|
puts $out "$tit, $sam"
|
|
puts $out "2 1 0 0 45 3 4 1 .5 0"
|
|
set wav [SplitReply [singlex lambda]]
|
|
puts $out "0 $wav"
|
|
puts $out "0 .0 0 .0 0 .0"
|
|
writerafincell $out $cell
|
|
writerafinref $out
|
|
puts $out ""
|
|
puts $out "-1"
|
|
close $out
|
|
catch {file attributes $filename -permissions 00664}
|
|
}
|
|
#---------------------------------------------------------
|
|
proc checkResult {filename} {
|
|
set f [open $filename r]
|
|
while {[gets $f line] >= 0} {
|
|
if {[string first ERROR $line] >= 0} {
|
|
close $f
|
|
error $line
|
|
}
|
|
}
|
|
return OK
|
|
}
|
|
#----------------------------------------------------------
|
|
proc runrafin {filename cell} {
|
|
global rafinprog
|
|
writerafinfile $filename $cell
|
|
set path [string trim [SplitReply [projectdir]]]
|
|
set olddir [pwd]
|
|
cd $path
|
|
set status [catch {exec $rafinprog >& rafin.lis} msg]
|
|
cd $olddir
|
|
if {$status == 0} {
|
|
checkResult $path/rafin.lis
|
|
} else {
|
|
error $msg
|
|
}
|
|
}
|
|
#----------------------------------------------------------
|
|
proc runrafnb {filename cell} {
|
|
global rafnbprog
|
|
writerafnbfile $filename $cell
|
|
set path [string trim [SplitReply [projectdir]]]
|
|
set olddir [pwd]
|
|
cd $path
|
|
catch {file delete -force rafnb.tmp}
|
|
set status [catch {exec $rafnbprog >& rafnb.lis} msg]
|
|
cd $olddir
|
|
if {$status == 0} {
|
|
checkResult $path/rafnb.lis
|
|
} else {
|
|
error $msg
|
|
}
|
|
}
|
|
#------------------------------------------------------------
|
|
proc ubrefine {{cell NULL}} {
|
|
set path [string trim [SplitReply [projectdir]]]
|
|
set filename $path/rafin.dat
|
|
set nbfile $path/rafnb.dat
|
|
set mode [string trim [SplitReply [singlex mode]]]
|
|
switch $mode {
|
|
bi { runrafin $filename $cell}
|
|
nb { runrafnb $nbfile $cell}
|
|
default { error "No UB refinement in this mode" }
|
|
}
|
|
return [refshow]
|
|
}
|
|
#----------------------------------------------------------
|
|
proc refshow {} {
|
|
set res ""
|
|
set path [string trim [SplitReply [projectdir]]]
|
|
set mode [string trim [SplitReply [singlex mode]]]
|
|
switch $mode {
|
|
bi { set filename $path/rafin.lis}
|
|
nb { set filename $path/rafnb.lis}
|
|
default { error "No UB refinement in this mode" }
|
|
}
|
|
set status [catch {open $filename r} in]
|
|
if {$status != 0} {
|
|
error "No refinement ever ran, or rafin.lis not found"
|
|
}
|
|
set dataappend 0
|
|
while {[gets $in line] >= 0} {
|
|
if {[string first ERROR $line] >= 0} {
|
|
close $in
|
|
error $line
|
|
}
|
|
if {[string first 0RESULTS $line] >= 0} {
|
|
set dataappend 1
|
|
}
|
|
if {$dataappend == 1} {
|
|
append res $line "\n"
|
|
}
|
|
}
|
|
close $in
|
|
return $res
|
|
}
|
|
#-------------------------------------------------------
|
|
proc loadub {} {
|
|
set path [string trim [SplitReply [projectdir]]]
|
|
set mode [string trim [SplitReply [singlex mode]]]
|
|
switch $mode {
|
|
bi { set filename $path/rafin.lis}
|
|
nb { set filename $path/rafnb.lis}
|
|
default {
|
|
error "No UB refinement in this mode"
|
|
}
|
|
}
|
|
set status [catch {open $filename r} in]
|
|
if {$status != 0} {
|
|
error "No refinement ever ran, or rafin,nb.lis not found"
|
|
}
|
|
while {[gets $in line] >= 0} {
|
|
if {[string first "0FINAL ORIENT" $line] >= 0} {
|
|
gets $in line
|
|
stscan $line "%f %f %f" u11 u12 u13
|
|
gets $in line
|
|
gets $in line
|
|
stscan $line "%f %f %f" u21 u22 u23
|
|
gets $in line
|
|
gets $in line
|
|
stscan $line "%f %f %f" u31 u32 u33
|
|
singlex ub $u11 $u12 $u13 $u21 $u22 $u23 $u31 $u32 $u33
|
|
}
|
|
if {[string first "0DIRECT CELL" $line] >= 0} {
|
|
stscan $line "%s %s %f %f %f %f %f %f" junk junk2 a b c alpha beta gamma
|
|
singlex cell $a $b $c $alpha $beta $gamma
|
|
}
|
|
}
|
|
close $in
|
|
return "Loaded!"
|
|
}
|
|
#--------------------------------------------------------------------
|
|
proc confsearch args {
|
|
set varlist [list min2t step2t max2t stepchi stepphi chimin chimax phimin phimax]
|
|
#-------- alternative syntax: confsearch var [value]
|
|
if {[llength $args] > 0} {
|
|
set idx [lsearch $varlist [lindex $args 0]]
|
|
if {$idx >= 0} {
|
|
if {[llength $args] > 1} {
|
|
set var [lindex $varlist $idx]
|
|
set val [lindex $args 1]
|
|
singlex peaksearch/$var $val
|
|
return OK
|
|
} else {
|
|
set var [lindex $varlist $idx]
|
|
set val [SplitReply [singlex peaksearch/$var]]
|
|
return "$var = $val"
|
|
}
|
|
}
|
|
}
|
|
#-------- normal syntsax, print or set all
|
|
if {[llength $args] < 3} {
|
|
foreach var $varlist {
|
|
set val [SplitReply [singlex peaksearch/$var]]
|
|
append result "$var = $val,"
|
|
}
|
|
return [string trim $result ,]
|
|
} else {
|
|
for {set i 0} \
|
|
{$i < [llength $args] && $i < [llength $varlist] } {incr i} {
|
|
set var [lindex $varlist $i]
|
|
set val [lindex $args $i]
|
|
singlex peaksearch/$var $val
|
|
}
|
|
return "Done"
|
|
}
|
|
}
|
|
#--------------------------------------------------------------------
|
|
proc confsearchnb args {
|
|
set varlist [list min2t step2t max2t stepom stepnu]
|
|
if {[llength $args] < 5} {
|
|
foreach var $varlist {
|
|
set val [SplitReply [singlex peaksearch/$var]]
|
|
append result "$var = $val,"
|
|
}
|
|
return [string trim $result ,]
|
|
} else {
|
|
for {set i 0} {$i < 5} {incr i} {
|
|
set var [lindex $varlist $i]
|
|
set val [lindex $args $i]
|
|
singlex peaksearch/$var $val
|
|
}
|
|
return "Done"
|
|
}
|
|
}
|
|
#-------------------------------------------------------------------
|
|
proc removeduplicatesold {peaklist} {
|
|
if {[llength $peaklist] < 1} {
|
|
return ""
|
|
}
|
|
lappend final [lindex $peaklist 0]
|
|
foreach peak $peaklist {
|
|
set valid 1
|
|
foreach fp $final {
|
|
if {abs($fp - $peak) < 2.} {
|
|
set valid 0
|
|
}
|
|
}
|
|
if {$valid == 1} {
|
|
lappend final $peak
|
|
}
|
|
}
|
|
return [join $final ,]
|
|
}
|
|
#----------------------------------------------------------------
|
|
# This one strives to locate the maximum peak with a window of 2.0
|
|
#-----------------------------------------------------------------
|
|
proc removeduplicates {peaklist countlist} {
|
|
if {[llength $peaklist] < 1} {
|
|
return ""
|
|
}
|
|
set ptr 0
|
|
set peaks($ptr) [lindex $peaklist 0]
|
|
set counts($ptr) [lindex $countlist 0]
|
|
for {set i 0} {$i < [llength $peaklist]} {incr i} {
|
|
set pos [lindex $peaklist $i]
|
|
set count [lindex $countlist $i]
|
|
if {abs($pos - $peaks($ptr)) < 2.} {
|
|
if {$count > $counts($ptr)} {
|
|
set peaks($ptr) $pos
|
|
set counts($ptr) $count
|
|
}
|
|
} else {
|
|
incr ptr
|
|
set peaks($ptr) $pos
|
|
set counts($ptr) $count
|
|
}
|
|
}
|
|
set keys [array names peaks]
|
|
foreach k $keys {
|
|
lappend final $peaks($k)
|
|
}
|
|
return $final
|
|
}
|
|
#--------------------------------------------------------------------
|
|
# Do not be confused by the use of phi. This is also used for finding
|
|
# peaks in omega in NB
|
|
#--------------------------------------------------------------------
|
|
proc findpeaksinscan {} {
|
|
set counts [split [string trim [SplitReply [xxxscan getcounts]]]]
|
|
set counts [lrange $counts 1 [expr [llength $counts] -1]]
|
|
set phiraw [SplitReply [xxxscan getvardata 0]]
|
|
foreach p $phiraw {
|
|
lappend phi [string trim $p]
|
|
}
|
|
set len [llength $counts]
|
|
for {set i 3} {$i < $len - 3} {incr i} {
|
|
set sum .0
|
|
for {set j [expr $i -3]} {$j < [expr $i + 3]} {incr j} {
|
|
if {$j != 4} {
|
|
set sum [expr $sum + [lindex $counts $j]]
|
|
}
|
|
}
|
|
set average [expr $sum/6.]
|
|
set thresh [expr sqrt($average) * 8.]
|
|
set count [lindex $counts $i]
|
|
if {$count > $thresh} {
|
|
lappend peaks [lindex $phi $i]
|
|
lappend peakcounts $count
|
|
}
|
|
}
|
|
if {[info exists peaks]} {
|
|
return [removeduplicates $peaks $peakcounts]
|
|
} else {
|
|
return ""
|
|
}
|
|
}
|
|
#----------------------------------------------------------------------
|
|
proc search {preset maxpeak {mode monitor} } {
|
|
set difmode [string trim [SplitReply [singlex mode]]]
|
|
switch $difmode {
|
|
bi {
|
|
return [searchbi $preset $mode $maxpeak]
|
|
}
|
|
nb {
|
|
return [searchnb $preset $mode $maxpeak]
|
|
}
|
|
default {
|
|
error "Peaksearch not supported in $difmode mode"
|
|
}
|
|
}
|
|
}
|
|
#-----------------------------------------------------------------------
|
|
proc searchbi {preset mode maxpeak} {
|
|
set sttmot [singlex motnam stt]
|
|
set ommot [singlex motnam om]
|
|
set chimot [singlex motnam chi]
|
|
set phimot [singlex motnam phi]
|
|
set min2t [SplitReply [singlex peaksearch/min2t]]
|
|
set chimin [SplitReply [singlex peaksearch/chimin]]
|
|
set chimax [SplitReply [singlex peaksearch/chimax]]
|
|
set phimin [SplitReply [singlex peaksearch/phimin]]
|
|
set phimax [SplitReply [singlex peaksearch/phimax]]
|
|
refclear
|
|
set chistep [SplitReply [singlex peaksearch/stepchi]]
|
|
set chinp [expr int(($chimax - $chimin)/ $chistep)]
|
|
set sttstep [SplitReply [singlex peaksearch/step2t]]
|
|
set sttnp [expr int([SplitReply [singlex peaksearch/max2t]]/$sttstep)]
|
|
set phistep [SplitReply [singlex peaksearch/stepphi]]
|
|
set phinp [expr int(($phimax - $phimin)/ $phistep)]
|
|
set detmode [string trim [SplitReply [detmode]]]
|
|
set count 0
|
|
for {set i 0} { $i < $sttnp} {incr i} {
|
|
set sttpos [expr $min2t + $i * $sttstep]
|
|
set status [catch {run $sttmot $sttpos $ommot [expr $sttpos / 2.]} msg]
|
|
if {$status != 0} {
|
|
clientput "WARNING: Cannot reach two-theta $sttpos, skipping"
|
|
continue
|
|
}
|
|
clientput "Searching at two theta: $sttpos"
|
|
for {set j 0} {$j < $chinp} {incr j} {
|
|
set chipos [expr $chimin + $j*$chistep]
|
|
set status [catch {run $chimot $chipos} msg]
|
|
if {$status != 0} {
|
|
clientput "WARNING: Cannot reach chi $chipos, skipping"
|
|
continue
|
|
}
|
|
clientput "Searching at chi: $chipos"
|
|
success
|
|
switch $detmode {
|
|
single {
|
|
xxxscan clear
|
|
xxxscan add $phimot $phimin $phistep
|
|
catch {xxxscan run $phinp $mode $preset} msg
|
|
set interrupt [getint]
|
|
if {[string first continue $interrupt] < 0} {
|
|
error $msg
|
|
}
|
|
set peaks [findpeaksinscan]
|
|
if {[llength $peaks] > 0} {
|
|
foreach p $peaks {
|
|
drive $phimot $p
|
|
centerref $preset $mode
|
|
refadd ang
|
|
incr count
|
|
if {$count >= $maxpeak} {
|
|
return "Found $maxpeak reflections, terminating..."
|
|
}
|
|
}
|
|
}
|
|
}
|
|
area {
|
|
xxxscan clear
|
|
xxxscan add $phimot 0 $phistep
|
|
catch {xxxscan run $phinp $mode $preset} msg
|
|
set interrupt [getint]
|
|
if {[string first continue $interrupt] < 0} {
|
|
error $msg
|
|
}
|
|
#--------- Do I need to extract peaks from the area detector data or is this to be
|
|
# left to anatric?
|
|
}
|
|
default {
|
|
error "Reflection search not supported for this detector mode"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
#-----------------------------------------------------------------------
|
|
# cos(gamma) = cos(tth)/cos(nu)
|
|
#-----------------------------------------------------------------------
|
|
proc calcGamma {stt nu} {
|
|
set RD 57.30
|
|
set stt [expr $stt/$RD]
|
|
set nu [expr $nu/$RD]
|
|
set val [expr cos($stt)/cos($nu)]
|
|
if {$val > 1.} {
|
|
error "Not reachable"
|
|
}
|
|
set gamma [expr acos($val)]
|
|
return [expr $gamma * $RD]
|
|
}
|
|
#-----------------------------------------------------------------------
|
|
proc searchnb {preset mode maxpeak} {
|
|
set sttmot [singlex motnam stt]
|
|
set ommot [singlex motnam om]
|
|
set numot [singlex motnam nu]
|
|
set min2t [SplitReply [singlex peaksearch/min2t]]
|
|
set omstart [SplitReply [$ommot softlowerlim]]
|
|
set omend [SplitReply [$ommot softupperlim]]
|
|
set omstep [SplitReply [singlex peaksearch/stepom]]
|
|
set omnp [expr int(($omend - $omstart)/$omstep)]
|
|
set nustart [SplitReply [$numot softlowerlim]]
|
|
set nuend [SplitReply [$numot softupperlim]]
|
|
set nustep [SplitReply [singlex peaksearch/stepnu]]
|
|
set nunp [expr ($nuend - $nustart)/$nustep]
|
|
set sttstep [SplitReply [singlex peaksearch/step2t]]
|
|
set sttnp [expr int([SplitReply [singlex peaksearch/max2t]]/$sttstep)]
|
|
refclear
|
|
set detmode [string trim [SplitReply [detmode]]]
|
|
set count 0
|
|
for {set i 0} { $i < $sttnp} {incr i} {
|
|
set sttpos [expr $min2t + $i * $sttstep]
|
|
for {set j 0} {$j < $nunp} {incr j} {
|
|
set nupos [expr $nustart + $j * $nustep]
|
|
clientput "Searching at stt: $sttpos, nu = $nupos"
|
|
if {[catch {calcGamma $sttpos $nupos} gamma] != 0} {
|
|
clientput "NB search at stt: $sttpos, nu = $nupos not reachable"
|
|
continue
|
|
}
|
|
if {[catch {drive $sttmot $gamma $numot $nupos} msg] != 0} {
|
|
clientput "Failed to reach gamma = $gamma, nu = $nupos with $msg, skipping "
|
|
continue
|
|
}
|
|
switch $detmode {
|
|
single {
|
|
xxxscan clear
|
|
xxxscan add $ommot $omstart $omstep
|
|
catch {xxxscan run $omnp $mode $preset} msg
|
|
set interrupt [getint]
|
|
if {[string first continue $interrupt] < 0} {
|
|
error $msg
|
|
}
|
|
clientput "scan completed"
|
|
set peaks [split [findpeaksinscan] ,]
|
|
clientput "findpeakscan completed"
|
|
if {[llength $peaks] > 0} {
|
|
foreach p $peaks {
|
|
drive $ommot $p
|
|
centerref $preset $mode
|
|
refadd ang
|
|
incr count
|
|
if {$count >= $maxpeak} {
|
|
return "Found $maxpeak reflections, terminating..."
|
|
}
|
|
}
|
|
}
|
|
}
|
|
area {
|
|
xxxscan clear
|
|
xxxscan add $ommot $omstart $omstep
|
|
catch {xxxscan run $omnp $mode $preset} msg
|
|
set interrupt [getint]
|
|
if {[string first continue $interrupt] < 0} {
|
|
error $msg
|
|
}
|
|
}
|
|
default {
|
|
error "Reflection search not supported for this detector mode"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
#--------------------------------------------------------------------------------------
|
|
proc noop argv {
|
|
error "Operation not supported"
|
|
}
|
|
#--------------------------------------------------------------------------------------
|
|
proc noopr {} {
|
|
error "Operation not supported"
|
|
}
|
|
#-------------------------------------------------------------------------------------
|
|
proc psidrive {target} {
|
|
global __psihkl __psitarget
|
|
set h [lindex $__psihkl 0]
|
|
set k [lindex $__psihkl 1]
|
|
set l [lindex $__psihkl 2]
|
|
set __psitarget $target
|
|
set status [catch {hkl calc $h $k $l $target} result]
|
|
if {$status != 0} {
|
|
clienput "Cannot drive to $h, $k, $l, psi = $target"
|
|
setint aportop
|
|
}
|
|
set l [split $result ,]
|
|
set result ""
|
|
set val [string trim [SplitReply [lindex $l 0]]]
|
|
set mot [singlex motnam stt]
|
|
append result "$mot=$val"
|
|
set val [string trim [SplitReply [lindex $l 1]]]
|
|
set mot [singlex motnam om]
|
|
append result ",$mot=$val"
|
|
set val [string trim [SplitReply [lindex $l 2]]]
|
|
set mot [singlex motnam chi]
|
|
append result ",$mot=$val"
|
|
set val [string trim [SplitReply [lindex $l 3]]]
|
|
set mot [singlex motnam phi]
|
|
append result ",$mot=$val"
|
|
return $result
|
|
}
|
|
#-------------------------------------------------------------------------------------
|
|
proc psiread {} {
|
|
global __psitarget
|
|
if {[info exists __psitarget] } {
|
|
return $__psitarget
|
|
} else {
|
|
return 0
|
|
}
|
|
}
|
|
#---------------------------------------------------------------------------------
|
|
proc psiprepare {obj userdata} {
|
|
global stdscangraph
|
|
stdscan noncheckprepare $obj $userdata
|
|
catch {hupdate $stdscangraph/dim}
|
|
}
|
|
#--------------------------------------------------------------------------
|
|
proc psicollect {obj userdata np} {
|
|
global stdscangraph
|
|
stdscan collect $obj $userdata $np
|
|
catch {hupdate $stdscangraph/scan_variable}
|
|
catch {hupdate $stdscangraph/counts}
|
|
}
|
|
#----------------------------------------------------------------------------
|
|
proc configurepsiscan {} {
|
|
xxxscan configure script
|
|
xxxscan function writeheader stdscan writeheader
|
|
xxxscan function prepare psiprepare
|
|
xxxscan function drive stdscan drive
|
|
xxxscan function count stdscan count
|
|
xxxscan function collect psicollect
|
|
xxxscan function writepoint stdscan writepoint
|
|
xxxscan function finish stdscan finish
|
|
}
|
|
#---------------------------------------------------------------------------------------
|
|
# This version is for well positioning instruments
|
|
#---------------------------------------------------------------------------------------
|
|
proc psiscanold {h k l step preset {countmode NULL}} {
|
|
global __psihkl __psistep
|
|
|
|
set mode [SplitReply [singlex mode]]
|
|
if {[string first bi $mode] < 0} {
|
|
error "PSI scans are only supported in bisecting mode"
|
|
}
|
|
set detmode [string trim [SplitReply [detmode]]]
|
|
if {[string first single $detmode] < 0} {
|
|
error "PSI scans are only supported in single detector mode"
|
|
}
|
|
|
|
set np [expr int((360./$step) + 1)]
|
|
if {[string compare $countmode NULL] == 0} {
|
|
set countmode [string trim [SplitReply [counter getmode]]]
|
|
}
|
|
set __psihkl [list $h $k $l]
|
|
set __psistep $step
|
|
psi drivescript psidrive
|
|
psi readscript psiread
|
|
xxxscan clear
|
|
configurepsiscan
|
|
xxxscan add psi 0 $step
|
|
xxxscan log [singlex motnam stt]
|
|
xxxscan log [singlex motnam om]
|
|
xxxscan log [singlex motnam chi]
|
|
xxxscan log [singlex motnam phi]
|
|
set status [catch {xxxscan run $np $countmode $preset} result]
|
|
psi drivescript noop
|
|
psi readscript noopr
|
|
configurestdscan
|
|
if {$status != 0} {
|
|
error $result
|
|
} else {
|
|
return $result
|
|
}
|
|
}
|
|
#---------------------------------------------------------------------------------------
|
|
# This is a new version which performs a cscan in om at each point in psi and
|
|
# stores the result into a ccl file.
|
|
#---------------------------------------------------------------------------------------
|
|
proc psiscan {h k l step stepom omnp preset {countmode NULL}} {
|
|
set mode [SplitReply [singlex mode]]
|
|
if {[string first bi $mode] < 0} {
|
|
error "PSI scans are only supported in bisecting mode"
|
|
}
|
|
set detmode [string trim [SplitReply [detmode]]]
|
|
if {[string first single $detmode] < 0} {
|
|
error "PSI scans are only supported in single detector mode"
|
|
}
|
|
|
|
set np [expr int((360./$step) + 1)]
|
|
if {[string compare $countmode NULL] == 0} {
|
|
set countmode [string trim [SplitReply [counter getmode]]]
|
|
}
|
|
xxxscan clear
|
|
configuremessscan
|
|
fmess start [newFileName]
|
|
set np [expr int(360./$step) + 1]
|
|
for {set i 0} {$i < $np} {incr i} {
|
|
set psi [expr $i * $step]
|
|
set status [catch {hkl drive $h $k $l $psi} msg]
|
|
if {$status != 0 || [string first ERROR $msg] >= 0 } {
|
|
set rupt [getint]
|
|
switch $rupt {
|
|
continue -
|
|
abortop {
|
|
setint continue
|
|
clientput "Cannot reach psi: $psi, skipping"
|
|
continue
|
|
}
|
|
default {
|
|
clientput $msg
|
|
break
|
|
}
|
|
}
|
|
}
|
|
clientput "Scanning at $psi"
|
|
set ompos [string trim [SplitReply [om]]]
|
|
set status [catch {cscan om $ompos $stepom $omnp $preset} msg]
|
|
if {$status != 0} {
|
|
set rupt [getint]
|
|
if {[string compare $rupt continue] != 0} {
|
|
clientput $msg
|
|
break
|
|
} else {
|
|
clientput "ERROR: $msg while scanning"
|
|
}
|
|
}
|
|
set stt [SplitReply [stt]]
|
|
set chi [SplitReply [chi]]
|
|
set phi [SplitReply [phi]]
|
|
fmess storeextra $h $k $l $stt $ompos $chi $phi $psi
|
|
}
|
|
fmess close
|
|
configurestdscan
|
|
return Done
|
|
}
|
|
#---------------------------------------------------------------------------
|
|
proc bitonb {stt om chi phi} {
|
|
return [hkl bitonb $stt $om $ch $phi]
|
|
}
|
|
#---------------------------------------------------------------------------
|
|
proc varToCom {var} {
|
|
set reply [$var]
|
|
return [string map {= " "} $reply]
|
|
}
|
|
#---------------------------------------------------------------------------
|
|
proc savexxx {filename} {
|
|
append fname [string trim [SplitReply [exe batchpath]]] / $filename
|
|
set status [catch {open $fname w} out]
|
|
if {$status != 0} {
|
|
error "Failed to open $fname"
|
|
}
|
|
puts $out [varToCom title]
|
|
puts $out [varToCom sample]
|
|
puts $out [varToCom lambda]
|
|
puts $out [varToCom cell]
|
|
puts $out [varToCom spgrp]
|
|
puts $out [varToCom ub]
|
|
|
|
puts $out [varToCom coneconf]
|
|
set reply [SplitReply [indexconf]]
|
|
puts $out "indexconf $reply"
|
|
set reply [SplitReply [hkllimit]]
|
|
puts $out "hkllimit $reply"
|
|
|
|
puts $out refclear
|
|
set reflist [split [ref names] \n]
|
|
foreach ref $reflist {
|
|
if {[string length $ref] < 2} {
|
|
continue
|
|
}
|
|
set txt [ref show [string trim $ref]]
|
|
set txtlist [split $txt]
|
|
set outlist [lrange $txtlist 2 end]
|
|
puts $out "ref addax [join $outlist]"
|
|
}
|
|
|
|
puts $out "fmess table clear"
|
|
set table [fmess table print]
|
|
set tblist [split $table "\n"]
|
|
for {set i 1} {$i < [llength $tblist]} {incr i} {
|
|
set line [lindex $tblist $i]
|
|
set line [string trim [regsub -all "\\s+" $line " "]]
|
|
if {[string length $line] < 2} {
|
|
continue
|
|
}
|
|
set l [split $line]
|
|
puts $out "fmess table addrow [join [lrange $l 1 end]]"
|
|
}
|
|
|
|
|
|
close $out
|
|
return "Done"
|
|
}
|
|
#======================================================================================
|
|
# Stuff to support Hipadaba
|
|
#======================================================================================
|
|
proc ubrefinehdb args {
|
|
set path /instrument/reflection_list/ubrefresult
|
|
set status [catch {ubrefine} msg]
|
|
if {[string length $msg] < 10} {
|
|
set msg "ubrefine produced no output, check raf*.lis in projectdir yourself!"
|
|
}
|
|
hset $path $msg
|
|
}
|
|
#--------------------------------------------------------------------------------------
|
|
proc runindex {sttlim anglim} {
|
|
indexconf $sttlim $anglim
|
|
catch {capture simidx run} result
|
|
set result [string map {ERROR PROBLEM} $result]
|
|
hupdate /instrument/reflection_list/indexresult $result
|
|
return Done
|
|
}
|
|
#-----------------------------------------------------------------------------------------
|
|
proc makeHipadabaReflectionList {} {
|
|
hfactory /instrument/reflection_list plain spy none
|
|
hfactory /instrument/reflection_list/list link ref
|
|
hsetprop /instrument/reflection_list/list viewer mountaingumui.TableEditor
|
|
hsetprop /instrument/reflection_list/list type part
|
|
hsetprop /instrument/reflection_list/list/addrow sicscommand "ref addrow"
|
|
hsetprop /instrument/reflection_list/list/clear sicscommand "ref clear"
|
|
hsetprop /instrument/reflection_list/list/del sicscommand "ref del"
|
|
hsetprop /instrument/reflection_list/list sicscommand ref
|
|
hfactory /instrument/reflection_list/list/calcub command calcub
|
|
hsetprop /instrument/reflection_list/list/calcub type command
|
|
hsetprop /instrument/reflection_list/list/calcub priv user
|
|
hsetprop /instrument/reflection_list/list/calcub tablecommand true
|
|
hsetprop /instrument/reflection_list/list/calcub sicscommand calcub
|
|
hfactory /instrument/reflection_list/list/calcub/args plain user text
|
|
|
|
hfactory /instrument/reflection_list/ubrefine command ubrefinehdb
|
|
hsetprop /instrument/reflection_list/ubrefine viewer mountaingumui.ubrefine
|
|
hsetprop /instrument/reflection_list/ubrefine type command
|
|
hsetprop /instrument/reflection_list/ubrefine priv user
|
|
hsetprop /instrument/reflection_list/ubrefine sicscommand ubrefinehdb
|
|
|
|
hfactory /instrument/reflection_list/ubrefresult plain user text
|
|
hsetprop /instrument/reflection_list/ubrefresult visible false
|
|
|
|
hfactory /instrument/reflection_list/loadub command loadub
|
|
hsetprop /instrument/reflection_list/loadub type command
|
|
hsetprop /instrument/reflection_list/loadub priv user
|
|
hsetprop /instrument/reflection_list/loadub sicscommand loadub
|
|
hsetprop /instrument/reflection_list/loadub visible false
|
|
|
|
|
|
set names [hlist /instrument/reflection_list/list]
|
|
set l [split $names '\n']
|
|
foreach n $l {
|
|
if {[string compare $n data] != 0} {
|
|
hsetprop /instrument/reflection_list/list/${n} visible false
|
|
}
|
|
}
|
|
hdelprop /instrument/reflection_list/list visible
|
|
|
|
hfactory /instrument/reflection_list/index command runindex
|
|
hsetprop /instrument/reflection_list/index viewer mountaingumui.index
|
|
hsetprop /instrument/reflection_list/index type command
|
|
hsetprop /instrument/reflection_list/index priv user
|
|
hsetprop /instrument/reflection_list/index sicscommand runindex
|
|
hfactory /instrument/reflection_list/index/sttlim plain user float
|
|
hfactory /instrument/reflection_list/index/anglim plain user float
|
|
|
|
hfactory /instrument/reflection_list/indexresult plain user text
|
|
hsetprop /instrument/reflection_list/indexresult visible false
|
|
hfactory /instrument/reflection_list/indexmax alias /sics/simidx/nsolutions
|
|
hsetprop /instrument/reflection_list/indexmax visible false
|
|
|
|
hfactory /instrument/reflection_list/choose command indexub
|
|
hsetprop /instrument/reflection_list/choose type command
|
|
hsetprop /instrument/reflection_list/choose priv user
|
|
hsetprop /instrument/reflection_list/choose sicscommand indexub
|
|
hsetprop /instrument/reflection_list/choose visible false
|
|
hfactory /instrument/reflection_list/choose/sel plain user int
|
|
|
|
hfactory /instrument/reflection_list/centerlist command centerlist
|
|
hsetprop /instrument/reflection_list/centerlist type command
|
|
hsetprop /instrument/reflection_list/centerlist priv user
|
|
hsetprop /instrument/reflection_list/centerlist sicscommand centerlist
|
|
hfactory /instrument/reflection_list/centerlist/preset plain user float
|
|
hset /instrument/reflection_list/centerlist/preset 20000
|
|
hfactory /instrument/reflection_list/centerlist/mode plain user text
|
|
hsetprop /instrument/reflection_list/centerlist/mode values Monitor,Timer
|
|
hfactory /instrument/reflection_list/centerlist/skip plain user int
|
|
hset /instrument/reflection_list/centerlist/skip 0
|
|
|
|
}
|