265 lines
7.8 KiB
Tcl
265 lines
7.8 KiB
Tcl
#----------------------------------------------------------------------
|
|
# This is a set of regression tests for the tasub module.
|
|
# This module does the UB matrix algorithm as described by Mark Lumsden
|
|
# triple axis spectrometers.
|
|
#
|
|
# Mark Koennecke, November 2006
|
|
#----------------------------------------------------------------------
|
|
puts stdout "Testing Tasub"
|
|
#----------------------------------------------------------------------
|
|
# testTasubCalculation tests the tasub calculation. The input is a list
|
|
# containg the cell constants and two lists denoting reflections.
|
|
# For each reflection the list must hold:
|
|
# 0 1 2 3 4 5 6 7 8 9 10 11 12
|
|
# qh qk ql ei ef a1 a2 a3 a4 sgu sgl a5 a6
|
|
# testTasubCalculation then inputs the cell and the reflections into
|
|
# tasub and calculates a UB from that. Then it tries to drive to the
|
|
# QE positions given for the reflections and checks if the angles are right
|
|
# It also checks QE positions in order to check if they have been properly
|
|
# updated.
|
|
# This then can be used with various inputs to check various configurations
|
|
# of the instrument.
|
|
#----------------------------------------------------------------------
|
|
proc testTasubCalculation {cell ref1 ref2} {
|
|
if {[llength $cell] < 6} {
|
|
error "Not enough cell parameters"
|
|
}
|
|
if {[llength $ref1] < 13} {
|
|
error "Not enough parameters for reflection 1"
|
|
}
|
|
if {[llength $ref2] < 13} {
|
|
error "Not enough parameters for reflection 2"
|
|
}
|
|
checkSettingCell $cell
|
|
checkMakeUB $ref1 $ref2
|
|
checkDrivingReflection $ref1
|
|
checkDrivingReflection $ref2
|
|
}
|
|
#-------------------------------------------------------------------
|
|
proc checkSettingCell {cell} {
|
|
config rights Mugger Mugger
|
|
append cmd "tasub cell " [join $cell]
|
|
testOK $cmd
|
|
set readback [string trim [SICSValue "tasub cell"]]
|
|
set l [split $readback]
|
|
for {set i 0} {$i < [llength $cell]} {incr i} {
|
|
set ori [lindex $cell $i]
|
|
set val [lindex $l $i]
|
|
if {abs($ori - $val) > .01} {
|
|
error "Bad cell readback, in $cell, back $readback"
|
|
}
|
|
}
|
|
}
|
|
#---------------------------------------------------------------------
|
|
proc checkMakeUB {ref1 ref2} {
|
|
checkOK "tasub clear"
|
|
set cmd [format "tasub addref %f %f %f %f %f %f %f %f %f" \
|
|
[lindex $ref1 0] [lindex $ref1 1] [lindex $ref1 2] \
|
|
[lindex $ref1 7] [lindex $ref1 8] [lindex $ref1 9] \
|
|
[lindex $ref1 10] \
|
|
[lindex $ref1 3] [lindex $ref1 4]]
|
|
eval $cmd
|
|
set cmd [format "tasub addref %f %f %f %f %f %f %f %f %f" \
|
|
[lindex $ref2 0] [lindex $ref2 1] [lindex $ref2 2] \
|
|
[lindex $ref2 7] [lindex $ref2 8] [lindex $ref2 9] \
|
|
[lindex $ref2 10] \
|
|
[lindex $ref2 3] [lindex $ref2 4]]
|
|
eval $cmd
|
|
set test [tasub makeub 1 2]
|
|
if {[string first ERROR $test] > 0} {
|
|
error "Problem calculating UB: $test"
|
|
}
|
|
}
|
|
#--------------------------------------------------------------------
|
|
proc checkDrivingReflection {ref} {
|
|
set cmd [format "drive qh %f qk %f ql %f ei %f ef %f" \
|
|
[lindex $ref 0] [lindex $ref 1] [lindex $ref 2] \
|
|
[lindex $ref 3] [lindex $ref 4]]
|
|
set test [eval $cmd]
|
|
puts $cmd
|
|
if {[string first ERROR $test] >= 0} {
|
|
error "Failed to drive reflection: $test"
|
|
}
|
|
set a1 [SICSValue a1]
|
|
set a1soll [lindex $ref 5]
|
|
if {abs($a1soll - $a1) >.01} {
|
|
error "Bad a1 position, should $a1soll, is $a1"
|
|
}
|
|
set a1 [SICSValue a1]
|
|
set a1soll [lindex $ref 5]
|
|
if {abs($a1soll - $a1) >.01} {
|
|
error "Bad a1 position, should $a1soll, is $a1"
|
|
}
|
|
set a2 [SICSValue a2]
|
|
set a2soll [lindex $ref 6]
|
|
if {abs($a2soll - $a2) >.01} {
|
|
error "Bad a2 position, should $a2soll, is $a2"
|
|
}
|
|
set a3 [SICSValue a3]
|
|
set a3soll [lindex $ref 7]
|
|
if {abs($a3soll - $a3) >.01} {
|
|
error "Bad a3 position, should $a3soll, is $a3"
|
|
}
|
|
set a4 [SICSValue a4]
|
|
set a4soll [lindex $ref 8]
|
|
if {abs($a4soll - $a4) >.01} {
|
|
error "Bad a4 position, should $a4soll, is $a4"
|
|
}
|
|
set sgu [SICSValue sgu]
|
|
set sgusoll [lindex $ref 9]
|
|
if {abs($sgusoll - $sgu) >.01} {
|
|
error "Bad sgu position, should $sgusoll, is $sgu"
|
|
}
|
|
set sgl [SICSValue sgl]
|
|
set sglsoll [lindex $ref 10]
|
|
if {abs($sglsoll - $sgl) >.01} {
|
|
error "Bad sgl position, should $sglsoll, is $sgl"
|
|
}
|
|
set a5 [SICSValue a5]
|
|
set a5soll [lindex $ref 11]
|
|
if {abs($a5soll - $a5) >.01} {
|
|
error "Bad a5 position, should $a5soll, is $a5"
|
|
}
|
|
set a6 [SICSValue a6]
|
|
set a6soll [lindex $ref 12]
|
|
if {abs($a6soll - $a6) >.01} {
|
|
error "Bad a6 position, should $a6soll, is $a6"
|
|
}
|
|
|
|
set qh [SICSValue qh]
|
|
set qhsoll [lindex $ref 0]
|
|
if {abs($qhsoll - $qh) >.01} {
|
|
error "Bad qh position, should $qhsoll, is $qh"
|
|
}
|
|
set qk [SICSValue qk]
|
|
set qksoll [lindex $ref 1]
|
|
if {abs($qksoll - $qk) >.01} {
|
|
error "Bad qk position, should $qksoll, is $qk"
|
|
}
|
|
set ql [SICSValue ql]
|
|
set qlsoll [lindex $ref 2]
|
|
if {abs($qlsoll - $ql) >.01} {
|
|
error "Bad ql position, should $qlsoll, is $ql"
|
|
}
|
|
|
|
set ei [SICSValue ei]
|
|
set eisoll [lindex $ref 3]
|
|
if {abs($eisoll - $ei) >.01} {
|
|
error "Bad ei position, should $eisoll, is $ei"
|
|
}
|
|
set ef [SICSValue ef]
|
|
set efsoll [lindex $ref 4]
|
|
if {abs($efsoll - $ef) >.01} {
|
|
error "Bad ef position, should $efsoll, is $ef"
|
|
}
|
|
}
|
|
#===================== tests =========================================
|
|
test tasub-1.0 {Test setting dd} -body {
|
|
testPar "tasub mono dd" 3.35461 Mugger
|
|
testPar "tasub ana dd" 3.35461 Mugger
|
|
return OK
|
|
} -result OK
|
|
|
|
test tasub-1.1 {Test setting ss} -body {
|
|
testPar "tasub mono ss" 1 Mugger
|
|
testPar "tasub ana ss" 1 Mugger
|
|
return OK
|
|
} -result OK
|
|
|
|
test tasub-1.2 {Test setting sample configuration} -body {
|
|
testPar "tasub const" kf Mugger
|
|
testPar "tasub ss" -1 Mugger
|
|
return OK
|
|
} -result OK
|
|
|
|
test tasub-1.3 {Test clearing tasub} -body {
|
|
testOK "tasub clear"
|
|
return OK
|
|
} -result OK
|
|
|
|
test tasub-1.4 {Test setting cell} -body {
|
|
checkSettingCell [list 7. 7. 7. 90. 90. 90.]
|
|
return OK
|
|
} -result OK
|
|
|
|
tasub mono dd 3.35461
|
|
tasub ana dd 3.35461
|
|
tasub mono ss 1
|
|
tasub ana ss 1
|
|
tasub const kf
|
|
tasub ss -1
|
|
|
|
test tasub-1.5 {Basic calculation test} -body {
|
|
set ref1 [list 1 0 0 5 5 37.075 74.150 168.27 -23.46 0 0 37.075 74.15]
|
|
set ref2 [list 0 0 1 5 5 37.075 74.150 84.78 -10.44 0 0 37.075 74.15]
|
|
set cell [list 9.95 9.95 22.24 90 90 90]
|
|
testTasubCalculation $cell $ref1 $ref2
|
|
return OK
|
|
} -result OK
|
|
|
|
|
|
test tasub-1.6 {Test driving ei} -body {
|
|
drive ei 5.0
|
|
set eit [SICSValue ei]
|
|
set a1 [SICSValue a1]
|
|
set a2 [SICSValue a2]
|
|
if {abs(5 - $eit) > .001} {
|
|
error "Readback of ei failed"
|
|
}
|
|
if {abs(37.07 - $a1) > .01} {
|
|
error "Bad a1 value, is $a1, should 37.07"
|
|
}
|
|
if {abs(74.15 - $a2) > .01} {
|
|
error "Bad a2 value, is $a2, should 74.15"
|
|
}
|
|
return OK
|
|
} -result OK
|
|
|
|
test tasub-1.7 {Test driving ef} -body {
|
|
drive ef 5.
|
|
set eit [SICSValue ef]
|
|
set a1 [SICSValue a5]
|
|
set a2 [SICSValue a6]
|
|
if {abs(5. - $eit) > .001} {
|
|
error "Readback of ei failed"
|
|
}
|
|
if {abs(37.07 - $a1) > .01} {
|
|
error "Bad a5 value, is $a1, should 37.07"
|
|
}
|
|
if {abs(74.15 - $a2) > .01} {
|
|
error "Bad a6 value, is $a2, should 74.15"
|
|
}
|
|
return OK
|
|
} -result OK
|
|
|
|
test tasub-1.8 {Test reading en} -body {
|
|
drive ei 5. ef 3.7
|
|
set en [SICSValue en]
|
|
if {abs($en - 1.3) > .01} {
|
|
error "Bad en value: should: 1.3, is $en"
|
|
}
|
|
return OK
|
|
} -result OK
|
|
|
|
test tasub-1.9 {Test driving ef, different scattering sense} -body {
|
|
tasub ana ss -1
|
|
drive ef 5.0
|
|
set eit [SICSValue ef]
|
|
set a1 [SICSValue a5]
|
|
set a2 [SICSValue a6]
|
|
if {abs(5 - $eit) > .001} {
|
|
error "Readback of ef failed"
|
|
}
|
|
if {abs(-37.07 - $a1) > .01} {
|
|
error "Bad a5 value, is $a1, should -37.07"
|
|
}
|
|
if {abs(-74.15 - $a2) > .01} {
|
|
error "Bad a6 value, is $a2, should -74.15"
|
|
}
|
|
return OK
|
|
} -result OK
|
|
|
|
|
|
|
|
|
|
|