527
tcl/astrium.tcl
527
tcl/astrium.tcl
@ -1,527 +0,0 @@
|
||||
#--------------------------------------------------------------
|
||||
# This is a new style driver for the Astrium chopper systems in
|
||||
# the new sicsobj/scriptcontext based system. Please note that
|
||||
# actual implementations may differ in the number of choppers
|
||||
# and the address of the chopper on the network.
|
||||
#
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# SCRIPT CHAINS:
|
||||
# - reading parameters:
|
||||
# astchopread - readastriumchopperpar - readastriumchopperpar - ...
|
||||
# - writing
|
||||
# astchopwrite - astchopwritereply
|
||||
#
|
||||
# Another remark:
|
||||
# In order for chosta to work properly, the chopperparlist and
|
||||
# chopperlonglist must be aligned.
|
||||
#
|
||||
# Mark Koennecke, February 2009
|
||||
#
|
||||
# If something goes wrong with this, the following things ought
|
||||
# to be checked:
|
||||
# - Is the standard Tcl scan command been properly renamed to stscan?
|
||||
# - Is a communication possible with the chopper via telnet?
|
||||
# This may not be the case because of other SICS servers blocking
|
||||
# things or the old driver being active and capturing the terminal
|
||||
# server port in SerPortServer. Scriptcontext then fails silently.
|
||||
# But may be we will fix the latter.
|
||||
# - The other thing which happens is that the parameter list of
|
||||
# the chopper differs in little ways between instances.
|
||||
#
|
||||
# Mark Koennecke, April 2009
|
||||
#--------------------------------------------------------------
|
||||
MakeSICSObj choco AstriumChopper
|
||||
#-------------------------------------------------------------
|
||||
proc astriumchopperputerror {txt} {
|
||||
global choppers chopperparlist
|
||||
foreach chopper $choppers {
|
||||
foreach par $chopperparlist {
|
||||
set path /sics/choco/${chopper}/${par}
|
||||
hsetprop $path geterror $txt
|
||||
}
|
||||
}
|
||||
}
|
||||
#--------------------------------------------------------------
|
||||
# Paramamters look like: name value, entries for parameters are
|
||||
# separated by ;
|
||||
#---------------------------------------------------------------
|
||||
proc astriumsplitreply {chopper reply} {
|
||||
set parlist [split [string trim $reply] ";"]
|
||||
foreach par $parlist {
|
||||
catch {stscan $par "%s %s" token val} count
|
||||
if {[string first ERROR $count] < 0 && $count == 2} {
|
||||
set val [string trim $val]
|
||||
set token [string trim $token]
|
||||
catch {hupdate /sics/choco/${chopper}/${token} $val}
|
||||
catch {hdelprop /sics/choco/${chopper}/${token} geterror}
|
||||
} else {
|
||||
#-------- special fix for dphas and averl
|
||||
if {[string first dphas $par] >= 0} {
|
||||
set val [string range $par 5 end]
|
||||
if {$val > 360} {
|
||||
set val [expr $val -360.]
|
||||
}
|
||||
hupdate /sics/choco/${chopper}/dphas $val
|
||||
hdelprop /sics/choco/${chopper}/dphas geterror
|
||||
}
|
||||
if {[string first averl $par] >= 0} {
|
||||
set val [string range $par 5 end]
|
||||
hupdate /sics/choco/${chopper}/averl $val
|
||||
hdelprop /sics/choco/${chopper}/averl geterror
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#-------------------------------------------------------------
|
||||
# update those parameters which are dependent on the chopper
|
||||
# status just read. Some of them may or may not be there, this
|
||||
# is why this is protected by catch'es.
|
||||
#-------------------------------------------------------------
|
||||
proc astcopydependentpar {} {
|
||||
global choppers
|
||||
foreach chop $choppers {
|
||||
set val [hval /sics/choco/${chop}/aspee]
|
||||
catch {hupdate /sics/choco/${chop}/speed $val}
|
||||
set val [hval /sics/choco/${chop}/nphas]
|
||||
set dp [hval /sics/choco/${chop}/dphas]
|
||||
set val [expr $val + $dp]
|
||||
catch {hupdate /sics/choco/${chop}/phase $val}
|
||||
}
|
||||
}
|
||||
#--------------------------------------------------------------
|
||||
proc readastriumchopperpar {} {
|
||||
global choppers
|
||||
set reply [sct result]
|
||||
if {[string first ERR $reply] >= 0} {
|
||||
astriumchopperputerror $reply
|
||||
return idle
|
||||
}
|
||||
if {[string first "not valid" $reply] >= 0 } {
|
||||
astriumchopperputerror "ERROR: chopper responded with not valid"
|
||||
return idle
|
||||
}
|
||||
set count [sct replycount]
|
||||
if {$count == -1} {
|
||||
sct send @@NOSEND@@
|
||||
sct replycount 0
|
||||
hupdate /sics/choco/asyst ""
|
||||
hdelprop /sics/choco/asyst geterror
|
||||
return astchoppar
|
||||
} else {
|
||||
set oldval [hval /sics/choco/asyst]
|
||||
hupdate /sics/choco/asyst "$oldval $reply"
|
||||
astriumsplitreply [lindex $choppers $count] $reply
|
||||
incr count
|
||||
sct replycount $count
|
||||
if {$count < [llength $choppers] } {
|
||||
sct send @@NOSEND@@
|
||||
return astchoppar
|
||||
} else {
|
||||
astcopydependentpar
|
||||
return idle
|
||||
}
|
||||
}
|
||||
}
|
||||
#--------------------------------------------------------------
|
||||
proc astchopread {} {
|
||||
sct send "asyst 1"
|
||||
sct replycount -1
|
||||
return astchoppar
|
||||
}
|
||||
#---------------------------------------------------------------
|
||||
proc astriumMakeChopperParameters {} {
|
||||
global choppers chopperparlist
|
||||
foreach chopper $choppers {
|
||||
hfactory /sics/choco/${chopper} plain spy none
|
||||
foreach par $chopperparlist {
|
||||
set path /sics/choco/${chopper}/${par}
|
||||
hfactory $path plain internal text
|
||||
chocosct connect $path
|
||||
}
|
||||
}
|
||||
hfactory /sics/choco/asyst plain user text
|
||||
hsetprop /sics/choco/asyst read astchopread
|
||||
hsetprop /sics/choco/asyst astchoppar readastriumchopperpar
|
||||
hfactory /sics/choco/stop plain user int
|
||||
chocosct poll /sics/choco/asyst 60
|
||||
#--------- This is for debugging
|
||||
# chocosct poll /sics/choco/asyst 10
|
||||
}
|
||||
#=================== write support ==============================
|
||||
proc astchopwrite {prefix} {
|
||||
set val [sct target]
|
||||
sct send "$prefix $val"
|
||||
sct writestart 1
|
||||
hupdate /sics/choco/stop 0
|
||||
return astchopwritereply
|
||||
}
|
||||
#----------------------------------------------------------------
|
||||
# Make sure to send a status request immediatly after a reply in
|
||||
# order to avoid timing problems
|
||||
#----------------------------------------------------------------
|
||||
proc astchopwritereply {} {
|
||||
set reply [sct result]
|
||||
if {[string first ERR $reply] >= 0} {
|
||||
sct print $reply
|
||||
hupdate /sics/choco/stop 1
|
||||
return idle
|
||||
}
|
||||
if {[string first "chopper error" $reply] >= 0} {
|
||||
sct print "ERROR: $reply"
|
||||
hupdate /sics/choco/stop 1
|
||||
return idle
|
||||
}
|
||||
if {[string first "not valid" $reply] >= 0 } {
|
||||
sct print "ERROR: chopper responded with not valid"
|
||||
hupdate /sics/choco/stop 1
|
||||
return idle
|
||||
}
|
||||
set state [sct writestart]
|
||||
if {$state == 1} {
|
||||
sct writestart 0
|
||||
sct send "asyst 1"
|
||||
sct replycount -1
|
||||
return astchopwritereply
|
||||
} else {
|
||||
set status [readastriumchopperpar]
|
||||
if {[string first idle $status] >= 0} {
|
||||
return idle
|
||||
} else {
|
||||
return astchopwritereply
|
||||
}
|
||||
}
|
||||
}
|
||||
#--------------------------------------------------------------------
|
||||
proc astchopcompare {path1 path2 delta} {
|
||||
set v1 [hval $path1]
|
||||
set v2 [hval $path2]
|
||||
if {abs($v1 - $v2) < $delta} {
|
||||
return 1
|
||||
} else {
|
||||
return 0
|
||||
}
|
||||
}
|
||||
#--------------------------------------------------------------------
|
||||
proc astchopcheckspeed {chopper} {
|
||||
set stop [hval /sics/choco/stop]
|
||||
if {$stop == 1} {
|
||||
return fault
|
||||
}
|
||||
chocosct queue /sics/choco/asyst progress read
|
||||
set tg [sct target]
|
||||
set p1 /sics/choco/${chopper}/nspee
|
||||
set p2 /sics/choco/${chopper}/aspee
|
||||
set tst [astchopcompare $p1 $p2 50]
|
||||
if {$tst == 1 } {
|
||||
wait 1
|
||||
return idle
|
||||
} else {
|
||||
return busy
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------------------
|
||||
proc astchopcheckphase {chopper} {
|
||||
set stop [hval /sics/choco/stop]
|
||||
if {$stop == 1} {
|
||||
return fault
|
||||
}
|
||||
chocosct queue /sics/choco/asyst progress read
|
||||
set p2 [hval /sics/choco/${chopper}/dphas]
|
||||
if {abs($p2) < .03} {
|
||||
wait 15
|
||||
return idle
|
||||
} else {
|
||||
return busy
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------------------
|
||||
proc astchopcheckratio {} {
|
||||
global choppers
|
||||
set stop [hval /sics/choco/stop]
|
||||
if {$stop == 1} {
|
||||
return fault
|
||||
}
|
||||
set ch1 [lindex $choppers 0]
|
||||
set ch2 [lindex $choppers 1]
|
||||
chocosct queue /sics/choco/asyst progress read
|
||||
set p1 [hval /sics/choco/${ch1}/aspee]
|
||||
set p2 [hval /sics/choco/${ch2}/aspee]
|
||||
set target [sct target]
|
||||
if {$p2 < 10} {
|
||||
return busy
|
||||
}
|
||||
if {abs($p1/$p2 - $target*1.) < .3} {
|
||||
set tst 1
|
||||
} else {
|
||||
set tst 0
|
||||
}
|
||||
if {$tst == 1 } {
|
||||
wait 1
|
||||
return idle
|
||||
} else {
|
||||
return busy
|
||||
}
|
||||
}
|
||||
#----------------------------------------------------------------------
|
||||
proc astchopstop {} {
|
||||
sct print "No real way to stop choppers but I will release"
|
||||
sct send @@NOSEND@@
|
||||
hupdate /sics/choco/stop 1
|
||||
return idle
|
||||
}
|
||||
#---------------------------------------------------------------------
|
||||
proc astspeedread {chopper} {
|
||||
set val [hval /sics/choco/${chopper}/aspee]
|
||||
sct update $val
|
||||
sct send @@NOSEND@@
|
||||
return idle
|
||||
}
|
||||
#---------------------------------------------------------------------
|
||||
proc astchopspeedlimit {chidx} {
|
||||
global choppers maxspeed
|
||||
set chname [lindex $choppers $chidx]
|
||||
set val [sct target]
|
||||
if {$val < 0 || $val > $maxspeed} {
|
||||
error "Desired chopper speed out of range"
|
||||
}
|
||||
if {$chidx > 0} {
|
||||
set state [hval /sics/choco/${chname}/state]
|
||||
if {[string first async $state] < 0} {
|
||||
error "Chopper in wrong state"
|
||||
}
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#----------------------------------------------------------------------
|
||||
proc astMakeChopperSpeed1 {var} {
|
||||
global choppers
|
||||
set ch [lindex $choppers 0]
|
||||
set path /sics/choco/${ch}/speed
|
||||
hfactory $path plain mugger float
|
||||
hsetprop $path read astspeedread $ch
|
||||
hsetprop $path write astchopwrite "nspee 1 "
|
||||
hsetprop $path astchopwritereply astchopwritereply
|
||||
chocosct write $path
|
||||
hsetprop $path checklimits astchopspeedlimit 0
|
||||
hsetprop $path halt astchopstop
|
||||
hsetprop $path checkstatus astchopcheckspeed $ch
|
||||
hsetprop $path priv manager
|
||||
makesctdriveobj $var $path DriveAdapter chocosct
|
||||
}
|
||||
#----------------------------------------------------------------------
|
||||
proc astMakeChopperSpeed2 {var} {
|
||||
global choppers
|
||||
set ch [lindex $choppers 1]
|
||||
set path /sics/choco/${ch}/speed
|
||||
hfactory $path plain mugger float
|
||||
hsetprop $path read astspeedread $ch
|
||||
hsetprop $path write astchopwrite "nspee 2 "
|
||||
hsetprop $path astchopwritereply astchopwritereply
|
||||
chocosct write $path
|
||||
hsetprop $path checklimits astchopspeedlimit 0
|
||||
hsetprop $path halt astchopstop
|
||||
hsetprop $path checkstatus astchopcheckspeed $ch
|
||||
hsetprop $path priv manager
|
||||
makesctdriveobj $var $path DriveAdapter chocosct
|
||||
}
|
||||
#-----------------------------------------------------------------------
|
||||
proc astchopphaselimit {} {
|
||||
set val [sct target]
|
||||
if {$val < -359.9 || $val > 359.9} {
|
||||
error "chopper phase out of range"
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#---------------------------------------------------------------------
|
||||
proc astphaseread {chopper} {
|
||||
set val [hval /sics/choco/${chopper}/aphas]
|
||||
sct update $val
|
||||
sct send @@NOSEND@@
|
||||
return idle
|
||||
}
|
||||
#-----------------------------------------------------------------------
|
||||
proc astMakeChopperPhase1 {var} {
|
||||
global choppers
|
||||
set ch [lindex $choppers 0]
|
||||
set path /sics/choco/${ch}/phase
|
||||
hfactory $path plain mugger float
|
||||
hsetprop $path read astphaseread $ch
|
||||
hsetprop $path write astchopwrite "nphas 1 "
|
||||
hsetprop $path astchopwritereply astchopwritereply
|
||||
chocosct write $path
|
||||
hsetprop $path checklimits astchopphaselimit
|
||||
hsetprop $path halt astchopstop
|
||||
hsetprop $path checkstatus astchopcheckphase $ch
|
||||
hsetprop $path priv manager
|
||||
makesctdriveobj $var $path DriveAdapter chocosct
|
||||
}
|
||||
#-----------------------------------------------------------------------
|
||||
proc astMakeChopperPhase2 {var} {
|
||||
global choppers
|
||||
set ch [lindex $choppers 1]
|
||||
set path /sics/choco/${ch}/phase
|
||||
hfactory $path plain mugger float
|
||||
hsetprop $path read astphaseread $ch
|
||||
hsetprop $path write astchopwrite "nphas 2 "
|
||||
hsetprop $path astchopwritereply astchopwritereply
|
||||
chocosct write $path
|
||||
hsetprop $path checklimits astchopphaselimit
|
||||
hsetprop $path halt astchopstop
|
||||
hsetprop $path checkstatus astchopcheckphase $ch
|
||||
hsetprop $path priv manager
|
||||
makesctdriveobj $var $path DriveAdapter chocosct
|
||||
}
|
||||
#----------------------------------------------------------------------
|
||||
proc astchopratiolimit {} {
|
||||
set val [sct target]
|
||||
if {$val < 1} {
|
||||
error "Ratio out of range"
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#-----------------------------------------------------------------------
|
||||
proc astMakeChopperRatio {var} {
|
||||
global choppers
|
||||
set ch [lindex $choppers 1]
|
||||
set path /sics/choco/${ch}/Ratio
|
||||
hdel $path
|
||||
hfactory $path plain mugger float
|
||||
chocosct connect $path
|
||||
hsetprop $path write astchopwrite "ratio 2 "
|
||||
hsetprop $path astchopwritereply astchopwritereply
|
||||
chocosct write $path
|
||||
hsetprop $path checklimits astchopratiolimit
|
||||
hsetprop $path halt astchopstop
|
||||
hsetprop $path checkstatus astchopcheckratio
|
||||
makesctdriveobj $var $path DriveAdapter chocosct
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc chosta {} {
|
||||
global chopperlonglist chopperparlist choppers chopperheader
|
||||
set result "$chopperheader\n"
|
||||
append line [format "%-20s " ""]
|
||||
set count 1
|
||||
foreach ch $choppers {
|
||||
append line [format "%-20s " $ch]
|
||||
incr count
|
||||
}
|
||||
append result $line "\n"
|
||||
set nchop [llength $choppers]
|
||||
set len [llength $chopperlonglist]
|
||||
for {set i 0} {$i < $len} {incr i} {
|
||||
set line ""
|
||||
set par [lindex $chopperlonglist $i]
|
||||
append line [format "%-20s " $par]
|
||||
for {set n 0} {$n < $nchop} {incr n} {
|
||||
set chname [lindex $choppers $n]
|
||||
set parname [lindex $chopperparlist $i]
|
||||
set val [hval /sics/choco/${chname}/${parname}]
|
||||
append line [format "%-20s " $val]
|
||||
}
|
||||
append result $line "\n"
|
||||
}
|
||||
return $result
|
||||
}
|
||||
#======================= Configuration Section ==========================
|
||||
set amor 0
|
||||
set poldi 1
|
||||
set focus 0
|
||||
|
||||
if {$amor == 1} {
|
||||
set choppers [list chopper1 chopper2]
|
||||
set chopperparlist [list amode aspee nspee nphas dphas averl ratio vibra t_cho \
|
||||
durch vakum valve sumsi spver state]
|
||||
set chopperlonglist [list "Chopper Mode" "Actual Speed" "Set Speed" "Phase" "Phase Error" \
|
||||
"Loss Current" Ratio Vibration Temperature "Water Flow" Vakuum \
|
||||
Valve Sumsi]
|
||||
set chopperheader "AMOR Chopper Status"
|
||||
makesctcontroller chocosct std psts224:3014 "\r\n" 60
|
||||
# makesctcontroller chocosct std localhost:8080 "\r\n" 60
|
||||
chocosct debug -1
|
||||
set maxspeed 5000
|
||||
set minphase 0
|
||||
astriumMakeChopperParameters
|
||||
astMakeChopperSpeed1 chopperspeed
|
||||
astMakeChopperPhase2 chopper2phase
|
||||
Publish chosta Spy
|
||||
}
|
||||
|
||||
#----------------------------- POLDI -----------------------------------------
|
||||
if {$poldi == 1} {
|
||||
|
||||
proc poldiastchopphaselimit {} {
|
||||
set val [sct target]
|
||||
if {$val < 80 || $val > 100} {
|
||||
error "chopper phase out of range"
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#-------
|
||||
proc poldispeedwrite {} {
|
||||
set val [sct target]
|
||||
set l [split [config myrights] =]
|
||||
set rights [string trim [lindex $l 1]]
|
||||
if {$rights == 2} {
|
||||
if {$val < 4990 || $val > 15000} {
|
||||
clientput "ERROR: Users may only drive the chopper between 5000 - 15000 RPM"
|
||||
hupdate /sics/choco/stop 1
|
||||
return idle
|
||||
}
|
||||
}
|
||||
return [astchopwrite "nspee 1 "]
|
||||
}
|
||||
#-----------
|
||||
set choppers [list chopper]
|
||||
set chopperparlist [list amode aspee nspee nphas dphas averl ratio vibra vibax t_cho \
|
||||
flowr vakum valve sumsi spver state]
|
||||
set chopperlonglist [list "Chopper Mode" "Actual Speed" "Set Speed" "Phase" "Phase Error" \
|
||||
"Loss Current" Ratio Vibration "Actual Vibration" Temperature "Water Flow" Vakuum \
|
||||
Valve Sumsi]
|
||||
set chopperheader "POLDI Chopper Status"
|
||||
makesctcontroller chocosct std psts240:3005 "\r\n" 60
|
||||
# makesctcontroller chocosct std localhost:8080 "\r\n" 60
|
||||
chocosct debug -1
|
||||
set maxspeed 15000
|
||||
set minphase 80
|
||||
astriumMakeChopperParameters
|
||||
# astMakeChopperSpeed1 chopperspeed
|
||||
|
||||
set path /sics/choco/chopper/speed
|
||||
hfactory $path plain user float
|
||||
hsetprop $path read astspeedread chopper
|
||||
hsetprop $path write poldispeedwrite
|
||||
hsetprop $path astchopwritereply astchopwritereply
|
||||
chocosct write $path
|
||||
hsetprop $path checklimits astchopspeedlimit 0
|
||||
hsetprop $path halt astchopstop
|
||||
hsetprop $path checkstatus astchopcheckspeed chopper
|
||||
hsetprop $path priv user
|
||||
makesctdriveobj chopperspeed $path DriveAdapter chocosct
|
||||
|
||||
astMakeChopperPhase1 chopperphase
|
||||
hsetprop /sics/choco/chopper/phase checklimit poldiastchopphaselimit
|
||||
Publish chosta Spy
|
||||
}
|
||||
#----------------------------- FOCUS -----------------------------------------------------
|
||||
if {$focus == 1} {
|
||||
set choppers [list fermi disk]
|
||||
set chopperparlist [list state amode aspee nspee nphas dphas averl ratio vibra t_cho \
|
||||
durch vakum valve sumsi]
|
||||
set chopperlonglist [list "Chopper State" "Chopper Mode" "Actual Speed" "Set Speed" \
|
||||
"Phase" "Phase Error" \
|
||||
"Loss Current" Ratio Vibration Temperature "Water Flow" \
|
||||
Vakuum Valve Sumsi]
|
||||
set chopperheader "FOCUS Chopper Status"
|
||||
makesctcontroller chocosct std psts227:3008 "\r\n" 60
|
||||
# makesctcontroller chocosct std localhost:8080 "\r\n" 60
|
||||
chocosct debug 0
|
||||
set maxspeed 20000
|
||||
set minphase 0
|
||||
astriumMakeChopperParameters
|
||||
astMakeChopperSpeed1 fermispeed
|
||||
astMakeChopperSpeed2 diskspeed
|
||||
astMakeChopperRatio ratio
|
||||
astMakeChopperPhase2 phase
|
||||
Publish chosta Spy
|
||||
}
|
||||
@ -1,8 +0,0 @@
|
||||
proc bgerror err {
|
||||
global errorInfo
|
||||
set info $errorInfo
|
||||
|
||||
puts stdout $err
|
||||
puts stdout "------------------------- StackTrace ---------------------"
|
||||
puts $info
|
||||
}
|
||||
151
tcl/client.tcl
151
tcl/client.tcl
@ -1,151 +0,0 @@
|
||||
#!/data/koenneck/bin/tclsh
|
||||
#----------------------------------------------------------------------------
|
||||
# A command line client for SICS, written in plain Tcl.
|
||||
# Just sends and reads commands from the SICServer
|
||||
#
|
||||
# Mark Koennecke, September 1996
|
||||
#----------------------------------------------------------------------------
|
||||
#---------- Data section
|
||||
set sdata(test,host) lnsa06.psi.ch
|
||||
set sdata(test,port) 2910
|
||||
set sdata(dmc,host) lnsa05.psi.ch
|
||||
set sdata(dmc,port) 3006
|
||||
set sdata(topsi,host) lnsa03.psi.ch
|
||||
set sdata(topsi,port) 9708
|
||||
set sdata(sans,host) lnsa07.psi.ch
|
||||
set sdata(sans,port) 2915
|
||||
set sdata(user) Spy
|
||||
set sdata(passwd) 007
|
||||
|
||||
set mysocket stdout
|
||||
#--------------------------------------------------------------------------
|
||||
proc bgerror err {
|
||||
global errorInfo
|
||||
set info $errorInfo
|
||||
|
||||
puts stdout $err
|
||||
puts stdout "------------------------- StackTrace ---------------------"
|
||||
puts $info
|
||||
}
|
||||
|
||||
#--------------------------------- procedures section -----------------------
|
||||
# Setting up the connection to the Server
|
||||
proc StartConnection {host port} {
|
||||
global mysocket
|
||||
global sdata
|
||||
# start main connection
|
||||
set mysocket [socket $host $port]
|
||||
puts $mysocket [format "%s %s" $sdata(user) $sdata(passwd)]
|
||||
set ret [catch {flush $mysocket} msg]
|
||||
if { $ret != 0} {
|
||||
error "Server NOT running!"
|
||||
}
|
||||
fconfigure $mysocket -blocking 0
|
||||
fconfigure $mysocket -buffering none
|
||||
fileevent $mysocket readable GetData
|
||||
after 5000
|
||||
}
|
||||
#----------------------------------------------------------------------------
|
||||
proc GetData { } {
|
||||
global mysocket
|
||||
global b
|
||||
if { [eof $mysocket] } {
|
||||
puts stdout "Connection to server lost"
|
||||
close $mysocket
|
||||
set b 1
|
||||
return
|
||||
}
|
||||
set buf [read $mysocket]
|
||||
set buf [string trim $buf]
|
||||
set list [split $buf \n]
|
||||
foreach teil $list {
|
||||
set teil [string trimright $teil]
|
||||
puts stdout $teil
|
||||
}
|
||||
puts -nonewline stdout "SICS> "
|
||||
flush stdout
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
proc SendCommand { text} {
|
||||
global mysocket
|
||||
global b
|
||||
if { [eof $mysocket] } {
|
||||
puts stdout "Connection to server lost"
|
||||
set b 1
|
||||
}
|
||||
puts $mysocket $text
|
||||
flush $mysocket
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
proc readProgA {pid} {
|
||||
global readProgADone;
|
||||
global b
|
||||
global mysocket
|
||||
|
||||
# read outputs of schemdb
|
||||
set tmpbuf [gets $pid];
|
||||
if {[string first quit $tmpbuf] > -1 } {
|
||||
close $mysocket
|
||||
puts stdout "Closing connection to SICS server on your request..."
|
||||
puts stdout "Bye, bye, have a nice day!"
|
||||
set b 1
|
||||
} elseif { [string first stop $tmpbuf] > -1} {
|
||||
SendCommand "INT1712 3"
|
||||
} else {
|
||||
SendCommand $tmpbuf
|
||||
}
|
||||
|
||||
set readProgADone [eof $pid];
|
||||
|
||||
if {$readProgADone} {
|
||||
puts "closing...";
|
||||
catch [close $pid] aa;
|
||||
if {$aa != ""} {
|
||||
puts "HERE1: Error on closing";
|
||||
exit 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
#-------------------------- some utility functions -------------------------
|
||||
proc MC { t n } {
|
||||
set string $t
|
||||
for { set i 1 } { $i < $n } { incr i } {
|
||||
set string [format "%s%s" $string $t]
|
||||
}
|
||||
return $string
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------------
|
||||
proc PrintHeader { } {
|
||||
global instrument
|
||||
puts stdout [format "%s Welcome to SICS! %s" [MC " " 30] [MC " " 30]]
|
||||
puts stdout [format "%s You are connected to: %s" [MC " " 29] [MC " " 29]]
|
||||
puts stdout [format "%s %s %s" [MC " " 35] $instrument [MC " " 35]]
|
||||
puts stdout "SICS> "
|
||||
flush stdout
|
||||
}
|
||||
#-------------------------------- "MAIN" -----------------------------------
|
||||
if {$argc < 1} {
|
||||
puts stdout "Usage: client instrumentname"
|
||||
exit 0
|
||||
}
|
||||
#----------------- StartConnection
|
||||
set instrument [lindex $argv 0]
|
||||
set ret [catch {StartConnection $sdata($instrument,host) \
|
||||
$sdata($instrument,port)} msg ]
|
||||
if {$ret != 0} {
|
||||
puts stdout $msg
|
||||
exit 1
|
||||
}
|
||||
#----------------- print header
|
||||
PrintHeader
|
||||
|
||||
# set the "read" event
|
||||
fileevent stdin readable {readProgA stdin};
|
||||
|
||||
#---loop till exit
|
||||
set b 0
|
||||
vwait b
|
||||
exit 0
|
||||
|
||||
@ -1,54 +0,0 @@
|
||||
#--------------------------------------------------------------------------
|
||||
# A count command for DMC
|
||||
# All arguments are optional. The current values will be used if not
|
||||
# specified
|
||||
# Dr. Mark Koennecke, Juli 1997
|
||||
#--------------------------------------------------------------------------
|
||||
proc SplitReply { text } {
|
||||
set l [split $text =]
|
||||
return [lindex $l 1]
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc count { {mode NULL } { preset NULL } } {
|
||||
starttime [sicstime]
|
||||
catch {temperature log clear} msg
|
||||
#----- deal with mode
|
||||
set mode2 [string toupper $mode]
|
||||
set mode3 [string trim $mode2]
|
||||
set mc [string index $mode2 0]
|
||||
if { [string compare $mc T] == 0 } {
|
||||
banana CountMode Timer
|
||||
} elseif { [string compare $mc M] == 0 } {
|
||||
banana CountMode Monitor
|
||||
}
|
||||
#------ deal with preset
|
||||
if { [string compare $preset NULL] != 0 } {
|
||||
banana preset $preset
|
||||
}
|
||||
#------ prepare a count message
|
||||
set a [banana preset]
|
||||
set aa [SplitReply $a]
|
||||
set b [banana CountMode]
|
||||
set bb [SplitReply $b]
|
||||
ClientPut [format " Starting counting in %s mode with a preset of %s" \
|
||||
$bb $aa]
|
||||
#------- count
|
||||
banana InitVal 0
|
||||
wait 1
|
||||
banana count
|
||||
set ret [catch {Success} msg]
|
||||
#------- StoreData
|
||||
StoreData
|
||||
if { $ret != 0 } {
|
||||
error [format "Counting ended with error"]
|
||||
}
|
||||
}
|
||||
#---------------- Repeat -----------------------------------------------
|
||||
proc repeat { num {mode NULL} {preset NULL} } {
|
||||
for { set i 0 } { $i < $num } { incr i } {
|
||||
set ret [catch {count $mode $preset} msg]
|
||||
if {$ret != 0} {
|
||||
error "Counting ended with error"
|
||||
}
|
||||
}
|
||||
}
|
||||
356
tcl/deltatau.tcl
356
tcl/deltatau.tcl
@ -1,356 +0,0 @@
|
||||
#---------------------------------------------------------------
|
||||
# These are the scripts for the delta-tau PMAC motor
|
||||
# controller.
|
||||
#
|
||||
# !!!!!!!!! Script Chains !!!!!!!!!!!
|
||||
# -- For reading parameters:
|
||||
# sendpmacread code -- pmacreadreply
|
||||
# -- For setting standard parameters
|
||||
# sendpmacwrite code -- pmacreadreply
|
||||
# -- For reading limits
|
||||
# sendpmaclim -- readpmaclim
|
||||
# -- For reading the status
|
||||
# pmacsendaxer --- pmacrcvaxerr -- pmacrcvpos -- pmacrcvstat
|
||||
# This means we check for an axis error first, then update the position,
|
||||
# then check the axis status itself.
|
||||
# -- For setting the position
|
||||
# pmacsendhardpos -- pmacrcvhardpos -- pmacrcvhardax
|
||||
# This means, we send the positioning command, read the reply and read the
|
||||
# axisstatus until the axis has started
|
||||
#
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# Mark Koennecke, December 2008, March 2009
|
||||
#---------------------------------------------------------------
|
||||
proc translatePMACError {key} {
|
||||
set pmacerr(ERR001) "Command not allowed while executing"
|
||||
set pmacerr(ERR002) "Password error"
|
||||
set pmacerr(ERR003) "Unrecognized command"
|
||||
set pmacerr(ERR004) "Illegal character"
|
||||
set pmacerr(ERR005) "Command not allowed"
|
||||
set pmacerr(ERR006) "No room in buffer for command"
|
||||
set pmacerr(ERR007) "Buffer already in use"
|
||||
set pmacerr(ERR008) "MACRO auxiliary communication error"
|
||||
set pmacerr(ERR009) "Bad program in MCU"
|
||||
set pmacerr(ERR010) "Both HW limits set"
|
||||
set pmacerr(ERR011) "Previous move did not complete"
|
||||
set pmacerr(ERR012) "A motor is open looped"
|
||||
set pmacerr(ERR013) "A motor is not activated"
|
||||
set pmacerr(ERR014) "No motors"
|
||||
set pmacerr(ERR015) "No valid program in MCU"
|
||||
set pmacerr(ERR016) "Bad program in MCU"
|
||||
set pmacerr(ERR017) "Trying to resume after H or Q"
|
||||
set pmacerr(ERR018) "Invalid operation during move"
|
||||
set pmacerr(ERR019) "Illegal position change command during move"
|
||||
return $pmacerr($key)
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
proc translateAxisError {key} {
|
||||
switch [string trim $key] {
|
||||
0 {return "no error"}
|
||||
1 { return "limit violation"}
|
||||
2 -
|
||||
3 -
|
||||
4 { return "jog error"}
|
||||
5 {return "command not allowed"}
|
||||
6 {return "watchdog triggered"}
|
||||
7 {return "current limit reached"}
|
||||
8 -
|
||||
9 {return "Air cushion error"}
|
||||
10 {return "MCU lim reached"}
|
||||
11 {return "following error triggered"}
|
||||
12 {return "EMERGENCY STOP ACTIVATED"}
|
||||
13 {return "Driver electronics error"}
|
||||
default { return "Unknown axis error $key"}
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------------------
|
||||
proc evaluateAxisStatus {key} {
|
||||
#----- Tcl does not like negative numbers as keys.
|
||||
if {$key < 0} {
|
||||
set key [expr 50 + abs($key)]
|
||||
}
|
||||
switch $key {
|
||||
0 -
|
||||
14 {return idle}
|
||||
1 -
|
||||
2 -
|
||||
3 -
|
||||
4 -
|
||||
5 -
|
||||
6 -
|
||||
7 -
|
||||
8 -
|
||||
9 -
|
||||
10 -
|
||||
11 {return run}
|
||||
56 {error "Controller aborted"}
|
||||
55 {error "Axis is deactivated"}
|
||||
54 {error "emergency stop activated, please release"}
|
||||
53 {error "Axis inhibited"}
|
||||
51 -
|
||||
52 {error "Incoming command is blocked"}
|
||||
}
|
||||
}
|
||||
#-----------------------------------------------------------------------
|
||||
proc checkpmacresult {} {
|
||||
set data [sct result]
|
||||
if {[string first ASCERR $data] >= 0} {
|
||||
error $data
|
||||
}
|
||||
if {[string first ERR $data] >= 0} {
|
||||
error [translatePMACError $data]
|
||||
}
|
||||
return [string trim $data]
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc sendpmacread {code} {
|
||||
sct send $code
|
||||
return pmacreadreply
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc pmacreadreply {} {
|
||||
set status [catch {checkpmacresult} data]
|
||||
if {$status != 0} {
|
||||
sct geterror $data
|
||||
} else {
|
||||
sct update $data
|
||||
}
|
||||
return idle
|
||||
}
|
||||
#----------------------------------------------------------------------
|
||||
proc sendpmaclim {code} {
|
||||
sct send $code
|
||||
return pmacreadlim
|
||||
}
|
||||
#-----------------------------------------------------------------------
|
||||
proc pmacreadlim {motname} {
|
||||
set status [catch {checkpmacresult} data]
|
||||
if {$status != 0} {
|
||||
sct geterror $data
|
||||
} else {
|
||||
set scale [hval /sics/${motname}/scale_factor]
|
||||
sct update [expr $data * $scale]
|
||||
}
|
||||
return idle
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc sendpmacwrite {code} {
|
||||
set value [sct target]
|
||||
sct send "$code=$value"
|
||||
return pmacwritereply
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc pmacwritereply {} {
|
||||
set status [catch {checkpmacresult} data]
|
||||
if {$status != 0} {
|
||||
sct geterror $data
|
||||
sct print "ERROR: $data"
|
||||
} else {
|
||||
set con [sct controller]
|
||||
$con queue [sct] read read
|
||||
}
|
||||
return idle
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
proc configurePMACPar {name par code sct} {
|
||||
set path /sics/$name/$par
|
||||
hsetprop $path read "sendpmacread $code"
|
||||
hsetprop $path pmacreadreply pmacreadreply
|
||||
$sct poll $path 30
|
||||
hsetprop $path write "sendpmacwrite $code"
|
||||
hsetprop $path pmacwritereply pmacwritereply
|
||||
$sct write $path
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
proc makePMACPar {name par code sct priv} {
|
||||
set path /sics/$name/$par
|
||||
hfactory $path plain $priv float
|
||||
configurePMACPar $name $par $code $sct
|
||||
}
|
||||
#========================== status functions =============================
|
||||
proc pmacsendaxerr {num} {
|
||||
sct send "P${num}01"
|
||||
return rcvaxerr
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc pmacrcvaxerr {motname num} {
|
||||
set status [catch {checkpmacresult} data]
|
||||
if {$status != 0} {
|
||||
clientput "ERROR: $data"
|
||||
sct update error
|
||||
sct geterror $data
|
||||
return idle
|
||||
}
|
||||
hupdate /sics/$motname/axiserror $data
|
||||
if {$data != 0 } {
|
||||
set err [translateAxisError $data]
|
||||
if {[string first following $err] >= 0} {
|
||||
clientput "WARNING: $err"
|
||||
sct update poserror
|
||||
} else {
|
||||
clientput "ERROR: $err"
|
||||
sct update error
|
||||
}
|
||||
return idle
|
||||
}
|
||||
hupdate /sics/$motname/axiserror $data
|
||||
sct send "Q${num}10"
|
||||
return rcvpos
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc pmacrcvpos {motname num} {
|
||||
set status [catch {checkpmacresult} data]
|
||||
if {$status != 0} {
|
||||
clientput "ERROR: $data"
|
||||
sct geterror $data
|
||||
sct update error
|
||||
return idle
|
||||
}
|
||||
hupdate /sics/$motname/hardposition $data
|
||||
sct send "P${num}00"
|
||||
return rcvstat
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc pmacrcvstat {motname num sct} {
|
||||
set status [catch {checkpmacresult} data]
|
||||
if {$status != 0} {
|
||||
clientput "ERROR: $data"
|
||||
sct update error
|
||||
return idle
|
||||
}
|
||||
set status [catch {evaluateAxisStatus $data} msg]
|
||||
if {$status != 0} {
|
||||
sct update error
|
||||
} else {
|
||||
sct update $msg
|
||||
switch $msg {
|
||||
idle {
|
||||
# force an update of the motor position
|
||||
$sct queue /sics/$motname/hardposition progress read
|
||||
}
|
||||
run {
|
||||
# force an update of ourselves, while running
|
||||
$sct queue /sics/$motname/status progress read
|
||||
}
|
||||
}
|
||||
}
|
||||
return idle
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
proc configurePMACStatus {motname num sct} {
|
||||
set path /sics/$motname/status
|
||||
hsetprop $path read "pmacsendaxerr $num"
|
||||
hsetprop $path rcvaxerr "pmacrcvaxerr $motname $num"
|
||||
hsetprop $path rcvpos "pmacrcvpos $motname $num"
|
||||
hsetprop $path rcvstat "pmacrcvstat $motname $num $sct"
|
||||
$sct poll $path 60
|
||||
}
|
||||
#======================= setting hard position ===========================
|
||||
proc pmacsendhardpos {motname num} {
|
||||
hupdate /sics/$motname/status run
|
||||
set value [sct target]
|
||||
sct send [format "P%2.2d23=0 Q%2.2d01=%12.4f M%2.2d=1" $num $num $value $num]
|
||||
return rcvhardpos
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
proc pmacrcvhardpos {num} {
|
||||
set status [catch {checkpmacresult} data]
|
||||
if {$status != 0} {
|
||||
clientput "ERROR: $data"
|
||||
sct seterror $data
|
||||
return idle
|
||||
}
|
||||
sct send "P${num}00"
|
||||
return rcvhardax
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc pmacrcvhardax {motname num sct} {
|
||||
set status [catch {checkpmacresult} data]
|
||||
if {$status != 0} {
|
||||
clientput "ERROR: $data"
|
||||
sct seterror $data
|
||||
return idle
|
||||
}
|
||||
set status [catch {evaluateAxisStatus $data} msg]
|
||||
if {$status != 0} {
|
||||
clientput "ERROR: $msg"
|
||||
sct seterror $msg
|
||||
return idle
|
||||
}
|
||||
switch $msg {
|
||||
idle {
|
||||
sct send "P${num}00"
|
||||
return rcvhardax
|
||||
}
|
||||
run {
|
||||
$sct queue /sics/$motname/status progress read
|
||||
return idle
|
||||
}
|
||||
}
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc configurePMAChardwrite {motname num sct} {
|
||||
set path /sics/$motname/hardposition
|
||||
hsetprop $path write "pmacsendhardpos $motname $num"
|
||||
hsetprop $path rcvhardpos "pmacrcvhardpos $num"
|
||||
hsetprop $path rcvhardax "pmacrcvhardax $motname $num $sct"
|
||||
}
|
||||
#======================= Halt =============================================
|
||||
proc pmacHalt {sct num} {
|
||||
$sct send "M${num}=8" halt
|
||||
return OK
|
||||
}
|
||||
#==================== Reference Run =======================================
|
||||
proc pmacrefrun {motorname sct num} {
|
||||
set path /sics/${motorname}/status
|
||||
$sct send "M${num}=9"
|
||||
hupdate /sics/${motorname}/status run
|
||||
set motstat run
|
||||
wait 3
|
||||
while {[string compare $motstat run] == 0} {
|
||||
$sct queue $path progress read
|
||||
wait 1
|
||||
set motstat [string trim [hval $path]]
|
||||
}
|
||||
return "Done"
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc MakeDeltaTau {name sct num} {
|
||||
MakeSecMotor $name
|
||||
hsetprop /sics/${name}/hardupperlim read "sendpmaclim I${num}13"
|
||||
hsetprop /sics/${name}/hardupperlim pmacreadlim "pmacreadlim $name"
|
||||
$sct poll /sics/${name}/hardupperlim 180
|
||||
hsetprop /sics/${name}/hardlowerlim read "sendpmaclim I${num}14"
|
||||
hsetprop /sics/${name}/hardlowerlim pmacreadlim "pmacreadlim $name"
|
||||
$sct poll /sics/${name}/hardlowerlim 180
|
||||
|
||||
# configurePMACPar $name hardlowerlim "Q${num}09" $sct
|
||||
# configurePMACPar $name hardupperlim "Q${num}08" $sct
|
||||
|
||||
configurePMACPar $name hardposition "Q${num}10" $sct
|
||||
configurePMAChardwrite $name $num $sct
|
||||
hfactory /sics/$name/numinmcu plain internal int
|
||||
hupdate /sics/$name/numinmcu ${num}
|
||||
makePMACPar $name scale_factor "Q${num}00" $sct mugger
|
||||
makePMACPar $name maxspeed "Q${num}03" $sct mugger
|
||||
makePMACPar $name commandspeed "Q${num}04" $sct mugger
|
||||
makePMACPar $name maxaccel "Q${num}05" $sct mugger
|
||||
makePMACPar $name commandedaccel "Q${num}06" $sct mugger
|
||||
makePMACPar $name offset "Q${num}07" $sct mugger
|
||||
makePMACPar $name axisstatus "P${num}00" $sct internal
|
||||
makePMACPar $name axiserror "P${num}01" $sct internal
|
||||
makePMACPar $name poshwlimitactive "M${num}21" $sct internal
|
||||
makePMACPar $name neghwlimitactive "M${num}22" $sct internal
|
||||
makePMACPar $name liftaircushion "M${num}96" $sct internal
|
||||
configurePMACStatus $name $num $sct
|
||||
$name makescriptfunc halt "pmacHalt $sct $num" user
|
||||
$name makescriptfunc refrun "pmacrefrun $name $sct $num" user
|
||||
set parlist [list scale_factor hardposition maxspeed \
|
||||
commandspeed maxaccel offset axisstatus axiserror status poshwlimitactive \
|
||||
neghwlimitactive liftaircushion hardlowerlim hardupperlim]
|
||||
$sct send [format "M%2.2d14=0" $num]
|
||||
foreach par $parlist {
|
||||
$sct queue /sics/$name/$par progress read
|
||||
}
|
||||
}
|
||||
314
tcl/el737sec.tcl
314
tcl/el737sec.tcl
@ -1,314 +0,0 @@
|
||||
#-----------------------------------------------------
|
||||
# This is a second generation counter driver for
|
||||
# the PSI EL737 counter boxes using scriptcontext
|
||||
# communication.
|
||||
#
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# Scriptchains:
|
||||
# start: el737sendstart - el737cmdreply
|
||||
# pause,cont, stop: el737sendcmd - el737cmdreply
|
||||
# status: el737readstatus - el737status
|
||||
# \ el737statval - el737statread
|
||||
# values: el737readvalues - el737val
|
||||
# threshold write: el737threshsend - el737threshrcv - el737cmdreply
|
||||
#
|
||||
# Mark Koennecke, February 2009
|
||||
#-----------------------------------------------------
|
||||
proc el737error {reply} {
|
||||
if {[string first ERR $reply] >= 0} {
|
||||
error $reply
|
||||
}
|
||||
if {[string first ? $reply] < 0} {
|
||||
return ok
|
||||
}
|
||||
if {[string first "?OV" $reply] >= 0} {
|
||||
error overflow
|
||||
}
|
||||
if {[string first "?1" $reply] >= 0} {
|
||||
error "out of range"
|
||||
}
|
||||
if {[string first "?2" $reply] >= 0} {
|
||||
error "bad command"
|
||||
}
|
||||
if {[string first "?3" $reply] >= 0} {
|
||||
error "bad parameter"
|
||||
}
|
||||
if {[string first "?4" $reply] >= 0} {
|
||||
error "bad counter"
|
||||
}
|
||||
if {[string first "?5" $reply] >= 0} {
|
||||
error "parameter missing"
|
||||
}
|
||||
if {[string first "?6" $reply] >= 0} {
|
||||
error "to many counts"
|
||||
}
|
||||
return ok
|
||||
}
|
||||
#---------------------------------------------------
|
||||
proc el737cmdreply {} {
|
||||
set reply [sct result]
|
||||
set status [catch {el737error $reply} err]
|
||||
if {$status != 0} {
|
||||
sct geterror $err
|
||||
set data [sct send]
|
||||
if {[string first overflow $err] >= 0} {
|
||||
clientput "WARNING: trying to fix $err on command = $data"
|
||||
sct send $data
|
||||
return el737cmdreply
|
||||
} else {
|
||||
clientput "ERROR: $err, command = $data"
|
||||
}
|
||||
}
|
||||
return idle
|
||||
}
|
||||
#---------------------------------------------------
|
||||
proc sctroot {} {
|
||||
set path [sct]
|
||||
return [file dirname $path]
|
||||
}
|
||||
#----------------------------------------------------
|
||||
proc el737sendstart {} {
|
||||
set obj [sctroot]
|
||||
set mode [string tolower [string trim [hval $obj/mode]]]
|
||||
set preset [string trim [hval $obj/preset]]
|
||||
hdelprop [sct] geterror
|
||||
switch $mode {
|
||||
timer {
|
||||
set cmd [format "TP %.2f" $preset]
|
||||
}
|
||||
default {
|
||||
set cmd [format "MP %d" [expr int($preset)]]
|
||||
}
|
||||
}
|
||||
sct send $cmd
|
||||
set con [sct controller]
|
||||
$con queue $obj/status progress read
|
||||
return el737cmdreply
|
||||
}
|
||||
#----------------------------------------------------
|
||||
proc el737sendcmd {cmd} {
|
||||
hdelprop [sct] geterror
|
||||
sct send $cmd
|
||||
return el737cmdreply
|
||||
}
|
||||
#---------------------------------------------------
|
||||
proc el737control {} {
|
||||
set target [sct target]
|
||||
switch $target {
|
||||
1000 {return [el737sendstart] }
|
||||
1001 {return [el737sendcmd S] }
|
||||
1002 {return [el737sendcmd PS] }
|
||||
1003 {return [el737sendcmd CO] }
|
||||
default {
|
||||
sct print "ERROR: bad start target $target given to control"
|
||||
return idle
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
#----------------------------------------------------
|
||||
proc el737readstatus {} {
|
||||
hdelprop [sct] geterror
|
||||
sct send RS
|
||||
return el737status
|
||||
}
|
||||
#-------------------------------------------------
|
||||
proc el737statval {} {
|
||||
el737readvalues
|
||||
return el737statread
|
||||
}
|
||||
#-------------------------------------------------
|
||||
proc el737statread {} {
|
||||
el737val
|
||||
sct update idle
|
||||
return idle
|
||||
}
|
||||
#--------------------------------------------------
|
||||
proc el737status {} {
|
||||
set reply [sct result]
|
||||
set status [catch {el737error $reply} err]
|
||||
if {$status != 0} {
|
||||
sct geterror $err
|
||||
sct update error
|
||||
sct print "ERROR: $err"
|
||||
return idle
|
||||
}
|
||||
set path [sct]
|
||||
set con [sct controller]
|
||||
switch [string trim $reply] {
|
||||
0 {
|
||||
return el737statval
|
||||
}
|
||||
1 -
|
||||
2 {
|
||||
sct update run
|
||||
$con queue $path progress read
|
||||
}
|
||||
5 -
|
||||
6 {
|
||||
sct update nobeam
|
||||
$con queue $path progress read
|
||||
}
|
||||
default {
|
||||
sct update pause
|
||||
$con queue $path progress read
|
||||
}
|
||||
}
|
||||
set count [sct moncount]
|
||||
if {$count >= 10} {
|
||||
set root [sctroot]
|
||||
$con queue $root/values progress read
|
||||
sct moncount 0
|
||||
} else {
|
||||
incr count
|
||||
sct moncount $count
|
||||
}
|
||||
return idle
|
||||
}
|
||||
#------------------------------------------------
|
||||
proc el737readvalues {} {
|
||||
hdelprop [sct] geterror
|
||||
sct send RA
|
||||
return el737val
|
||||
}
|
||||
#--------------------------------------------------
|
||||
proc swapFirst {l} {
|
||||
set m1 [lindex $l 0]
|
||||
set cts [lindex $l 1]
|
||||
lappend res $cts $m1
|
||||
for {set i 2} {$i < [llength $l]} {incr i} {
|
||||
lappend res [lindex $l $i]
|
||||
}
|
||||
return $res
|
||||
}
|
||||
#---------------------------------------------------
|
||||
# There are two types of reponses to the RA command:
|
||||
# the old form with 5 values and the new one
|
||||
# with 9 values
|
||||
#---------------------------------------------------
|
||||
proc el737val {} {
|
||||
set reply [sct result]
|
||||
set status [catch {el737error $reply} err]
|
||||
if {$status != 0} {
|
||||
sct geterror $err
|
||||
sct print "ERROR: $err"
|
||||
return idle
|
||||
}
|
||||
set l [split $reply]
|
||||
set root [sctroot]
|
||||
if {[llength $l] > 5} {
|
||||
set l2 [lrange $l 1 end]
|
||||
set l2 [swapFirst $l2]
|
||||
hupdate ${root}/values [join $l2]
|
||||
set time [lindex $l 0]
|
||||
hupdate ${root}/time $time
|
||||
} else {
|
||||
set last [expr [llength $l] - 1]
|
||||
set l2 [lrange $l 0 $last]
|
||||
set l2 [swapFirst $l2]
|
||||
hupdate ${root}/values [join $l2]
|
||||
set time [lindex $l $last]
|
||||
hupdate ${root}/time $time
|
||||
}
|
||||
set mode [hval ${root}/mode]
|
||||
switch $mode {
|
||||
timer {
|
||||
hupdate ${root}/control $time
|
||||
}
|
||||
default {
|
||||
set mon [lindex $l2 1]
|
||||
hupdate ${root}/control $time
|
||||
}
|
||||
}
|
||||
return idle
|
||||
}
|
||||
#----------------------------------------------
|
||||
proc el737threshsend {} {
|
||||
set val [string trim [sct target]]
|
||||
set root [sctroot]
|
||||
set cter [string trim [hval $root/thresholdcounter]]
|
||||
sct send [format "DL %1.1d %f" $cter $val]
|
||||
return el737threshrecv
|
||||
}
|
||||
#---------------------------------------------
|
||||
proc el737threshrecv {} {
|
||||
set reply [sct result]
|
||||
set status [catch {el737error $reply} err]
|
||||
if {$status != 0} {
|
||||
sct geterror $err
|
||||
sct print "ERROR: $err"
|
||||
}
|
||||
set root [sctroot]
|
||||
set cter [string trim [hval $root/thresholdcounter]]
|
||||
sct send [format "DR %1.1d" $cter]
|
||||
set sctcon [sct controller]
|
||||
$sctcon queue [sct] progress read
|
||||
return el737cmdreply
|
||||
}
|
||||
#---------------------------------------------
|
||||
proc el737threshread {} {
|
||||
set root [sctroot]
|
||||
set cter [string trim [hval $root/thresholdcounter]]
|
||||
sct send [format "DL %1.1d" $cter]
|
||||
return el737thresh
|
||||
}
|
||||
#----------------------------------------------
|
||||
proc el737thresh {} {
|
||||
set reply [sct result]
|
||||
set status [catch {el737error $reply} err]
|
||||
if {$status != 0} {
|
||||
sct geterror $err
|
||||
sct print "ERROR: $err"
|
||||
return idle
|
||||
}
|
||||
stscan $reply "%f" val
|
||||
sct update $val
|
||||
return idle
|
||||
}
|
||||
#----------------------------------------------
|
||||
proc el737func {controller path} {
|
||||
$controller queue $path write
|
||||
}
|
||||
#============================================
|
||||
proc MakeSecEL737 {name netaddr} {
|
||||
MakeSecCounter $name 8
|
||||
set conname ${name}sct
|
||||
makesctcontroller $conname std $netaddr "\r" 10
|
||||
$conname send "RMT 1"
|
||||
$conname send "RMT 1"
|
||||
$conname send "ECHO 2"
|
||||
|
||||
set path /sics/${name}/values
|
||||
hsetprop $path read el737readvalues
|
||||
hsetprop $path el737val el737val
|
||||
$conname poll $path 60
|
||||
|
||||
set path /sics/${name}/status
|
||||
hsetprop $path read el737readstatus
|
||||
hsetprop $path el737status el737status
|
||||
hsetprop $path el737statval el737statval
|
||||
hsetprop $path el737statread el737statread
|
||||
hsetprop $path moncount 0
|
||||
$conname poll $path 60
|
||||
|
||||
set path /sics/${name}/control
|
||||
hsetprop $path write el737control
|
||||
hsetprop $path el737cmdreply el737cmdreply
|
||||
$conname write $path
|
||||
|
||||
hfactory /sics/${name}/thresholdcounter plain mugger int
|
||||
hsetprop /sics/${name}/thresholdcounter __save true
|
||||
set path /sics/${name}/threshold
|
||||
hfactory $path plain mugger float
|
||||
hsetprop $path write el737threshsend
|
||||
hsetprop $path el737threshrcv el737threshrcv
|
||||
hsetprop $path el737cmdreply el737cmdreply
|
||||
$conname write $path
|
||||
hsetprop $path read el737threshread
|
||||
hsetprop $path el737thresh el737thresh
|
||||
# $conname poll $path 60
|
||||
|
||||
$conname debug -1
|
||||
|
||||
}
|
||||
@ -1,97 +0,0 @@
|
||||
#-------------------------------------------------------------
|
||||
# This is a scriptcontext driver for the PSI EL755 magnet
|
||||
# controller.
|
||||
#
|
||||
# scriptchains:
|
||||
# read - readreply
|
||||
# write - writereply - writereadback
|
||||
#
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# Mark Koennecke, November 2009
|
||||
#--------------------------------------------------------------
|
||||
|
||||
namespace eval el755 {}
|
||||
|
||||
#--------------------------------------------------------------
|
||||
proc el755::read {num} {
|
||||
sct send [format "I %d" $num]
|
||||
return readreply
|
||||
}
|
||||
#--------------------------------------------------------------
|
||||
proc el755::readreply {num} {
|
||||
set reply [sct result]
|
||||
if {[string first ? $reply] >= 0} {
|
||||
if {[string first ?OV $reply] >= 0} {
|
||||
sct send [format "I %d" $num]
|
||||
# clientput "EL755 did an overflow...."
|
||||
return readreply
|
||||
}
|
||||
error $reply
|
||||
}
|
||||
set n [stscan $reply "%f %f" soll ist]
|
||||
if {$n < 2} {
|
||||
sct send [format "I %d" $num]
|
||||
clientput "Invalid response $reply from EL755"
|
||||
return readreply
|
||||
}
|
||||
sct update $ist
|
||||
return idle
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
proc el755::write {num} {
|
||||
set cur [sct target]
|
||||
sct send [format "I %d %f" $num $cur]
|
||||
return writereply
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
proc el755::writereply {num} {
|
||||
set reply [sct result]
|
||||
if {[string first ? $reply] >= 0} {
|
||||
if {[string first ?OV $reply] >= 0} {
|
||||
set cur [sct target]
|
||||
sct send [format "I %d %f" $num $cur]
|
||||
# clientput "EL755 did an overflow...."
|
||||
return writereply
|
||||
}
|
||||
error $reply
|
||||
}
|
||||
sct send [format "I %d" $num]
|
||||
return writereadback
|
||||
}
|
||||
#--------------------------------------------------------------------
|
||||
proc el755::writereadback {num} {
|
||||
set reply [sct result]
|
||||
if {[string first ? $reply] >= 0} {
|
||||
if {[string first ?OV $reply] >= 0} {
|
||||
set cur [sct target]
|
||||
sct send [format "I %d" $num]
|
||||
# clientput "EL755 did an overflow...."
|
||||
return writereadback
|
||||
}
|
||||
error $reply
|
||||
}
|
||||
set n [stscan $reply "%f %f" soll ist]
|
||||
if {$n < 2} {
|
||||
sct send [format "I %d" $num]
|
||||
clientput "Invalid response $reply from EL755"
|
||||
return writereadback
|
||||
}
|
||||
set cur [sct target]
|
||||
if {abs($cur - $soll) < .1} {
|
||||
return idle
|
||||
}
|
||||
return el755::write $num
|
||||
}
|
||||
#--------------------------------------------------------------------
|
||||
proc el755::makeel755 {name num sct} {
|
||||
stddrive::makestddrive $name EL755Magnet $sct
|
||||
set path /sics/${name}
|
||||
hsetprop $path read el755::read $num
|
||||
hsetprop $path readreply el755::readreply $num
|
||||
hsetprop $path write el755::write $num
|
||||
hsetprop $path writereply el755::writereply $num
|
||||
hsetprop $path writereadback el755::writereadback $num
|
||||
$sct poll $path 60
|
||||
$sct write $path
|
||||
}
|
||||
52
tcl/fit.tcl
52
tcl/fit.tcl
@ -1,52 +0,0 @@
|
||||
#-----------------------------------------------------------------------------
|
||||
# This is an implementation for a fit command for SICS. It uses a separate
|
||||
# fit program retrieved from the vast spaces of the net for this purpose.
|
||||
# The scheme is as follows: Data is written to a file, the fit program is
|
||||
# executed and the data retrieved at need.
|
||||
#
|
||||
# Mark Koennecke, October 1997
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
#----- Initialise this to match your setup
|
||||
set fithome /data/koenneck/src/sics/fit
|
||||
set scancom xxxscan
|
||||
set IIcentervar ""
|
||||
|
||||
proc fit__run { } {
|
||||
global fithome
|
||||
global scancom
|
||||
global IIcentervar
|
||||
#---------------
|
||||
set cp [$scancom getcounts]
|
||||
set cp2 [split $cp =]
|
||||
set Counts [lindex $cp2 1]
|
||||
set fp [$scancom getvardata 0]
|
||||
set fp2 [split $fp = ]
|
||||
set fitpar [lindex $fp2 1]
|
||||
#----- set center variable
|
||||
set bg [lindex $fp2 1]
|
||||
set bg2 [split $bg .]
|
||||
set IIcentervar [lindex $bg2 1]
|
||||
unset cp
|
||||
unset cp2
|
||||
unset fp
|
||||
unset fp2
|
||||
unset bg
|
||||
unset bg2
|
||||
#---- write fit input file
|
||||
set fd [open $fithome/sicsin.dat w]
|
||||
set length [llength $Counts]
|
||||
for {set i 0 } { $i < $length } { incr i} {
|
||||
puts $fd [format " %f %d" [lindex $fitpar $i] \
|
||||
[lindex $Counts $i] ]
|
||||
}
|
||||
close $fd
|
||||
|
||||
}
|
||||
|
||||
proc fit args {
|
||||
set l [llength $args]
|
||||
if { $l < 1} {
|
||||
fit__run
|
||||
}
|
||||
}
|
||||
228
tcl/ldAout.tcl
228
tcl/ldAout.tcl
@ -1,228 +0,0 @@
|
||||
# ldAout.tcl --
|
||||
#
|
||||
# This "tclldAout" procedure in this script acts as a replacement
|
||||
# for the "ld" command when linking an object file that will be
|
||||
# loaded dynamically into Tcl or Tk using pseudo-static linking.
|
||||
#
|
||||
# Parameters:
|
||||
# The arguments to the script are the command line options for
|
||||
# an "ld" command.
|
||||
#
|
||||
# Results:
|
||||
# The "ld" command is parsed, and the "-o" option determines the
|
||||
# module name. ".a" and ".o" options are accumulated.
|
||||
# The input archives and object files are examined with the "nm"
|
||||
# command to determine whether the modules initialization
|
||||
# entry and safe initialization entry are present. A trivial
|
||||
# C function that locates the entries is composed, compiled, and
|
||||
# its .o file placed before all others in the command; then
|
||||
# "ld" is executed to bind the objects together.
|
||||
#
|
||||
# SCCS: @(#) ldAout.tcl 1.11 96/09/17 09:02:20
|
||||
#
|
||||
# Copyright (c) 1995, by General Electric Company. All rights reserved.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
# This work was supported in part by the ARPA Manufacturing Automation
|
||||
# and Design Engineering (MADE) Initiative through ARPA contract
|
||||
# F33615-94-C-4400.
|
||||
|
||||
proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
|
||||
global env
|
||||
global argv
|
||||
|
||||
if {$cc==""} {
|
||||
set cc $env(CC)
|
||||
}
|
||||
|
||||
# if only two parameters are supplied there is assumed that the
|
||||
# only shlib_suffix is missing. This parameter is anyway available
|
||||
# as "info sharedlibextension" too, so there is no need to transfer
|
||||
# 3 parameters to the function tclLdAout. For compatibility, this
|
||||
# function now accepts both 2 and 3 parameters.
|
||||
|
||||
if {$shlib_suffix==""} {
|
||||
set shlib_suffix $env(SHLIB_SUFFIX)
|
||||
set shlib_cflags $env(SHLIB_CFLAGS)
|
||||
} else {
|
||||
if {$shlib_cflags=="none"} {
|
||||
set shlib_cflags $shlib_suffix
|
||||
set shlib_suffix [info sharedlibextension]
|
||||
}
|
||||
}
|
||||
|
||||
# seenDotO is nonzero if a .o or .a file has been seen
|
||||
|
||||
set seenDotO 0
|
||||
|
||||
# minusO is nonzero if the last command line argument was "-o".
|
||||
|
||||
set minusO 0
|
||||
|
||||
# head has command line arguments up to but not including the first
|
||||
# .o or .a file. tail has the rest of the arguments.
|
||||
|
||||
set head {}
|
||||
set tail {}
|
||||
|
||||
# nmCommand is the "nm" command that lists global symbols from the
|
||||
# object files.
|
||||
|
||||
set nmCommand {|nm -g}
|
||||
|
||||
# entryProtos is the table of _Init and _SafeInit prototypes found in the
|
||||
# module.
|
||||
|
||||
set entryProtos {}
|
||||
|
||||
# entryPoints is the table of _Init and _SafeInit entries found in the
|
||||
# module.
|
||||
|
||||
set entryPoints {}
|
||||
|
||||
# libraries is the list of -L and -l flags to the linker.
|
||||
|
||||
set libraries {}
|
||||
set libdirs {}
|
||||
|
||||
# Process command line arguments
|
||||
|
||||
foreach a $argv {
|
||||
if {!$minusO && [regexp {\.[ao]$} $a]} {
|
||||
set seenDotO 1
|
||||
lappend nmCommand $a
|
||||
}
|
||||
if {$minusO} {
|
||||
set outputFile $a
|
||||
set minusO 0
|
||||
} elseif {![string compare $a -o]} {
|
||||
set minusO 1
|
||||
}
|
||||
if [regexp {^-[lL]} $a] {
|
||||
lappend libraries $a
|
||||
if [regexp {^-L} $a] {
|
||||
lappend libdirs [string range $a 2 end]
|
||||
}
|
||||
} elseif {$seenDotO} {
|
||||
lappend tail $a
|
||||
} else {
|
||||
lappend head $a
|
||||
}
|
||||
}
|
||||
lappend libdirs /lib /usr/lib
|
||||
|
||||
# MIPS -- If there are corresponding G0 libraries, replace the
|
||||
# ordinary ones with the G0 ones.
|
||||
|
||||
set libs {}
|
||||
foreach lib $libraries {
|
||||
if [regexp {^-l} $lib] {
|
||||
set lname [string range $lib 2 end]
|
||||
foreach dir $libdirs {
|
||||
if [file exists [file join $dir lib${lname}_G0.a]] {
|
||||
set lname ${lname}_G0
|
||||
break
|
||||
}
|
||||
}
|
||||
lappend libs -l$lname
|
||||
} else {
|
||||
lappend libs $lib
|
||||
}
|
||||
}
|
||||
set libraries $libs
|
||||
|
||||
# Extract the module name from the "-o" option
|
||||
|
||||
if {![info exists outputFile]} {
|
||||
error "-o option must be supplied to link a Tcl load module"
|
||||
}
|
||||
set m [file tail $outputFile]
|
||||
set l [expr [string length $m] - [string length $shlib_suffix]]
|
||||
if [string compare [string range $m $l end] $shlib_suffix] {
|
||||
error "Output file does not appear to have a $shlib_suffix suffix"
|
||||
}
|
||||
set modName [string tolower [string range $m 0 [expr $l-1]]]
|
||||
if [regexp {^lib} $modName] {
|
||||
set modName [string range $modName 3 end]
|
||||
}
|
||||
if [regexp {[0-9\.]*(_g0)?$} $modName match] {
|
||||
set modName [string range $modName 0 [expr [string length $modName]-[string length $match]-1]]
|
||||
}
|
||||
set modName "[string toupper [string index $modName 0]][string range $modName 1 end]"
|
||||
|
||||
# Catalog initialization entry points found in the module
|
||||
|
||||
set f [open $nmCommand r]
|
||||
while {[gets $f l] >= 0} {
|
||||
if [regexp {T[ ]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol] {
|
||||
if {![regexp {_?([A-Z][a-z0-9_]*_(Safe)?Init)} $symbol trash s]} {
|
||||
set s $symbol
|
||||
}
|
||||
append entryProtos {extern int } $symbol { (); } \n
|
||||
append entryPoints { } \{ { "} $s {", } $symbol { } \} , \n
|
||||
}
|
||||
}
|
||||
close $f
|
||||
|
||||
if {$entryPoints==""} {
|
||||
error "No entry point found in objects"
|
||||
}
|
||||
|
||||
# Compose a C function that resolves the initialization entry points and
|
||||
# embeds the required libraries in the object code.
|
||||
|
||||
set C {#include <string.h>}
|
||||
append C \n
|
||||
append C {char TclLoadLibraries_} $modName { [] =} \n
|
||||
append C { "@LIBS: } $libraries {";} \n
|
||||
append C $entryProtos
|
||||
append C {static struct } \{ \n
|
||||
append C { char * name;} \n
|
||||
append C { int (*value)();} \n
|
||||
append C \} {dictionary [] = } \{ \n
|
||||
append C $entryPoints
|
||||
append C { 0, 0 } \n \} \; \n
|
||||
append C {typedef struct Tcl_Interp Tcl_Interp;} \n
|
||||
append C {typedef int Tcl_PackageInitProc (Tcl_Interp *);} \n
|
||||
append C {Tcl_PackageInitProc *} \n
|
||||
append C TclLoadDictionary_ $modName { (symbol)} \n
|
||||
append C { char * symbol;} \n
|
||||
append C {{
|
||||
int i;
|
||||
for (i = 0; dictionary [i] . name != 0; ++i) {
|
||||
if (!strcmp (symbol, dictionary [i] . name)) {
|
||||
return dictionary [i].value;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}} \n
|
||||
|
||||
# Write the C module and compile it
|
||||
|
||||
set cFile tcl$modName.c
|
||||
set f [open $cFile w]
|
||||
puts -nonewline $f $C
|
||||
close $f
|
||||
set ccCommand "$cc -c $shlib_cflags $cFile"
|
||||
puts stderr $ccCommand
|
||||
eval exec $ccCommand
|
||||
|
||||
# Now compose and execute the ld command that packages the module
|
||||
|
||||
set ldCommand ld
|
||||
foreach item $head {
|
||||
lappend ldCommand $item
|
||||
}
|
||||
lappend ldCommand tcl$modName.o
|
||||
foreach item $tail {
|
||||
lappend ldCommand $item
|
||||
}
|
||||
puts stderr $ldCommand
|
||||
eval exec $ldCommand
|
||||
|
||||
# Clean up working files
|
||||
|
||||
exec /bin/rm $cFile [file rootname $cFile].o
|
||||
}
|
||||
90
tcl/lof.tcl
90
tcl/lof.tcl
@ -1,90 +0,0 @@
|
||||
#------------------------------------------------------------
|
||||
# Last openened files. Lists the last n old files, giving
|
||||
# a summary of each.
|
||||
#
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# Mark Koennecke, July 2009
|
||||
#------------------------------------------------------------
|
||||
|
||||
namespace eval lof {}
|
||||
|
||||
set lof::instrument focus
|
||||
|
||||
set lof::table(Title) /entry1/title
|
||||
set lof::table(Finished) /entry1/end_time
|
||||
set lof::table(Monitor) /entry1/FOCUS/counter/monitor
|
||||
set lof::table(Sample) /entry1/sample/name
|
||||
set lof::table(Temperature) /entry1/sample/temperature
|
||||
set lof::table(Lambda) /entry1/FOCUS/monochromator/lambda
|
||||
|
||||
|
||||
proc lof::getyear {} {
|
||||
return [clock format [clock seconds] -format "%Y"]
|
||||
}
|
||||
#------------------------------------------------------------
|
||||
proc lof::makefilename {num} {
|
||||
global simMode lof::instrument datahome
|
||||
|
||||
set hun [expr $num / 1000]
|
||||
set y [lof::getyear]
|
||||
if {$simMode == 0} {
|
||||
set filename [format "%s/%3.3d/%s%4.4dn%6.6d.hdf" $datahome $hun $lof::instrument $y $num]
|
||||
} else {
|
||||
set filename [format "/afs/psi.ch/project/sinqdata/%s/%s/%3.3d/%s%4.4dn%6.6d.hdf" \
|
||||
$y $lof::instrument $hun $lof::instrument $y $num]
|
||||
}
|
||||
return $filename
|
||||
}
|
||||
#------------------------------------------------------------
|
||||
proc lof::getcurrentnumor {} {
|
||||
global simMode lof::instrument
|
||||
|
||||
if {$simMode == 0} {
|
||||
set txt [sicsdatanumber]
|
||||
set l [split $txt =]
|
||||
return [string trim [lindex $l 1]]
|
||||
} else {
|
||||
set y [getyear]
|
||||
set filnam [format "/afs/psi.ch/project/sinqdata/%s/%s/DataNumber" \
|
||||
$y $instrument]
|
||||
set in [open $filnam r]
|
||||
gets $in line
|
||||
close $in
|
||||
return [string trim $line]
|
||||
}
|
||||
}
|
||||
#-----------------------------------------------------------
|
||||
proc lof::readfiledata {num} {
|
||||
global lof::table NXACC_READ NX_CHAR
|
||||
|
||||
set hdffile [lof::makefilename $num]
|
||||
set nxfile [nx_open $hdffile $NXACC_READ]
|
||||
set names [array names lof::table]
|
||||
append result [file tail $hdffile] \n
|
||||
append result "=======================================================================\n"
|
||||
foreach name $names {
|
||||
set status [catch {nx_openpath $nxfile $lof::table($name)} msg]
|
||||
if {$status == 0} {
|
||||
set data [nx_getdata $nxfile]
|
||||
set type [get_nxds_type $data]
|
||||
if {[string compare $type $NX_CHAR] == 0} {
|
||||
set value [get_nxds_text $data]
|
||||
} else {
|
||||
set value [get_nxds_value $data 0]
|
||||
}
|
||||
append result [format "%-20s:%50s" $name $value] \n
|
||||
}
|
||||
}
|
||||
nx_close $nxfile
|
||||
return $result
|
||||
}
|
||||
#-----------------------------------------------------------
|
||||
proc lof::lof {{num 5}} {
|
||||
set numor [getcurrentnumor]
|
||||
for {set n [expr $numor - $num] } {$n < $numor} {incr n} {
|
||||
append result [readfiledata $n]
|
||||
append result " \n"
|
||||
}
|
||||
return $result
|
||||
}
|
||||
84
tcl/log.tcl
84
tcl/log.tcl
@ -1,84 +0,0 @@
|
||||
#-----------------------------------------------------------------------------
|
||||
# This file implements a LogBook facility for SICS.
|
||||
# Usage:
|
||||
# LogBook - lists the current status
|
||||
# LogBook filename - sets the logbook file name
|
||||
# LogBook on - starts logging, creates new file
|
||||
# LogBook off - closes log file
|
||||
#
|
||||
# Mark Koennecke, June 1997, initially developed for SANS
|
||||
# works using one procedure and an array for data. All internal procedures
|
||||
# start with cli
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
set cliArray(file) default.log
|
||||
set cliArray(status) off
|
||||
set cliArray(number) 0
|
||||
#---------------------------------------------------------------------------
|
||||
proc cliList { } {
|
||||
global cliArray
|
||||
# ClientPut [format " LogBook file: %s\n" $cliArray(file)]
|
||||
# ClientPut [format " Logging: %s " $cliArray(status)] ]
|
||||
append res [format " LogBook file: %s\n" $cliArray(file)] \
|
||||
[format " Logging: %s " $cliArray(status)]
|
||||
return $res
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
proc cliLogOn { } {
|
||||
global cliArray
|
||||
set cmd [list config File $cliArray(file)]
|
||||
set ret [catch {eval $cmd} msg]
|
||||
if { $ret != 0 } {
|
||||
error $msg
|
||||
} else {
|
||||
set l [ split $msg = ]
|
||||
set cliArray(number) [lindex $l 1]
|
||||
set cliArray(status) on
|
||||
}
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc cliLogOff { } {
|
||||
global cliArray
|
||||
set cmd [list config close $cliArray(number)]
|
||||
set ret [catch {eval $cmd} msg]
|
||||
if { $ret != 0 } {
|
||||
error $msg
|
||||
} else {
|
||||
set cliArray(status) off
|
||||
}
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
proc logbook args {
|
||||
global cliArray
|
||||
#---- first case: a listing
|
||||
if { [llength $args] == 0} {
|
||||
return [cliList]
|
||||
}
|
||||
#---- there must be an argument
|
||||
set argument [lindex $args 0]
|
||||
#---- on/ off
|
||||
if {[string compare "on" $argument] == 0} {
|
||||
set ret [catch {cliLogOn} msg]
|
||||
if { $ret != 0 } {
|
||||
error $msg
|
||||
} else {
|
||||
ClientPut OK
|
||||
}
|
||||
} elseif {[string compare "off" $argument] == 0} {
|
||||
set ret [catch {cliLogOff} msg]
|
||||
if { $ret != 0 } {
|
||||
error $msg
|
||||
} else {
|
||||
ClientPut OK
|
||||
}
|
||||
} elseif {[string compare "file" $argument] >= 0} {
|
||||
if {[llength $args] < 1} {
|
||||
error "ERROR: nor filename specified for LogBook"
|
||||
}
|
||||
set cliArray(file) [lindex $args 1]
|
||||
} elseif {[string compare "no" $argument] == 0} {
|
||||
ClientPut $cliArray(number)
|
||||
} else {
|
||||
error [format "ERROR: unknown argument %s to LogBook" $argument]
|
||||
}
|
||||
}
|
||||
145
tcl/nhq202m.tcl
145
tcl/nhq202m.tcl
@ -1,145 +0,0 @@
|
||||
#----------------------------------------------------------
|
||||
# This is a scriptcontext driver for a NHQ 202M high
|
||||
# voltage power supply as used at the POLDI for the
|
||||
# detector. This has a peculiar protocol and requires the
|
||||
# charbychar protocol driver.
|
||||
#
|
||||
# If this responds only with ?WCN, then it is on the wrong
|
||||
# channel.
|
||||
#
|
||||
# Mark Koennecke, April 2010
|
||||
#--------------------------------------------------------
|
||||
|
||||
namespace eval nhq202m {}
|
||||
|
||||
#-------------------------------------------------------
|
||||
# Sometimes numbers come in the form: polarity/mantissse/exponent
|
||||
# This checks for this and converts it into a proper number
|
||||
#-------------------------------------------------------
|
||||
proc nhq202m::fixnumber {num} {
|
||||
set c [string index $num 0]
|
||||
if {[string compare $c -] == 0} {
|
||||
set num [string range $num 1 end]
|
||||
}
|
||||
clientput $num
|
||||
if {[string first - $num] > 0} {
|
||||
set l [split $num -]
|
||||
set man [string trimleft [lindex $l 0] 0]
|
||||
set exp [string trimleft [lindex $l 1] 0]
|
||||
clientput "$num, $man, $exp"
|
||||
return [expr $man * pow(10,-$exp)]
|
||||
} elseif { [string first + $num] > 0} {
|
||||
set l [split $num +]
|
||||
set man [string trimleft [lindex $l 0] 0]
|
||||
set exp [string trimleft [lindex $l 1] 0]
|
||||
return [expr $man * pow(10,$exp)]
|
||||
} else {
|
||||
return $num
|
||||
}
|
||||
}
|
||||
#-------------------------------------------------------
|
||||
proc nhq202m::sendreadcommand {command} {
|
||||
sct send $command
|
||||
return readreply
|
||||
}
|
||||
#--------------------------------------------------------
|
||||
proc nhq202m::readreply {} {
|
||||
set val [sct result]
|
||||
if {[string first ? $val] >= 0} {
|
||||
clientput "Read Command not understood, result = $val"
|
||||
} else {
|
||||
sct update [nhq202m::fixnumber $val]
|
||||
}
|
||||
return idle
|
||||
}
|
||||
#--------------------------------------------------------
|
||||
proc nhq202m::sendwrite {command} {
|
||||
set val [sct target]
|
||||
sct send [format "%s=%d" $command $val]
|
||||
return writereply
|
||||
}
|
||||
#------------------------------------------------------
|
||||
proc nhq202m::writereply {} {
|
||||
set val [sct result]
|
||||
if {[string first ? $val] >= 0} {
|
||||
clientput "Write command not understood, result = $val"
|
||||
}
|
||||
[sct controller] queue [sct] progress read
|
||||
return idle
|
||||
}
|
||||
#----------------------------------------------------
|
||||
proc nhq202m::startwrite {} {
|
||||
hupdate [sct]/stop 0
|
||||
set num [sct numpower]
|
||||
set com [format "D%1.1d" $num]
|
||||
nhq202m::sendwrite $com
|
||||
return setreply
|
||||
}
|
||||
#----------------------------------------------------
|
||||
proc nhq202m::setreply {} {
|
||||
set val [sct result]
|
||||
if {[string first ? $val] >= 0} {
|
||||
clientput "Write command not understood, result = $val"
|
||||
}
|
||||
set num [sct numpower]
|
||||
sct send [format "G%1.1d" $num]
|
||||
return goreply
|
||||
}
|
||||
#----------------------------------------------------
|
||||
proc nhq202m::goreply {} {
|
||||
set badcodes [list MAN ERR OFF]
|
||||
set val [sct result]
|
||||
if {[string first ? $val] >= 0} {
|
||||
clientput "Write command not understood, result = $val"
|
||||
}
|
||||
set l [split $val =]
|
||||
set code [string trim [lindex $l 1]]
|
||||
if {[lsearch $badcodes $code] >= 0} {
|
||||
hupdate [sct]/stop 1
|
||||
error "Bad code in $val, probably front panel switches fucked up"
|
||||
}
|
||||
return idle
|
||||
}
|
||||
#----------------------------------------------------
|
||||
proc nhq202m::makehv {name sct num} {
|
||||
makesctdriveobj $name float mugger NHQ202M $sct
|
||||
hfactory /sics/${name}/tolerance plain mugger int
|
||||
hset /sics/${name}/tolerance 2
|
||||
hfactory /sics/${name}/upperlimit plain mugger int
|
||||
hset /sics/${name}/upperlimit 4000
|
||||
hfactory /sics/${name}/lowerlimit plain mugger int
|
||||
hset /sics/${name}/lowerlimit 0
|
||||
hfactory /sics/${name}/stop plain mugger int
|
||||
hset /sics/${name}/stop 0
|
||||
|
||||
hsetprop /sics/${name} checklimits stddrive::stdcheck $name
|
||||
hsetprop /sics/${name} checkstatus stddrive::stdstatus $name
|
||||
hsetprop /sics/${name} halt stddrive::stop $name
|
||||
|
||||
hsetprop /sics/${name} read nhq202m::sendreadcommand [format "U%1.1d" $num]
|
||||
hsetprop /sics/${name} readreply nhq202m::readreply
|
||||
hsetprop /sics/${name} numpower $num
|
||||
hsetprop /sics/${name} write nhq202m::startwrite
|
||||
hsetprop /sics/${name} setreply nhq202m::setreply
|
||||
hsetprop /sics/${name} goreply nhq202m::goreply
|
||||
$sct write /sics/${name}
|
||||
$sct poll /sics/${name} 180
|
||||
$sct queue /sics/${name} progress read
|
||||
|
||||
hfactory /sics/${name}/ramp plain mugger int
|
||||
hsetprop /sics/${name}/ramp read nhq202m::sendreadcommand [format "V%1.1d" $num]
|
||||
hsetprop /sics/${name}/ramp readreply nhq202m::readreply
|
||||
hsetprop /sics/${name}/ramp write nhq202m::sendwrite [format "V%1.1d" $num]
|
||||
hsetprop /sics/${name}/ramp writereply nhq202m::writereply
|
||||
$sct poll /sics/${name}/ramp 180
|
||||
$sct write /sics/${name}/ramp
|
||||
$sct queue /sics/${name}/ramp progress read
|
||||
|
||||
|
||||
hfactory /sics/${name}/current plain mugger int
|
||||
hsetprop /sics/${name}/current read nhq202m::sendreadcommand [format "N%1.1d" $num]
|
||||
hsetprop /sics/${name}/current readreply nhq202m::readreply
|
||||
$sct poll /sics/${name}/current 180
|
||||
$sct queue /sics/${name}/current progress read
|
||||
|
||||
}
|
||||
157
tcl/nvs.tcl
157
tcl/nvs.tcl
@ -1,157 +0,0 @@
|
||||
#-------------------------------------------------------------------------
|
||||
# This is a scriptcontext based driver for the NVS at SANS2. This NVS has
|
||||
# the nasty feauture that its terminators are command dependent.
|
||||
#
|
||||
# Mark Koennecke, April 2009
|
||||
#-----------------------------------------------------------------------
|
||||
makesctcontroller nvssct varterm psts229.psi.ch:3007 \n 30
|
||||
#makesctcontroller nvssct varterm localhost:8080 \n 30
|
||||
nvssct send "\\:REM\n"
|
||||
nvssct debug -1
|
||||
MakeSecNVS nvs tilt nvssct
|
||||
#----------------------------------------------------------------------------------
|
||||
# handle parameters first: Most are in the list. MODE is treated special, as an
|
||||
# anchor for finding the status part of the reply and as the polled node used for
|
||||
# updating the parameter list. Date, time and com mode are omitted.
|
||||
#-----------------------------------------------------------------------------------
|
||||
set nvsparlist [list R_SPEED A_SPEED P_LOSS R_CURRENT T_ROT T_INL T_OUT F_RATE A_VAC \
|
||||
V_OSC V_BCU Hz]
|
||||
|
||||
foreach par $nvsparlist {
|
||||
hfactory /sics/nvs/${par} plain internal float
|
||||
nvssct connect /sics/nvs/${par}
|
||||
}
|
||||
#-----------------------------------------------------------------
|
||||
proc nvsstatus {} {
|
||||
sct send "\n:???\n"
|
||||
return nvsstatusreply
|
||||
}
|
||||
#----------------------------------------------------------------
|
||||
# We purposely disregard the geterror mechanism here: it is better to
|
||||
# have an old value rather then no value
|
||||
#-----------------------------------------------------------------
|
||||
proc nvsstatusreply {} {
|
||||
global nvsparlist
|
||||
set reply [sct result]
|
||||
if {[string first ERR $reply] >= 0 \
|
||||
|| [string first ASCERR $reply] >= 0} {
|
||||
clientput "ERROR: $reply while reading NVS, parameter NOT updated"
|
||||
return idle
|
||||
}
|
||||
set idx [string first MODE: $reply]
|
||||
if {$idx < 0} {
|
||||
clientput "Invalid status reponse $reply received from NVS"
|
||||
return idle
|
||||
}
|
||||
set reply [string range $reply $idx end]
|
||||
set parlist [split $reply /]
|
||||
foreach pair $parlist {
|
||||
set l [split $pair :]
|
||||
set par [string trim [lindex $l 0]]
|
||||
set value [string trim [lindex $l 1]]
|
||||
if {[lsearch $nvsparlist $par] >= 0 || [string first MODE $par] >= 0} {
|
||||
catch {hupdate /sics/nvs/${par} $value} msg
|
||||
}
|
||||
}
|
||||
set speed [hval /sics/nvs/A_SPEED]
|
||||
hupdate /sics/nvs $speed
|
||||
return idle
|
||||
}
|
||||
#-------------------------------------------------------------------------------
|
||||
set path /sics/nvs/MODE
|
||||
hfactory $path plain internal text
|
||||
hsetprop $path read nvsstatus
|
||||
hsetprop $path nvsstatusreply nvsstatusreply
|
||||
nvssct poll $path 60
|
||||
#=================================================================================
|
||||
# This section cares for driving the NVS. Please note that there are two modes:
|
||||
# at low speeds the NVS must be started before over 3000 RPM, a new value can be set.
|
||||
# If ths NVS is already at speed, this step can be saved.
|
||||
# Also we have to check for limits and forbidden speed regions
|
||||
#--------------------------------------------------------------------------------
|
||||
set nvsrange [list -20 28800]
|
||||
set nvsforbidden [list {3600 4500} {7800 10500} {21500 23500}]
|
||||
#--------------------------------------------------------------------------------
|
||||
proc nvscheck {} {
|
||||
global nvsrange nvsforbidden
|
||||
set target [sct target]
|
||||
set min [lindex $nvsrange 0]
|
||||
set max [lindex $nvsrange 1]
|
||||
if {$target < $min || $target > $max} {
|
||||
error "$target is out of range"
|
||||
}
|
||||
foreach range $nvsforbidden {
|
||||
set min [lindex $range 0]
|
||||
set max [lindex $range 1]
|
||||
if {$target > $min && $target < $max} {
|
||||
error "$target is in forbidden region"
|
||||
}
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#--------------------------------------------------------------------------------
|
||||
# Halting for a NVS is interpreted as: leave at current speed
|
||||
#--------------------------------------------------------------------------------
|
||||
proc nvshalt {} {
|
||||
set current [hval /sics/nvs]
|
||||
set send [format "\r:SDR %d\n" [expr int($current)]]
|
||||
return nvsreply
|
||||
}
|
||||
#---------------------------------------------------------------------------------
|
||||
proc nvsreply {} {
|
||||
set reply [sct result]
|
||||
if {[string first ERR $reply] >= 0 \
|
||||
|| [string first ASCERR $reply] >= 0} {
|
||||
clientput "ERROR: $reply while driving NVS"
|
||||
}
|
||||
return idle
|
||||
}
|
||||
#--------------------------------------------------------------------------------
|
||||
# checking status
|
||||
#--------------------------------------------------------------------------------
|
||||
proc nvscheckstatus {} {
|
||||
set mode [sct runmode]
|
||||
if {[string first start $mode] >= 0} {
|
||||
return idle
|
||||
}
|
||||
set target [sct target]
|
||||
set actual [hval /sics/nvs/A_SPEED]
|
||||
if {abs($target - $actual) < 5} {
|
||||
wait 20
|
||||
return idle
|
||||
}
|
||||
nvssct queue /sics/nvs/MODE progress read
|
||||
return busy
|
||||
}
|
||||
#--------------------------------------------------------------------------------
|
||||
proc nvswrite {} {
|
||||
set target [sct target]
|
||||
set actual [hval /sics/nvs/A_SPEED]
|
||||
if {$target < 50 } {
|
||||
sct send "\r:HAL\n"
|
||||
sct runmode halt
|
||||
return nvsreply
|
||||
}
|
||||
if {$actual >= 3000} {
|
||||
sct send [format "\r:SDR %d\n" [expr int($target)]]
|
||||
sct runmode normal
|
||||
} else {
|
||||
sct send "\r:SST\n"
|
||||
clientput "NVS started, check manually when done"
|
||||
sct runmode start
|
||||
}
|
||||
return nvsreply
|
||||
}
|
||||
#---------------------------------------------------------------------------------
|
||||
hsetprop /sics/nvs checklimits nvscheck
|
||||
hsetprop /sics/nvs checkstatus nvscheckstatus
|
||||
hsetprop /sics/nvs halt nvshalt
|
||||
hsetprop /sics/nvs nvsreply nvsreply
|
||||
hsetprop /sics/nvs write nvswrite
|
||||
hsetprop /sics/nvs runmode normal
|
||||
nvssct write /sics/nvs
|
||||
|
||||
nvssct queue /sics/nvs/MODE progress read
|
||||
nvs tilt
|
||||
|
||||
|
||||
163
tcl/nvs20m.tcl
163
tcl/nvs20m.tcl
@ -1,163 +0,0 @@
|
||||
#-------------------------------------------------------------------------
|
||||
# This is a scriptcontext based driver for the NVS at SANS.
|
||||
#
|
||||
# script chains:
|
||||
#
|
||||
# - status reading: sitting at the Status node
|
||||
# nvststatus - nvsstatusreply
|
||||
# - driving:
|
||||
# nvswrite - nvsreply
|
||||
#
|
||||
# Mark Koennecke, May 2009
|
||||
#-----------------------------------------------------------------------
|
||||
makesctcontroller nvssct std psts223.psi.ch:3006 \n 30
|
||||
#makesctcontroller nvssct std localhost:8080 \n 30
|
||||
nvssct send "REM\n"
|
||||
nvssct debug -1
|
||||
MakeSecNVS nvs tilt nvssct
|
||||
#----------------------------------------------------------------------------------
|
||||
# handle parameters first: Most are in the list. MODE is treated special, as an
|
||||
# anchor for finding the status part of the reply and as the polled node used for
|
||||
# updating the parameter list. Date, time and com mode are omitted.
|
||||
#-----------------------------------------------------------------------------------
|
||||
set nvsparlist [list S_DREH I_DREH P_VERL STROM T_ROT T_VOR T_RUECK DURCHFL VAKUUM \
|
||||
BESCHL BCU Hz]
|
||||
|
||||
foreach par $nvsparlist {
|
||||
hfactory /sics/nvs/${par} plain internal float
|
||||
nvssct connect /sics/nvs/${par}
|
||||
}
|
||||
#-----------------------------------------------------------------
|
||||
proc nvsstatus {} {
|
||||
sct send "???\n"
|
||||
return nvsstatusreply
|
||||
}
|
||||
#----------------------------------------------------------------
|
||||
# We purposely disregard the geterror mechanism here: it is better to
|
||||
# have an old value rather then no value
|
||||
#-----------------------------------------------------------------
|
||||
proc nvsstatusreply {} {
|
||||
global nvsparlist
|
||||
set reply [sct result]
|
||||
if {[string first ERR $reply] >= 0 \
|
||||
|| [string first ASCERR $reply] >= 0} {
|
||||
clientput "ERROR: $reply while reading NVS, parameter NOT updated"
|
||||
return idle
|
||||
}
|
||||
set idx [string first Status: $reply]
|
||||
if {$idx < 0} {
|
||||
clientput "Invalid status reponse $reply received from NVS"
|
||||
return idle
|
||||
}
|
||||
set reply [string range $reply $idx end]
|
||||
set parlist [split $reply /]
|
||||
foreach pair $parlist {
|
||||
set l [split $pair :]
|
||||
set par [string trim [lindex $l 0]]
|
||||
set value [string trim [lindex $l 1]]
|
||||
if {[lsearch $nvsparlist $par] >= 0 || [string first Status $par] >= 0} {
|
||||
catch {hupdate /sics/nvs/${par} $value} msg
|
||||
}
|
||||
}
|
||||
set speed [hval /sics/nvs/I_DREH]
|
||||
hupdate /sics/nvs $speed
|
||||
return idle
|
||||
}
|
||||
#-------------------------------------------------------------------------------
|
||||
set path /sics/nvs/Status
|
||||
hfactory $path plain internal text
|
||||
hsetprop $path read nvsstatus
|
||||
hsetprop $path nvsstatusreply nvsstatusreply
|
||||
nvssct poll $path 60
|
||||
#=================================================================================
|
||||
# This section cares for driving the NVS. Please note that there are two modes:
|
||||
# at low speeds the NVS must be started before over 3000 RPM, a new value can be set.
|
||||
# If ths NVS is already at speed, this step can be saved.
|
||||
# Also we have to check for limits and forbidden speed regions
|
||||
#--------------------------------------------------------------------------------
|
||||
set nvsrange [list -20 28800]
|
||||
set nvsforbidden [list {3600 4600} {7600 9600} {1 3599} ]
|
||||
#--------------------------------------------------------------------------------
|
||||
proc nvscheck {} {
|
||||
global nvsrange nvsforbidden
|
||||
set target [sct target]
|
||||
set min [lindex $nvsrange 0]
|
||||
set max [lindex $nvsrange 1]
|
||||
if {$target < $min || $target > $max} {
|
||||
error "$target is out of range"
|
||||
}
|
||||
foreach range $nvsforbidden {
|
||||
set min [lindex $range 0]
|
||||
set max [lindex $range 1]
|
||||
if {$target > $min && $target < $max} {
|
||||
error "$target is in forbidden region"
|
||||
}
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#--------------------------------------------------------------------------------
|
||||
# Halting for a NVS is interpreted as: leave at current speed
|
||||
#--------------------------------------------------------------------------------
|
||||
proc nvshalt {} {
|
||||
set current [hval /sics/nvs]
|
||||
set send [format "SDR %d\n" [expr int($current)]]
|
||||
return nvsreply
|
||||
}
|
||||
#---------------------------------------------------------------------------------
|
||||
proc nvsreply {} {
|
||||
set reply [sct result]
|
||||
if {[string first ERR $reply] >= 0 \
|
||||
|| [string first ASCERR $reply] >= 0} {
|
||||
clientput "ERROR: $reply while driving NVS"
|
||||
}
|
||||
return idle
|
||||
}
|
||||
#--------------------------------------------------------------------------------
|
||||
# checking status
|
||||
#--------------------------------------------------------------------------------
|
||||
proc nvscheckstatus {} {
|
||||
set mode [sct runmode]
|
||||
if {[string first start $mode] >= 0} {
|
||||
return idle
|
||||
}
|
||||
set target [sct target]
|
||||
set actual [hval /sics/nvs/I_DREH]
|
||||
if {abs($target - $actual) < 5} {
|
||||
wait 20
|
||||
return idle
|
||||
}
|
||||
nvssct queue /sics/nvs/Status progress read
|
||||
return busy
|
||||
}
|
||||
#--------------------------------------------------------------------------------
|
||||
proc nvswrite {} {
|
||||
set target [sct target]
|
||||
set actual [hval /sics/nvs/I_DREH]
|
||||
if {$target < 50 } {
|
||||
sct send "HAL\n"
|
||||
sct runmode halt
|
||||
return nvsreply
|
||||
}
|
||||
if {$actual >= 3000} {
|
||||
sct send [format "SDR %d\n" [expr int($target)]]
|
||||
sct runmode normal
|
||||
} else {
|
||||
sct send "SST\n"
|
||||
clientput "NVS started, check manually when done"
|
||||
sct runmode start
|
||||
}
|
||||
return nvsreply
|
||||
}
|
||||
#---------------------------------------------------------------------------------
|
||||
hsetprop /sics/nvs checklimits nvscheck
|
||||
hsetprop /sics/nvs checkstatus nvscheckstatus
|
||||
hsetprop /sics/nvs halt nvshalt
|
||||
hsetprop /sics/nvs nvsreply nvsreply
|
||||
hsetprop /sics/nvs write nvswrite
|
||||
hsetprop /sics/nvs runmode normal
|
||||
nvssct write /sics/nvs
|
||||
|
||||
nvssct queue /sics/nvs/Status progress read
|
||||
nvs tilt
|
||||
|
||||
|
||||
@ -1,29 +0,0 @@
|
||||
# parray:
|
||||
# Print the contents of a global array on stdout.
|
||||
#
|
||||
# SCCS: @(#) parray.tcl 1.9 96/02/16 08:56:44
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
proc parray {a {pattern *}} {
|
||||
upvar 1 $a array
|
||||
if ![array exists array] {
|
||||
error "\"$a\" isn't an array"
|
||||
}
|
||||
set maxl 0
|
||||
foreach name [lsort [array names array $pattern]] {
|
||||
if {[string length $name] > $maxl} {
|
||||
set maxl [string length $name]
|
||||
}
|
||||
}
|
||||
set maxl [expr {$maxl + [string length $a] + 2}]
|
||||
foreach name [lsort [array names array $pattern]] {
|
||||
set nameString [format %s(%s) $a $name]
|
||||
puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
|
||||
}
|
||||
}
|
||||
138
tcl/pfeiffer.tcl
138
tcl/pfeiffer.tcl
@ -1,138 +0,0 @@
|
||||
#---------------------------------------------------------
|
||||
# This is a new asynchronous driver for the Pfeiffer
|
||||
# Vacuum measurement device. This driver has been redone
|
||||
# in order to better integrate it into the Hipadaba tree
|
||||
# at FOCUS.
|
||||
#
|
||||
# The pfeiffer device is somewhat shitty in that it cannot
|
||||
# be switched on all the time. What is implemented now is
|
||||
# this: the looser has to switch the thing on via the state
|
||||
# field. After that values are read any 2 minutes. After 20
|
||||
# minutes the thing switches itself off again.
|
||||
#
|
||||
# Then there is a funny protocol. A normal command is easy:
|
||||
# Host: command <lf>
|
||||
# Pfeiffer: <ACK> or <NACK> <cr><lf>
|
||||
# It gets involved when a parameter is requested. Then it looks
|
||||
# like this:
|
||||
# Host: command <lf>
|
||||
# Pfeiffer: <ACK>or <NACK> <cr><lf>
|
||||
# Host: <ENQ>
|
||||
# Pfeiffer: something,value <cr><lf>
|
||||
#
|
||||
# The script chains:
|
||||
# pfiffstate - pfiffstatereply
|
||||
# pfiffreadsensor - pfiffenq - pfiffreply
|
||||
#
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# Mark Koennecke, March 2009
|
||||
#---------------------------------------------------------
|
||||
MakeSICSObj pfiff Vacuum
|
||||
#makesctcontroller pfiffsct pfeiffer localhost:8080
|
||||
makesctcontroller pfiffsct pfeiffer $ts:3009
|
||||
#pfiffsct debug -1
|
||||
set pfiffpar [list Antitrumpet Be-filter Flightpath Sample-Chamber]
|
||||
|
||||
#-----------------------------------------------------
|
||||
proc pfiffstate {} {
|
||||
set val [sct target]
|
||||
if {[string compare $val on] == 0} {
|
||||
sct send "SEN ,2,2,2,2,0,0"
|
||||
sct utime devon
|
||||
} else {
|
||||
sct send "SEN ,1,1,1,1,0,0"
|
||||
}
|
||||
return pfiffstatereply
|
||||
}
|
||||
#----------------------------------------------------
|
||||
proc pfiffstatereply {} {
|
||||
sct update [sct target]
|
||||
return idle
|
||||
}
|
||||
#------------------------------------------------------
|
||||
# This tests for the state being off
|
||||
# This also tests if the device has been on for more
|
||||
# then 20 minutes. If so it is switched off
|
||||
#------------------------------------------------------
|
||||
proc pfiffreadsensor {num} {
|
||||
set test [hval /sics/pfiff/state]
|
||||
if {[string compare $test off] == 0} {
|
||||
sct update "sensor off"
|
||||
return idle
|
||||
}
|
||||
set time [hgetpropval /sics/pfiff/state devon]
|
||||
if {[clock seconds] > $time + 20*60} {
|
||||
hset /sics/pfiff/state off
|
||||
return idle
|
||||
}
|
||||
if {$num < 5} {
|
||||
sct send [format "PR%1.1d" $num]
|
||||
return pfiffenq
|
||||
} else {
|
||||
return idle
|
||||
}
|
||||
}
|
||||
#-------------------------------------------------------
|
||||
proc pfiffenq {} {
|
||||
sct send "<ENQ>"
|
||||
return pfiffreply
|
||||
}
|
||||
#-------------------------------------------------------
|
||||
proc pfiffreply {} {
|
||||
set reply [sct result]
|
||||
if {[string first ERR $reply] >= 0 ||
|
||||
[string first ASCER $reply] >= 0} {
|
||||
sct geterror $reply
|
||||
return idle
|
||||
}
|
||||
set l [split $reply ,]
|
||||
sct update [lindex $l 1]
|
||||
hdelprop [sct] geterror
|
||||
return idle
|
||||
}
|
||||
#--------------------------------------------------------
|
||||
proc pfiffidle {} {
|
||||
return idle
|
||||
}
|
||||
#---------------------------------------------------------
|
||||
set count 1
|
||||
foreach p $pfiffpar {
|
||||
hfactory /sics/pfiff/$p plain internal text
|
||||
hsetprop /sics/pfiff/$p read "pfiffreadsensor $count"
|
||||
hsetprop /sics/pfiff/$p pfiffenq pfiffenq
|
||||
hsetprop /sics/pfiff/$p pfiffreply pfiffreply
|
||||
pfiffsct poll /sics/pfiff/$p 120
|
||||
incr count
|
||||
}
|
||||
|
||||
hfactory /sics/pfiff/state plain spy text
|
||||
hupdate /sics/pfiff/state off
|
||||
hsetprop /sics/pfiff/state values on,off
|
||||
hsetprop /sics/pfiff/state write pfiffstate
|
||||
hsetprop /sics/pfiff/state pfiffstatereply pfiffstatereply
|
||||
pfiffsct write /sics/pfiff/state
|
||||
#------------------------------------------------------
|
||||
proc pfiffread {num} {
|
||||
global pfiffpar
|
||||
set par [lindex $pfiffpar [expr $num -1]]
|
||||
return [hval /sics/pfiff/$par]
|
||||
}
|
||||
#--------------------------------------------------------
|
||||
proc vac {} {
|
||||
global pfiffpar
|
||||
set test [hval /sics/pfiff/state]
|
||||
if {[string first off $test] >= 0} {
|
||||
hset /sics/pfiff/state on
|
||||
foreach p $pfiffpar {
|
||||
pfiffsct queue /sics/pfiff/$p progress read
|
||||
}
|
||||
return "Switched Pfeiffer on, try to read again in a couple of seconds"
|
||||
}
|
||||
append result "Antitrumpet : " [pfiffread 1] "\n"
|
||||
append result "Berylium filter : " [pfiffread 2] "\n"
|
||||
append result "Flightpath : " [pfiffread 3] "\n"
|
||||
append result "Sample chamber : " [pfiffread 4] "\n"
|
||||
return $result
|
||||
}
|
||||
Publish vac User
|
||||
302
tcl/phytron.tcl
302
tcl/phytron.tcl
@ -1,302 +0,0 @@
|
||||
#------------------------------------------------------------------
|
||||
# This is driver for the combination Phytron MCC-2 Motor Controller
|
||||
# and SICS using the scriptcontext asynchronous I/O system. The
|
||||
# MCC-2 has a funny protocl as that messages are enclosed into
|
||||
# <STX> data <ETX> sequences. This protocol is handled by the
|
||||
# C-language phytron protocol handler. Per default, the MCC-2 is
|
||||
# configured to use 57600 baud. I have configured it to use 9600
|
||||
# baud and it ought to remember this. The command to change this
|
||||
# 0IC1S9600, the command to read this is 0IC1R.
|
||||
#
|
||||
# So, if this thing does not work on a serial port then the solution is
|
||||
# to set the terminal server to 57600 and try again. And set the baud rate
|
||||
# or leave it.
|
||||
#
|
||||
# There are surely many ways to use the MCC-2. It supports two axes, X and Y.
|
||||
# All examples below are given for X only. This driver uses it in
|
||||
# this way:
|
||||
#
|
||||
# Nothing works properly without a reference run. The reference run is done
|
||||
# in the following way:
|
||||
# 1) Send it into the negative limit switch with 0X0-
|
||||
# 2) Set the mechanical position with 0XP20Swert to the negative limit
|
||||
# 3) Set the encoder position with 0XP22Swert to the negative limit
|
||||
#
|
||||
# Position ever afterwards with 0XAwert, read encoder with 0XP22R
|
||||
#
|
||||
# While driving 0X=H return ACKN, else ACKE
|
||||
#
|
||||
# Stopping goes via 0XSN
|
||||
#
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# Script chains:
|
||||
#
|
||||
# - reading position:
|
||||
# readpos - posrcv
|
||||
#
|
||||
# - writing postion:
|
||||
# setpos - setrcv
|
||||
#
|
||||
# - reading status:
|
||||
# sendstatus - rcvstatus - statpos
|
||||
#
|
||||
# - reading speed:
|
||||
# readspeed - rcvspeed
|
||||
#
|
||||
# - setting speed:
|
||||
# writespeed - rcvwspeed - rcvspeed
|
||||
#
|
||||
# Mark Koennecke, June 2009
|
||||
#
|
||||
# Added code to switch a brake on for schneider_m2
|
||||
#
|
||||
# Mark Koennecke, September 2009
|
||||
#
|
||||
# Added code to support the speed parameter
|
||||
#
|
||||
# Mark Koennecke, December 2009
|
||||
# TODO: speed still has to be tested: 02-12-2009
|
||||
#-------------------------------------------------------------------------
|
||||
|
||||
namespace eval phytron {}
|
||||
|
||||
#-----------------------------------------------------------------------
|
||||
proc phytron::check {} {
|
||||
set data [sct result]
|
||||
if {[string first AscErr $data] >= 0} {
|
||||
error $data
|
||||
}
|
||||
return $data
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc phytron::readpos {axis} {
|
||||
sct send "0${axis}P22R"
|
||||
return posrcv
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc phytron::posrcv {} {
|
||||
set data [phytron::check]
|
||||
set pos [string range $data 3 end]
|
||||
sct update $pos
|
||||
return idle
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc phytron::setpos {axis name} {
|
||||
set val [sct target]
|
||||
sct send "0${axis}A$val"
|
||||
hupdate /sics/${name}/status run
|
||||
return setrcv
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc phytron::setrcv {controller name} {
|
||||
set data [phytron::check]
|
||||
if {[string first NACK $data] >= 0} {
|
||||
error "Invalid command"
|
||||
}
|
||||
$controller queue /sics/${name}/status progress read
|
||||
return idle
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
proc phytron::sendstatus {axis} {
|
||||
sct send "0${axis}=H"
|
||||
return rcvstatus
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
proc phytron::rcvstatus {axis controller} {
|
||||
set status [catch {phytron::check} data]
|
||||
if {$status != 0} {
|
||||
sct update error
|
||||
clientput $error
|
||||
}
|
||||
if {[string first ACKN $data] >= 0} {
|
||||
sct update run
|
||||
$controller queue [sct] progress read
|
||||
}
|
||||
if {[string first ACKE $data] >= 0} {
|
||||
phytron::readpos $axis
|
||||
return posrcv
|
||||
}
|
||||
return idle
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
proc phytron::statpos {axis name} {
|
||||
set data [phytron::check]
|
||||
set pos [string range $data 3 end]
|
||||
hupdate /sics/${name}/hardposition $pos
|
||||
sct send "0${axis}=I+"
|
||||
return statposlim
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc phytron::statposlim {axis} {
|
||||
set data [phytron::check]
|
||||
if {[string first ACKE $data] >= 0} {
|
||||
sct update error
|
||||
clientput "Hit positive limit switch"
|
||||
return idle
|
||||
}
|
||||
sct send "0${axis}=I-"
|
||||
return statneglim
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc phytron::statneglim {axis} {
|
||||
set data [phytron::check]
|
||||
if {[string first ACKE $data] >= 0} {
|
||||
sct update error
|
||||
clientput "Hit negative limit switch"
|
||||
return idle
|
||||
}
|
||||
sct send "0${axis}=E"
|
||||
return statend
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc phytron::statend {axis} {
|
||||
set data [phytron::check]
|
||||
if {[string first ACKE $data] >= 0} {
|
||||
sct update error
|
||||
clientput "Electronics error"
|
||||
return idle
|
||||
}
|
||||
sct update idle
|
||||
return idle
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc phytron::readspeed {axis} {
|
||||
sct send "0${axis}P14R"
|
||||
return rcvspeed
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc phytron::rcvspeed {} {
|
||||
set data [phytron::check]
|
||||
set speed [string range $data 3 end]
|
||||
sct update $speed
|
||||
return idle
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc phytron::writespeed {axis} {
|
||||
set val [sct target]
|
||||
sct send "0${axis}P14S$val"
|
||||
return rcvwspeed
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc phytron::rcvwspeed {axis} {
|
||||
set data [phytron::check]
|
||||
if {[string first NACK $data] >= 0} {
|
||||
error "Invalid command"
|
||||
}
|
||||
return [phytron::readspeed $axis]
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
proc phytron::halt {controller axis} {
|
||||
$controller send "0${axis}SN"
|
||||
return Done
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc phytron::refrun {name controller axis lowlim} {
|
||||
set path /sics/${name}/status
|
||||
$controller send "0${axis}0-"
|
||||
hupdate $path run
|
||||
set motstat run
|
||||
wait 3
|
||||
while {[string compare $motstat run] == 0} {
|
||||
$controller queue $path progress read
|
||||
wait 1
|
||||
set motstat [string trim [hval $path]]
|
||||
}
|
||||
$controller transact "0${axis}P20S$lowlim"
|
||||
$controller transact "0${axis}P22S$lowlim"
|
||||
return Done
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
proc phytron::defpos {controller axis value} {
|
||||
$controller transact "0${axis}P20S$value"
|
||||
$controller transact "0${axis}P22S$value"
|
||||
return Done
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc phytron::make {name axis controller lowlim upperlim} {
|
||||
MakeSecMotor $name
|
||||
|
||||
hdel /sics/${name}/hardupperlim
|
||||
hdel /sics/${name}/hardlowerlim
|
||||
hfactory /sics/${name}/hardupperlim plain internal float
|
||||
hfactory /sics/${name}/hardlowerlim plain internal float
|
||||
$name hardlowerlim $lowlim
|
||||
$name softlowerlim $lowlim
|
||||
$name hardupperlim $upperlim
|
||||
$name softupperlim $upperlim
|
||||
|
||||
hsetprop /sics/${name}/hardposition read phytron::readpos $axis
|
||||
hsetprop /sics/${name}/hardposition posrcv phytron::posrcv
|
||||
$controller poll /sics/${name}/hardposition 60
|
||||
|
||||
hsetprop /sics/${name}/hardposition write phytron::setpos $axis $name
|
||||
hsetprop /sics/${name}/hardposition setrcv phytron::setrcv $controller $name
|
||||
$controller write /sics/${name}/hardposition
|
||||
|
||||
hsetprop /sics/${name}/status read phytron::sendstatus $axis
|
||||
hsetprop /sics/${name}/status rcvstatus phytron::rcvstatus $axis $controller
|
||||
hsetprop /sics/${name}/status posrcv phytron::statpos $axis $name
|
||||
hsetprop /sics/${name}/status statposlim phytron::statposlim $axis
|
||||
hsetprop /sics/${name}/status statneglim phytron::statneglim $axis
|
||||
hsetprop /sics/${name}/status statend phytron::statend $axis
|
||||
$controller poll /sics/${name}/status 60
|
||||
|
||||
hfactory /sics/${name}/speed plain user float
|
||||
hsetprop /sics/${name}/speed read "phytron::readspeed $axis"
|
||||
hsetprop /sics/${name}/speed rcvspeed "phytron::rcvspeed"
|
||||
hsetprop /sics/${name}/speed write "phytron::writespeed $axis"
|
||||
hsetprop /sics/${name}/speed rcvwspeed "phytron::rcvwspeed $axis"
|
||||
$controller poll /sics/${name}/speed 60
|
||||
$controller write /sics/${name}/speed
|
||||
|
||||
$name makescriptfunc halt "phytron::halt $controller $axis" user
|
||||
|
||||
$name makescriptfunc refrun "phytron::refrun $name $controller $axis $lowlim" user
|
||||
|
||||
$name makescriptfunc sethardpos "phytron::defpos $controller $axis" user
|
||||
hfactory /sics/${name}/sethardpos/value plain user float
|
||||
|
||||
hupdate /sics/${name}/status idle
|
||||
$controller queue /sics/${name}/hardposition progress read
|
||||
$controller queue /sics/${name}/speed progress read
|
||||
}
|
||||
#===============================================================================================
|
||||
# At MORPHEUS there is a special table where one motor needs a brake. This requires a digital I/O
|
||||
# to be disabled before driving and enabled after driving. The code below adds this feature to
|
||||
# a phytron motor
|
||||
#-----------------------------------------------------------------------------------------------
|
||||
proc phytron::openset {out} {
|
||||
sct send [format "0A%dS" $out]
|
||||
return openans
|
||||
}
|
||||
#----------------------------------------------------------------------------------------------
|
||||
proc phytron::openans {axis name} {
|
||||
after 100
|
||||
return [phytron::setpos $axis $name]
|
||||
}
|
||||
#----------------------------------------------------------------------------------------------
|
||||
proc phytron::outsend {axis out} {
|
||||
set data [phytron::check]
|
||||
if {[string first ACKE $data] >= 0} {
|
||||
sct update error
|
||||
clientput "Electronics error"
|
||||
return idle
|
||||
}
|
||||
sct send [format "0A%dR" $out]
|
||||
return outend
|
||||
}
|
||||
#----------------------------------------------------------------------------------------------
|
||||
proc phytron::outend {} {
|
||||
sct update idle
|
||||
return idle
|
||||
}
|
||||
#----------------------------------------------------------------------------------------------
|
||||
proc phytron::configureM2 {motor axis out} {
|
||||
set path /sics/${motor}
|
||||
hsetprop $path/hardposition write phytron::openset $out
|
||||
hsetprop $path/hardposition openans phytron::openans $axis $motor
|
||||
|
||||
hsetprop $path/status statend phytron::outsend $axis $out
|
||||
hsetprop $path/status outend phytron::outend
|
||||
}
|
||||
156
tcl/pimotor.tcl
156
tcl/pimotor.tcl
@ -1,156 +0,0 @@
|
||||
#----------------------------------------------------
|
||||
# This is a scriptcontext motor driver for the
|
||||
# prehistoric Physik Instrumente DC-406 DC motor
|
||||
# controller.
|
||||
#
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# Scriptchains:
|
||||
# - read - readreply
|
||||
# - write - writerepy
|
||||
# - sendstatus - statusreply - statuspos
|
||||
# - speedread - readreply
|
||||
# - writespeed - speedreply
|
||||
# - writenull - speedreply
|
||||
#
|
||||
# Mark Koennecke, Neovember 2009, after the
|
||||
# C original from 1998
|
||||
#-----------------------------------------------------
|
||||
|
||||
namespace eval pimotor {}
|
||||
#----------------------------------------------------
|
||||
proc pimotor::read {num} {
|
||||
sct send [format "%1.1dTP" $num]
|
||||
return readreply
|
||||
}
|
||||
#----------------------------------------------------
|
||||
proc pimotor::readreply {} {
|
||||
set result [sct result]
|
||||
if {[string first ? $result] >= 0} {
|
||||
error $result
|
||||
}
|
||||
set val [string range $result 3 end]
|
||||
sct update $val
|
||||
return idle
|
||||
}
|
||||
#----------------------------------------------------
|
||||
proc pimotor::write {num name} {
|
||||
set ival [expr int([sct target])]
|
||||
sct send [format "%1.1dMA%10.10d{0}" $num $ival]
|
||||
hupdate /sics/${name}/status run
|
||||
return writereply
|
||||
}
|
||||
#----------------------------------------------------
|
||||
proc pimotor::writereply {} {
|
||||
# the DC-406 does not reply on this, so we have for sure a
|
||||
# timeout here which we ignore. We do nothing else, as we
|
||||
# need a little wait anyway to get the motor to start
|
||||
# before starting to check status.
|
||||
wait 2
|
||||
set con [sct controller]
|
||||
$con queue /sics/${name}/status progress read
|
||||
return idle
|
||||
}
|
||||
#-----------------------------------------------------
|
||||
proc pimotor::sendstatus {num} {
|
||||
sct send [format "%1.1dTV" $num]
|
||||
return statusreply
|
||||
}
|
||||
#------------------------------------------------------
|
||||
proc pimotor::statusreply {num} {
|
||||
set result [sct result]
|
||||
if {[string first ? $result] >= 0} {
|
||||
sct update error
|
||||
error $result
|
||||
}
|
||||
set val [string range $result 3 end]
|
||||
if {abs($val) > 0} {
|
||||
sct update run
|
||||
[sct controller] queue sct progress read
|
||||
} else {
|
||||
pimotor::read $num
|
||||
return statuspos
|
||||
}
|
||||
return idle
|
||||
}
|
||||
#------------------------------------------------------
|
||||
proc pimotor::statuspos {name} {
|
||||
set result [sct result]
|
||||
if {[string first ? $result] >= 0} {
|
||||
error $result
|
||||
}
|
||||
set val [string range $result 3 end]
|
||||
hupdate /sics/${name} $val
|
||||
return idle
|
||||
}
|
||||
#-------------------------------------------------------
|
||||
proc pimotor::readspeed {num} {
|
||||
sct send [format "%1.1dTY" $num]
|
||||
return readreply
|
||||
}
|
||||
#--------------------------------------------------------
|
||||
proc pimotor::writespeed {num} {
|
||||
sct send [format "%1.1dSV%7.7d{0}" $num [sct target]]
|
||||
return speedreply
|
||||
}
|
||||
#----------------------------------------------------
|
||||
proc pimotor::emptyreply {} {
|
||||
return idle
|
||||
}
|
||||
#-----------------------------------------------------
|
||||
proc pimotor::writenull {controller num} {
|
||||
$controller send [format "%1.1dDH{0}" $num]
|
||||
return Done
|
||||
}
|
||||
#------------------------------------------------------
|
||||
proc pimotor::writeon {controller num} {
|
||||
$controller send [format "%1.1dMN{0}" $num]
|
||||
return Done
|
||||
}
|
||||
#------------------------------------------------------
|
||||
proc pimotor::halt {controller num} {
|
||||
$controller send [format "%1.1dAB{0}" $num]
|
||||
return Done
|
||||
}
|
||||
#------------------------------------------------------
|
||||
proc pimotor::makepimotor {name num sct lowlim upperlim} {
|
||||
MakeSecMotor $name
|
||||
|
||||
hdel /sics/${name}/hardupperlim
|
||||
hdel /sics/${name}/hardlowerlim
|
||||
hfactory /sics/${name}/hardupperlim plain internal float
|
||||
hfactory /sics/${name}/hardlowerlim plain internal float
|
||||
$name hardlowerlim $lowlim
|
||||
$name softlowerlim $lowlim
|
||||
$name hardupperlim $upperlim
|
||||
$name softupperlim $upperlim
|
||||
|
||||
hsetprop /sics/${name}/hardposition read pimotor::read $num
|
||||
hsetprop /sics/${name}/hardposition readreply pimotor::readreply
|
||||
$sct poll /sics/${name} 60
|
||||
|
||||
hsetprop /sics/${name}/hardposition write pimotor::write $num $name
|
||||
hsetprop /sics/${name}/hardposition writereply pimotor::writereply
|
||||
$sct write /sics/${name}/hardposition
|
||||
|
||||
hsetprop /sics/${name}/status read pimotor::sendstatus $num
|
||||
hsetprop /sics/${name}/status statusreply pimotor::statusreply $num
|
||||
hsetprop /sics/${name}/status statuspos pimotor::statuspos $name
|
||||
$sct poll /sics/${name}/status 60
|
||||
|
||||
hfactory /sics/${name}/speed plain user int
|
||||
hsetprop /sics/${name}/speed read pimotor::speedread $num
|
||||
hsetprop /sics/${name}/speed readreply pimotor::readreply
|
||||
$sct poll /sics/${name}/speed 120
|
||||
|
||||
hsetprop /sics/${name}/speed write pimotor::writespeed $num
|
||||
hsetprop /sics/${name}/speed speedreply pimotor::speedreply
|
||||
$sct write /sics/${name}/speed
|
||||
|
||||
$name makescriptfunc halt "pimotor::halt $sct $num" user
|
||||
$name makescriptfunc on "pimotor::writeon $sct $num" user
|
||||
$name makescriptfunc home "pimotor::writenull $sct $num" user
|
||||
|
||||
hupdate /sics/${name}/status idle
|
||||
$sct queue /sics/${name}/hardposition progress read
|
||||
}
|
||||
@ -1,79 +0,0 @@
|
||||
#---------------------------------------------------------------------------
|
||||
# The first step when doing a four circle experiment is to search
|
||||
# reflections manually. When some have been found a UB-matrix calculation
|
||||
# can be tried. In between it is necessary to keep a list of peak positons
|
||||
# found and to write them to file. This is exactly what this is for.
|
||||
#
|
||||
# Mark Koennecke, October 1998
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
#----- where data files shall go by default
|
||||
set prefix ./
|
||||
|
||||
#--------------------------------------------------------------------------
|
||||
proc iiGetNum { text } {
|
||||
set list [split $text =]
|
||||
return [lindex $list 1]
|
||||
}
|
||||
|
||||
#------------ clear everything
|
||||
proc iiinit {} {
|
||||
global iiref
|
||||
set iiref(np) 0
|
||||
set iiref(OM) ""
|
||||
set iiref(TH) ""
|
||||
set iiref(CH) ""
|
||||
set iiref(PH) ""
|
||||
set iiref(title) ""
|
||||
}
|
||||
#------- run this once when loading in order to empty space
|
||||
iiinit
|
||||
#------------------- store
|
||||
proc iistore {} {
|
||||
global iiref
|
||||
incr iiref(np)
|
||||
lappend iiref(OM) [iiGetNum [OM]]
|
||||
lappend iiref(TH) [iiGetNum [TH]]
|
||||
lappend iiref(CH) [iiGetNum [CH]]
|
||||
lappend iiref(PH) [iiGetNum [PH]]
|
||||
lappend iiref(title) [iiGetNum [title]]
|
||||
}
|
||||
#------------- write to file
|
||||
proc iiwrite {fil} {
|
||||
global iiref
|
||||
global prefix
|
||||
set fd [open $prefix/$fil w]
|
||||
for {set i 0} {$i < $iiref(np)} { incr i } {
|
||||
set om [lindex $iiref(OM) $i]
|
||||
set th [lindex $iiref(TH) $i]
|
||||
set ch [lindex $iiref(CH) $i]
|
||||
set ph [lindex $iiref(PH) $i]
|
||||
set tt [lindex $iiref(title) $i]
|
||||
puts $fd [format "%8.2f %8.2f %8.2f %8.2f %d %s" $th $om $ch $ph $i $tt]
|
||||
}
|
||||
close $fd
|
||||
}
|
||||
#------------------- the actual control implementation function
|
||||
proc rliste args {
|
||||
if {[llength $args] < 1} {
|
||||
error "ERROR: keyword expected to rliste"
|
||||
}
|
||||
switch [lindex $args 0] {
|
||||
"clear" {
|
||||
iiinit
|
||||
return
|
||||
}
|
||||
"store" {
|
||||
iistore
|
||||
}
|
||||
"write" {
|
||||
if { [llength $args] < 2 } {
|
||||
error "ERROR: expected filename after write"
|
||||
}
|
||||
iiwrite [lindex $args 1]
|
||||
}
|
||||
default {
|
||||
error "ERROR: keyword [lindex $args 0] not recognized"
|
||||
}
|
||||
}
|
||||
}
|
||||
74
tcl/scan.tcl
74
tcl/scan.tcl
@ -1,74 +0,0 @@
|
||||
#----------------------------------------------------------------------------
|
||||
# A simple scan command for DMC. This allows scanning a motor against the
|
||||
# monitors. This is useful for adjusting DMC. No fancy file writing is done.
|
||||
# This code relies on (and checks for) the LogBook being active.
|
||||
#
|
||||
# Mark Koennecke, Juli 1997
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
#----- internal: check LogBook is on.
|
||||
proc scan:CheckLog { } {
|
||||
set text [LogBook]
|
||||
if { [string match Log*:*on $text] } {
|
||||
return 1
|
||||
} else {
|
||||
return 0
|
||||
}
|
||||
}
|
||||
#------ internal: get Monitor value
|
||||
proc scan:monitor { num } {
|
||||
set reply [counter GetMonitor $num]
|
||||
set l [split $reply =]
|
||||
return [lindex $l 1]
|
||||
}
|
||||
|
||||
#------ actual scan command
|
||||
proc scan { motor start step n {mode NULL } { preset NULL } } {
|
||||
#----- check for existence of LogBook
|
||||
# set ret [scan:CheckLog]
|
||||
# if { $ret != 1 } {
|
||||
# ClientPut "ERROR: logging must be active for scan"
|
||||
# ClientPut $ret
|
||||
# return
|
||||
# }
|
||||
#----- is motor reallly countable ?
|
||||
set ret [SICSType $motor]
|
||||
if { [string compare $ret "DRIV"] != 0 } {
|
||||
ClientPut [format "ERROR: %s not drivable" $motor]
|
||||
return
|
||||
}
|
||||
#----- deal with mode
|
||||
set mode2 [string toupper $mode]
|
||||
set mode3 [string trim $mode2]
|
||||
set mc [string index $mode2 0]
|
||||
if { [string compare $mc T] == 0 } {
|
||||
banana CountMode Timer
|
||||
} elseif { [string compare $mc M] == 0 } {
|
||||
banana CountMode Monitor
|
||||
}
|
||||
#------ deal with preset
|
||||
if { [string compare $preset NULL] != 0 } {
|
||||
banana preset $preset
|
||||
}
|
||||
#------- write output header
|
||||
ClientPut [format "%10.10s Monitor0 Monitor1" $motor]
|
||||
|
||||
#------ the scan loop
|
||||
for { set i 0} { $i < $n } { incr i } {
|
||||
#--------- drive
|
||||
set pos [expr $start + $i * $step]
|
||||
set ret [catch "drive $motor $pos" msg]
|
||||
if { $ret != 0 } {
|
||||
ClientPut "ERROR: driving motor"
|
||||
ClientPut $msg
|
||||
}
|
||||
#---------- count
|
||||
banana count
|
||||
Success
|
||||
#---------- create output
|
||||
set m0 [scan:monitor 0]
|
||||
set m1 [scan:monitor 1]
|
||||
ClientPut [format "%10.2f %11.11d %11.11d" $pos $m0 $m1]
|
||||
}
|
||||
ClientPut "Scan finished !"
|
||||
}
|
||||
542
tcl/scancom.tcl
542
tcl/scancom.tcl
@ -1,542 +0,0 @@
|
||||
#--------------------------------------------------------------------------
|
||||
# general scan command wrappers for TOPSI and the like.
|
||||
# New version using the object.tcl system from sntl instead of obTcl which
|
||||
# caused a lot of trouble with tcl8.0
|
||||
#
|
||||
# Requires the built in scan command xxxscan.
|
||||
#
|
||||
# Mark Koennecke, February 2000
|
||||
#--------------------------------------------------------------------------
|
||||
|
||||
#---------- adapt to the local settings
|
||||
set home /data/koenneck/src
|
||||
|
||||
source $home/sics/object.tcl
|
||||
|
||||
set datapath $home/tmp
|
||||
set recoverfil $home/tmp/recover.bin
|
||||
|
||||
#-------------------------- some utility functions -------------------------
|
||||
proc MC { t n } {
|
||||
set string $t
|
||||
for { set i 1 } { $i < $n } { incr i } {
|
||||
set string [format "%s%s" $string $t]
|
||||
}
|
||||
return $string
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc GetNum { text } {
|
||||
set list [split $text =]
|
||||
return [lindex $list 1]
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
|
||||
#************** Definition of scan class **********************************
|
||||
|
||||
object_class ScanCommand {
|
||||
member Mode Monitor
|
||||
member NP 1
|
||||
member counter counter
|
||||
member NoVar 0
|
||||
member Preset 10000
|
||||
member File default.dat
|
||||
member pinterest ""
|
||||
member Channel 0
|
||||
member Active 0
|
||||
member Recover 0
|
||||
member scanvars
|
||||
member scanstart
|
||||
member scanstep
|
||||
member pinterest
|
||||
|
||||
method var {name start step} {
|
||||
# check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
# check parameters
|
||||
set t [SICSType $name]
|
||||
if { [string compare $t DRIV] != 0 } {
|
||||
ClientPut [format "ERROR: %s is not drivable" $name] error
|
||||
return 0
|
||||
}
|
||||
set t [SICSType $start]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $start] error
|
||||
return 0
|
||||
}
|
||||
set t [SICSType $step]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $step] error
|
||||
return 0
|
||||
}
|
||||
# install the variable
|
||||
set i $slot(NoVar)
|
||||
incr slot(NoVar)
|
||||
lappend slot(scanvars) $name
|
||||
lappend slot(scanstart) $start
|
||||
lappend slot(scanstep) $step
|
||||
$self SendInterest pinterest ScanVarChange
|
||||
ClientPut OK
|
||||
}
|
||||
|
||||
method info {} {
|
||||
if { $slot(NoVar) < 1 } {
|
||||
return "0,1,NONE,0.,0.,default.dat"
|
||||
}
|
||||
append result $slot(NP) "," $slot(NoVar)
|
||||
for {set i 0} { $i < $slot(NoVar) } { incr i} {
|
||||
append result "," [lindex $slot(scanvars) $i]
|
||||
}
|
||||
append result "," [lindex $slot(scanstart) 0] "," \
|
||||
[lindex $slot(scanstep) 0]
|
||||
set r1 [xxxscan getfile]
|
||||
set l1 [split $r1 "="]
|
||||
append result "," [lindex $l1 1]
|
||||
return $result
|
||||
}
|
||||
|
||||
method getvars {} {
|
||||
set list ""
|
||||
lappend list $slot(scanvars)
|
||||
return [format "scan.Vars = %s -END-" $list]
|
||||
}
|
||||
|
||||
method xaxis {} {
|
||||
if { $slot(NoVar) <= 0} {
|
||||
#---- default Answer
|
||||
set t [format "%s.xaxis = %f %f" $self 0 1]
|
||||
} else {
|
||||
set t [format "%s.xaxis = %f %f" $self [lindex $slot(scanstart) 0] \
|
||||
[lindex $slot(scanstep) 0] ]
|
||||
}
|
||||
ClientPut $t
|
||||
}
|
||||
|
||||
method cinterest {} {
|
||||
xxxscan interest
|
||||
}
|
||||
|
||||
method uuinterest {} {
|
||||
xxxscan uuinterest
|
||||
}
|
||||
|
||||
method pinterest {} {
|
||||
set nam [GetNum [config MyName]]
|
||||
lappend $slot(pinterest) $nam
|
||||
}
|
||||
|
||||
method SendInterest { type text } {
|
||||
#------ check list first
|
||||
set l1 $slot($type)
|
||||
set l2 ""
|
||||
foreach e $l1 {
|
||||
set b [string trim $e]
|
||||
set g [string trim $b "{}"]
|
||||
set ret [SICSType $g]
|
||||
if { [string first COM $ret] >= 0 } {
|
||||
lappend l2 $e
|
||||
}
|
||||
}
|
||||
#-------- update scan data and write
|
||||
set slot($type) $l2
|
||||
foreach e $l2 {
|
||||
set b [string trim $e]
|
||||
$b put $text
|
||||
}
|
||||
}
|
||||
|
||||
method mode { {NewVal NULL} } {
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.Mode = %s" $self $slot(Mode)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
set tmp [string tolower $NewVal]
|
||||
set NewVal $tmp
|
||||
if { ([string compare $NewVal "timer"] == 0) || \
|
||||
([string compare $NewVal monitor] ==0) } {
|
||||
set slot(Mode) $NewVal
|
||||
ClientPut OK
|
||||
} else {
|
||||
ClientPut [format "ERROR: %s not recognized as ScanMode" $NewVal]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
method np { { NewVal NULL } } {
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.NP = %d" $self $slot(NP)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
set t [SICSType $NewVal]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number" $NewVal] error
|
||||
return
|
||||
}
|
||||
set slot(NP) $NewVal
|
||||
ClientPut OK
|
||||
}
|
||||
}
|
||||
|
||||
method preset { {NewVal NULL} } {
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.Preset = %f" $self $slot(Preset)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
set t [SICSType $NewVal]
|
||||
if { [string compare $t NUM] != 0} {
|
||||
ClientPut [format "ERROR: %s is no number" $NewVal] error
|
||||
return
|
||||
}
|
||||
set slot(Preset) $NewVal
|
||||
ClientPut OK
|
||||
}
|
||||
}
|
||||
|
||||
method file {} {
|
||||
return [xxxscan file]
|
||||
}
|
||||
|
||||
method setchannel {num} {
|
||||
set ret [catch {xxxscan setchannel $num} msg]
|
||||
if { $ret == 0} {
|
||||
set slot(Channel) $num
|
||||
} else {
|
||||
return $msg
|
||||
}
|
||||
}
|
||||
|
||||
method list { } {
|
||||
ClientPut [format "%s.Preset = %f" $self $slot(Preset)]
|
||||
ClientPut [format "%s.Mode = %s" $self $slot(Mode)]
|
||||
ClientPut [format "%s.File = %s" $self $slot(File)]
|
||||
ClientPut [format "%s.NP = %d" $self $slot(NP)]
|
||||
ClientPut [format "%s.Channel = %d" $self $slot(Channel)]
|
||||
ClientPut "ScanVariables:"
|
||||
for { set i 0 } {$i < $slot(NoVar) } { incr i } {
|
||||
ClientPut [format " %s %f %f" [lindex $slot(scanvars) $i] \
|
||||
[lindex $slot(scanstart) $i] \
|
||||
[lindex $slot(scanstep) $i] ]
|
||||
}
|
||||
}
|
||||
|
||||
method clear {} {
|
||||
# check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: cannot clear running scan" error
|
||||
return
|
||||
}
|
||||
|
||||
set slot(NP) 0
|
||||
set slot(NoVar) 0
|
||||
set slot(scanvars) ""
|
||||
set slot(scanstart) ""
|
||||
set slot(scanstep) ""
|
||||
$self SendInterest pinterest ScanVarChange
|
||||
xxxscan clear
|
||||
ClientPut OK
|
||||
}
|
||||
|
||||
method getcounts {} {
|
||||
return [xxxscan getcounts]
|
||||
}
|
||||
|
||||
method run { } {
|
||||
# start with error checking
|
||||
if { $slot(NP) < 1 } {
|
||||
ClientPut "ERROR: Insufficient Number of ScanPoints"
|
||||
return
|
||||
}
|
||||
if { $slot(NoVar) < 1 } {
|
||||
ClientPut "ERROR: No variables to scan given!"
|
||||
return
|
||||
}
|
||||
#------- check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: Scan already in progress" error
|
||||
return
|
||||
}
|
||||
xxxscan clear
|
||||
for {set i 0 } { $i < $slot(NoVar)} {incr i} {
|
||||
set ret [catch {xxxscan add [lindex $slot(scanvars) $i] \
|
||||
[lindex $slot(scanstart) $i] [lindex $slot(scanstep) $i]} msg]
|
||||
if {$ret != 0} {
|
||||
set slot(Active) 0
|
||||
error $msg
|
||||
}
|
||||
}
|
||||
set slot(Active) 1
|
||||
set ret [catch \
|
||||
{xxxscan run $slot(NP) $slot(Mode) $slot(Preset)} msg]
|
||||
set slot(Active) 0
|
||||
if {$ret != 0 } {
|
||||
error $msg
|
||||
} else {
|
||||
return "Scan Finished"
|
||||
}
|
||||
}
|
||||
|
||||
method recover {} {
|
||||
set slot(Active) 1
|
||||
catch {xxxscan recover} msg
|
||||
set slot(Active) 0
|
||||
return "Scan Finished"
|
||||
}
|
||||
|
||||
method forceclear {} {
|
||||
set slot(Active) 0
|
||||
}
|
||||
}
|
||||
#---- end of ScanCommand definition
|
||||
|
||||
#********************** initialisation of module commands to SICS **********
|
||||
|
||||
set ret [catch {scan list} msg]
|
||||
#if {$ret != 0} {
|
||||
object_new ScanCommand scan
|
||||
Publish scan Spy
|
||||
VarMake lastscancommand Text User
|
||||
Publish scancounts Spy
|
||||
Publish textstatus Spy
|
||||
Publish cscan User
|
||||
Publish sscan User
|
||||
Publish sftime Spy
|
||||
Publish scaninfo Spy
|
||||
Publish wwwsics Spy
|
||||
#}
|
||||
|
||||
#*************************************************************************
|
||||
|
||||
#===================== Helper commands for status display work ============
|
||||
# a new user command which allows status clients to read the counts in a scan
|
||||
# This is just to circumvent the user protection on scan
|
||||
proc scancounts { } {
|
||||
set status [ catch {scan getcounts} result]
|
||||
if { $status == 0 } {
|
||||
return $result
|
||||
} else {
|
||||
return "scan.Counts= 0"
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
# This is just another utilility function which helps in implementing the
|
||||
# status display client
|
||||
proc textstatus { } {
|
||||
set text [status]
|
||||
return [format "Status = %s" $text]
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
# Dumps time in a useful format
|
||||
proc sftime {} {
|
||||
return [format "sicstime = %s" [sicstime]]
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
# Utility function which gives scan parameters as an easily parsable
|
||||
# comma separated list for java status client
|
||||
proc scaninfo {} {
|
||||
set result [scan info]
|
||||
set r1 [sample]
|
||||
set inf [string first = $r1]
|
||||
if {$inf > 0} {
|
||||
incr inf
|
||||
set sa [string range $r1 $inf end]
|
||||
} else {
|
||||
set sa Unknown
|
||||
}
|
||||
regsub -all , $sa " " sam
|
||||
append result "," $sam
|
||||
append result "," [sicstime]
|
||||
set r1 [lastscancommand]
|
||||
set l1 [split $r1 "="]
|
||||
append result "," [lindex $l1 1]
|
||||
return [format "scaninfo = %s" $result]
|
||||
}
|
||||
#----------------------------------------------------------------------
|
||||
# wwwsics is a procedure which formats the most important status
|
||||
# information for the WWW-status.
|
||||
proc wwwsics {} {
|
||||
#----- get all the data we need
|
||||
set user [GetNum [user]]
|
||||
set sample [GetNum [sample]]
|
||||
set tit [GetNum [title]]
|
||||
set ret [catch {lambda} msg]
|
||||
if {$ret != 0 } {
|
||||
set lam Undetermined
|
||||
} else {
|
||||
set lam [GetNum $msg]
|
||||
}
|
||||
set lscan [GetNum [lastscancommand]]
|
||||
set svar [GetNum [scan getvars]]
|
||||
set ind [string last -END- $svar]
|
||||
if { $ind > 2 } {
|
||||
set svar [string range $svar 0 $ind]
|
||||
} else {
|
||||
set svar " "
|
||||
}
|
||||
set res [scan info]
|
||||
set l [split $res ,]
|
||||
set fil [lindex $l 5]
|
||||
set run [GetNum [sicsdatanumber]]
|
||||
set stat [GetNum [status]]
|
||||
#------- html format the reply
|
||||
append result "<table BORDER=2>"
|
||||
append result <tr> <th>Run Number</th> <td> $run </td> </tr>
|
||||
append result <tr> <th>Title</th> <td> $tit </td> </tr>
|
||||
append result <tr> <th>User</th> <td> $user </td> </tr>
|
||||
append result <tr> <th>Sample </th> <td> $sample </td> </tr>
|
||||
append result <tr> <th>wavelength</th> <td> $lam</td> </tr>
|
||||
append result <tr> <th>Status</th> <td> $stat</td> </tr>
|
||||
append result <tr> <th>Scan Variables</th> <td> $svar</td> </tr>
|
||||
append result <tr> <th>File </th> <td> $fil</td> </tr>
|
||||
append result <tr> <th>Last Scan Command</th> <td> $lscan</td> </tr>
|
||||
append result </table>
|
||||
return $result
|
||||
}
|
||||
#===================== Syntactical sugar around scan ===================
|
||||
# center scan. A convenience scan for the one and only Daniel Clemens
|
||||
# at TOPSI. Scans around a given center point. Requires the scan command
|
||||
# for TOPSI to work.
|
||||
#
|
||||
# another convenience scan:
|
||||
# sscan var1 start end var1 start end .... np preset
|
||||
# scans var1, var2 from start to end with np steps and a preset of preset
|
||||
#
|
||||
# Mark Koennecke, August, 22, 1997
|
||||
#-----------------------------------------------------------------------------
|
||||
proc cscan { var center delta np preset } {
|
||||
#------ start with some argument checking
|
||||
set t [SICSType $var]
|
||||
if { [string compare $t DRIV] != 0 } {
|
||||
ClientPut [format "ERROR: %s is NOT drivable!" $var]
|
||||
return
|
||||
}
|
||||
set t [SICSType $center]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $center]
|
||||
return
|
||||
}
|
||||
set t [SICSType $delta]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $delta]
|
||||
return
|
||||
}
|
||||
set t [SICSType $np]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $np]
|
||||
return
|
||||
}
|
||||
set t [SICSType $preset]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $preset]
|
||||
return
|
||||
}
|
||||
#-------- store command in lastscancommand
|
||||
set txt [format "cscan %s %s %s %s %s" $var $center \
|
||||
$delta $np $preset]
|
||||
catch {lastscancommand $txt}
|
||||
#-------- set standard parameters
|
||||
scan clear
|
||||
scan preset $preset
|
||||
scan np [expr $np*2 + 1]
|
||||
#--------- calculate start
|
||||
set start [expr $center - $np * $delta]
|
||||
set ret [catch {scan var $var $start $delta} msg]
|
||||
if { $ret != 0} {
|
||||
ClientPut $msg
|
||||
return
|
||||
}
|
||||
#---------- start scan
|
||||
set ret [catch {scan run} msg]
|
||||
if {$ret != 0} {
|
||||
error $msg
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
proc sscan args {
|
||||
scan clear
|
||||
#------- check arguments: the last two must be preset and np!
|
||||
set l [llength $args]
|
||||
if { $l < 5} {
|
||||
ClientPut "ERROR: Insufficient number of arguments to sscan"
|
||||
return
|
||||
}
|
||||
set preset [lindex $args [expr $l - 1]]
|
||||
set np [lindex $args [expr $l - 2]]
|
||||
set t [SICSType $preset]
|
||||
ClientPut $t
|
||||
ClientPut [string first $t "NUM"]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for preset, got %s" \
|
||||
$preset]
|
||||
return
|
||||
}
|
||||
set t [SICSType $np]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for np, got %s" \
|
||||
$np]
|
||||
return
|
||||
}
|
||||
scan preset $preset
|
||||
scan np $np
|
||||
#--------- do variables
|
||||
set nvar [expr ($l - 2) / 3]
|
||||
for { set i 0 } { $i < $nvar} { incr i } {
|
||||
set var [lindex $args [expr $i * 3]]
|
||||
set t [SICSType $var]
|
||||
if {[string compare $t DRIV] != 0} {
|
||||
ClientPut [format "ERROR: %s is not drivable" $var]
|
||||
return
|
||||
}
|
||||
set start [lindex $args [expr ($i * 3) + 1]]
|
||||
set t [SICSType $start]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for start, got %s" \
|
||||
$start]
|
||||
return
|
||||
}
|
||||
set end [lindex $args [expr ($i * 3) + 2]]
|
||||
set t [SICSType $end]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for end, got %s" \
|
||||
$end]
|
||||
return
|
||||
}
|
||||
#--------- do scan parameters
|
||||
set step [expr double($end - $start)/double($np)]
|
||||
set ret [catch {scan var $var $start $step} msg]
|
||||
if { $ret != 0} {
|
||||
ClientPut $msg
|
||||
return
|
||||
}
|
||||
}
|
||||
#------------- set lastcommand text
|
||||
set txt [format "sscan %s" [join $args]]
|
||||
catch {lastscancommand $txt}
|
||||
#------------- start scan
|
||||
set ret [catch {scan run} msg]
|
||||
if {$ret != 0} {
|
||||
error $msg
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@ -1,66 +0,0 @@
|
||||
#---------------------------------------------------------------
|
||||
# This is a second generation simulation motor.
|
||||
#
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# Mark Koennecke, December 2008
|
||||
#----------------------------------------------------------------
|
||||
proc simhardset {motname newval} {
|
||||
hset /sics/$motname/starttime [clock sec]
|
||||
}
|
||||
#--------------------------------------------------------------
|
||||
proc simhardget {motname} {
|
||||
set stat [hval /sics/$motname/status]
|
||||
set val [hval /sics/$motname/targetposition]
|
||||
if {[string first run $stat] >= 0 \
|
||||
|| [string first error $stat] >= 0 } {
|
||||
return [expr $val -.777]
|
||||
} else {
|
||||
return $val
|
||||
}
|
||||
}
|
||||
#-------------------------------------------------------------
|
||||
proc simhardfaultget {motname} {
|
||||
set val [hval /sics/$motname/targetposition]
|
||||
return [expr $val - .5]
|
||||
}
|
||||
#--------------------------------------------------------------
|
||||
proc simstatusget {motname} {
|
||||
set start [hval /sics/$motname/starttime]
|
||||
if {$start < 0} {
|
||||
return error
|
||||
}
|
||||
set delay [hval /sics/$motname/delay]
|
||||
if {[clock sec] > $start + $delay} {
|
||||
return idle
|
||||
} else {
|
||||
return run
|
||||
}
|
||||
}
|
||||
#-------------------------------------------------------------
|
||||
proc simstatusfault {motname } {
|
||||
clientput "ERROR: I am feeling faulty!"
|
||||
return error
|
||||
}
|
||||
#--------------------------------------------------------------
|
||||
proc simhalt {motname} {
|
||||
hset /sics/$motname/starttime -100
|
||||
}
|
||||
#---------------------------------------------------------------
|
||||
proc MakeSecSim {name lower upper delay} {
|
||||
MakeSecMotor $name
|
||||
hfactory /sics/$name/delay plain user text
|
||||
hfactory /sics/$name/starttime plain user int
|
||||
hset /sics/$name/delay $delay
|
||||
hdel /sics/$name/hardposition
|
||||
hfactory /sics/$name/hardposition script "simhardget $name" "simhardset $name" float
|
||||
# hfactory /sics/$name/hardposition script "simhardfaultget $name" "simhardset $name" float
|
||||
hdel /sics/$name/status
|
||||
hfactory /sics/$name/status script "simstatusget $name" hdbReadOnly text
|
||||
# hfactory /sics/$name/status script "simstatusfault $name" hdbReadOnly text
|
||||
$name makescriptfunc halt "simhalt $name" user
|
||||
hupdate /sics/$name/hardupperlim $upper
|
||||
hupdate /sics/$name/softupperlim $upper
|
||||
hupdate /sics/$name/hardlowerlim $lower
|
||||
hupdate /sics/$name/softlowerlim $lower
|
||||
}
|
||||
@ -1,74 +0,0 @@
|
||||
#------------------------------------------------------------------
|
||||
# This is a helper file in order to debug SICS Tcl scripts. The idea
|
||||
# is that a connection to a SICS interpreter at localhost:2911 is opened.
|
||||
# Then unknown is reimplemented to send unknown commands (which must be
|
||||
# SICS commands) to the SICS interpreter for evaluation. This is done
|
||||
# with transact in order to figure out when SICS finished processing.
|
||||
# Thus is should be possible to debug SICS Tcl scripts in a normal
|
||||
# standalone interpreter without the overhead of restarting SICS
|
||||
# all the time. It may even be possible to use one of the normal
|
||||
# Tcl debuggers then....
|
||||
#
|
||||
# Mark Koennecke, February 2006
|
||||
#
|
||||
# Revamped for use in testing SICS instruments.
|
||||
# Mark Koennecke, November 2006
|
||||
#------------------------------------------------------------------
|
||||
set host(amor) amor.psi.ch
|
||||
set host(dmc) dmc.psi.ch
|
||||
set host(focus) focus.psi.ch
|
||||
set host(hrpt) hrpt.psi.ch
|
||||
set host(mars) mars.psi.ch
|
||||
set host(morpheus) morpheus.psi.ch
|
||||
set host(narziss) narziss.psi.ch
|
||||
set host(poldi) poldi.psi.ch
|
||||
set host(rita2) rita2.psi.ch
|
||||
set host(sans) sans.psi.ch
|
||||
set host(sansli) sans2.psi.ch
|
||||
set host(tasp) tasp.psi.ch
|
||||
set host(trics) trics.psi.ch
|
||||
set host(local) localhost
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
# initialize the socket before debugging. If local == 1, then a
|
||||
# connection to localhost is built
|
||||
#------------------------------------------------------------------
|
||||
proc initSicsDebug {instrument} {
|
||||
global socke host
|
||||
catch {close $socke}
|
||||
set status [catch {set compi $host($instrument)} msg]
|
||||
if {$status != 0} {
|
||||
error "Host for $instrument not found"
|
||||
}
|
||||
set socke [socket $compi 2911]
|
||||
gets $socke
|
||||
puts $socke "Spy 007"
|
||||
flush $socke
|
||||
gets $socke
|
||||
}
|
||||
#----------------------------------------------------------------
|
||||
proc sicscommand args {
|
||||
global socke
|
||||
append com "transact " [join $args]
|
||||
puts stdout "Sending: $com"
|
||||
puts $socke $com
|
||||
flush $socke
|
||||
set reply ""
|
||||
while {1} {
|
||||
set line [gets $socke]
|
||||
if {[string first TRANSACTIONFINISHED $line] >= 0} {
|
||||
return $reply
|
||||
} else {
|
||||
append reply $line "\n"
|
||||
}
|
||||
}
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
proc unknown args {
|
||||
return [sicscommand $args]
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
proc clientput args {
|
||||
puts stdout [join $args]
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
@ -1,91 +0,0 @@
|
||||
#-----------------------------------------------------
|
||||
# This is a simulation driver for the second
|
||||
# generation histogram memory. It provides
|
||||
# for a fill value which is used to initialize
|
||||
# data.
|
||||
#
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# Mark Koennecke, January 2010
|
||||
#-----------------------------------------------------
|
||||
namespace eval simhm {}
|
||||
#-----------------------------------------------------
|
||||
proc simhm::getcontrol {name} {
|
||||
return -9999.99
|
||||
}
|
||||
#----------------------------------------------------
|
||||
proc simhm::setcontrol {name val} {
|
||||
switch $val {
|
||||
1000 {
|
||||
hset /sics/${name}/internalstatus run
|
||||
set pp [hval /sics/${name}/preset]
|
||||
hset /sics/${name}/finishtime [expr $pp + [clock seconds]]
|
||||
return idle
|
||||
}
|
||||
1001 {
|
||||
hset /sics/${name}/internalstatus error
|
||||
return idle
|
||||
}
|
||||
1002 {
|
||||
hset /sics/${name}/internalstatus pause
|
||||
return idle
|
||||
}
|
||||
1003 {
|
||||
hset /sics/${name}/internalstatus run
|
||||
return idle
|
||||
}
|
||||
1005 {
|
||||
return idle
|
||||
}
|
||||
default {
|
||||
clientput "ERROR: bad start target $target given to control"
|
||||
return idle
|
||||
}
|
||||
}
|
||||
}
|
||||
#----------------------------------------------------
|
||||
proc simhm::getstatus {name} {
|
||||
set status [string trim [hval /sics/${name}/internalstatus]]
|
||||
if {[string first run $status] >= 0} {
|
||||
set fin [string trim [hval /sics/${name}/finishtime]]
|
||||
if {[clock seconds] > $fin} {
|
||||
hset /sics/${name}/internalstatus idle
|
||||
set val [string trim [hval /sics/${name}/initval]]
|
||||
$name set $val
|
||||
set second [string trim [hval /sics/${name}/secondbank]]
|
||||
if {[string compare $second NULL] != 0} {
|
||||
harray /sics/${name}/${second} init $val
|
||||
}
|
||||
}
|
||||
}
|
||||
return $status
|
||||
}
|
||||
#-----------------------------------------------------
|
||||
proc simhm::MakeSimHM {name rank {tof NULL} } {
|
||||
MakeSecHM $name $rank $tof
|
||||
hfactory /sics/${name}/initval plain user int
|
||||
hset /sics/${name}/initval 0
|
||||
|
||||
hfactory /sics/${name}/finishtime plain user int
|
||||
hfactory /sics/${name}/internalstatus plain user text
|
||||
hupdate /sics/${name}/internalstatus idle
|
||||
|
||||
hdel /sics/${name}/control
|
||||
hfactory /sics/${name}/control script \
|
||||
"simhm::getcontrol $name" "simhm::setcontrol $name" float
|
||||
hsetprop /sics/${name}/control priv user
|
||||
|
||||
hdel /sics/${name}/status
|
||||
hfactory /sics/${name}/status script \
|
||||
"simhm::getstatus $name" hdbReadOnly text
|
||||
hsetprop /sics/${name}/control priv user
|
||||
hupdate /sics/${name}/status idle
|
||||
|
||||
hfactory /sics/${name}/secondbank plain user text
|
||||
hupdate /sics/${name}/secondbank NULL
|
||||
}
|
||||
#------------------------------------------------------
|
||||
proc simhm::makeSecond {name bankname length} {
|
||||
hfactory /sics/${name}/${bankname} plain user intvarar $length
|
||||
hupdate /sics/${name}/secondbank $bankname
|
||||
}
|
||||
152
tcl/sinqhttp.tcl
152
tcl/sinqhttp.tcl
@ -1,152 +0,0 @@
|
||||
#--------------------------------------------------------
|
||||
# This is an asynchronous scriptcontext driven driver for
|
||||
# the SINQ style http based histogram memory.
|
||||
#
|
||||
# script chains:
|
||||
# -- control
|
||||
# hmhttpcontrol - hmhttpreply
|
||||
# -- data
|
||||
# hmhttpdata - hmhttpreply
|
||||
# -- status
|
||||
# hmhttpstatus - hmhttpevalstatus -- hmhttpstatusdata
|
||||
#
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# Mark Koennecke, May 2009
|
||||
#
|
||||
# You will need to override hmhttpevalstatus to implement
|
||||
# an update of the detector data
|
||||
#
|
||||
# Mark Koennecke, April 2010
|
||||
#---------------------------------------------------------
|
||||
proc hmhttpsend {url} {
|
||||
sct send $url
|
||||
return hmhttpreply
|
||||
}
|
||||
#--------------------------------------------------------
|
||||
proc hmhttptest {data} {
|
||||
if {[string first ASCERR $data] >= 0} {
|
||||
error $data
|
||||
}
|
||||
if {[string first ERROR $data] >= 0} {
|
||||
error $data
|
||||
}
|
||||
return $data
|
||||
}
|
||||
#--------------------------------------------------------
|
||||
proc hmhttpreply {} {
|
||||
set reply [sct result]
|
||||
set status [catch {hmhttptest $reply} data]
|
||||
if {$status != 0} {
|
||||
sct geterror $data
|
||||
clientput $data
|
||||
} else {
|
||||
hdelprop [sct] geterror
|
||||
}
|
||||
return idle
|
||||
}
|
||||
#---------------------------------------------------------
|
||||
proc hmhttpcontrol {} {
|
||||
set target [sct target]
|
||||
switch $target {
|
||||
1000 {
|
||||
set ret [hmhttpsend "/admin/startdaq.egi"]
|
||||
set path [file dirname [sct]]
|
||||
[sct controller] queue $path/status progress read
|
||||
return $ret
|
||||
}
|
||||
1001 {return [hmhttpsend "/admin/stopdaq.egi"] }
|
||||
1002 {return [hmhttpsend "/admin/pausedaq.egi"] }
|
||||
1003 {return [hmhttpsend "/admin/continuedaq.egi"]}
|
||||
1005 {
|
||||
set path [file dirname [sct]]
|
||||
set script [hval $path/initscript]
|
||||
set confdata [eval $script]
|
||||
return [hmhttpsend "post:/admin/configure.egi:$confdata"]
|
||||
}
|
||||
default {
|
||||
sct print "ERROR: bad start target $target given to control"
|
||||
return idle
|
||||
}
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------
|
||||
proc hmhttpdata {name} {
|
||||
set len [hval /sics/${name}/datalength]
|
||||
set path "/sics/${name}/data"
|
||||
set com [format "node:%s:/admin/readhmdata.egi?bank=0&start=0&end=%d" $path $len]
|
||||
sct send $com
|
||||
return hmhttpdatareply
|
||||
}
|
||||
#--------------------------------------------------------
|
||||
proc hmhttpdatareply {} {
|
||||
set status [catch {hmhttpreply} txt]
|
||||
if {$status == 0} {
|
||||
set path [file dirname [sct]]
|
||||
hdelprop $path/data geterror
|
||||
}
|
||||
return idle
|
||||
}
|
||||
#--------------------------------------------------------
|
||||
proc hmhttpstatus {} {
|
||||
sct send /admin/textstatus.egi
|
||||
return hmhttpevalstatus
|
||||
}
|
||||
#-------------------------------------------------------
|
||||
proc hmhttpstatusdata {} {
|
||||
catch {hmhttpdatareply}
|
||||
sct update idle
|
||||
return idle
|
||||
}
|
||||
#---------------------------------------------------------
|
||||
proc hmhttpevalstatus {name} {
|
||||
set reply [sct result]
|
||||
set status [catch {hmhttptest $reply} data]
|
||||
if {$status != 0} {
|
||||
sct geterror $data
|
||||
clientput $data
|
||||
sct update error
|
||||
return idle
|
||||
}
|
||||
hdelprop [sct] geterror
|
||||
set lines [split $data \n]
|
||||
foreach line $lines {
|
||||
set ld [split $line :]
|
||||
sct [string trim [lindex $ld 0]] [string trim [lindex $ld 1]]
|
||||
}
|
||||
set daq [sct DAQ]
|
||||
set old [hval [sct]]
|
||||
if {$daq == 1} {
|
||||
sct update run
|
||||
[sct controller] queue [sct] progress read
|
||||
return idle
|
||||
} else {
|
||||
if {[string compare $old idle] != 0} {
|
||||
hmhttpdata $name
|
||||
return hmhttpstatusdata
|
||||
} else {
|
||||
return idle
|
||||
}
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------
|
||||
proc MakeHTTPHM {name rank host initscript {tof NULL} } {
|
||||
sicsdatafactory new ${name}transfer
|
||||
makesctcontroller ${name}sct sinqhttpopt $host ${name}transfer 600 spy 007
|
||||
MakeSecHM $name $rank $tof
|
||||
hsetprop /sics/${name}/control write hmhttpcontrol
|
||||
hsetprop /sics/${name}/control hmhttpreply hmhttpreply
|
||||
${name}sct write /sics/${name}/control
|
||||
|
||||
hsetprop /sics/${name}/data read hmhttpdata $name
|
||||
hsetprop /sics/${name}/data hmhttpdatareply hmhttpdatareply
|
||||
${name}sct poll /sics/${name}/data 120
|
||||
|
||||
hsetprop /sics/${name}/status read hmhttpstatus
|
||||
hsetprop /sics/${name}/status hmhttpevalstatus hmhttpevalstatus $name
|
||||
hsetprop /sics/${name}/status hmhttpstatusdata hmhttpstatusdata
|
||||
${name}sct poll /sics/${name}/status 60
|
||||
|
||||
hfactory /sics/${name}/initscript plain mugger text
|
||||
hset /sics/${name}/initscript $initscript
|
||||
}
|
||||
293
tcl/slsecho.tcl
293
tcl/slsecho.tcl
@ -1,293 +0,0 @@
|
||||
#--------------------------------------------------------------
|
||||
# This is a scriptcontext based driver for the SLS magnet
|
||||
# controllers interfaced via the new shiny, silvery TCP/IP
|
||||
# interface box.
|
||||
#
|
||||
# Mark Koennecke, March 2010
|
||||
#---------------------------------------------------------------
|
||||
namespace eval slsecho {}
|
||||
|
||||
|
||||
proc slsecho::sendread {num} {
|
||||
sct send "$num:r:0x9c:0:read"
|
||||
return readreply
|
||||
}
|
||||
#---------------------------------------------------------------
|
||||
proc slsecho::readreply {} {
|
||||
set reply [sct result]
|
||||
set l [split $reply :]
|
||||
# set v [lindex $l 1]
|
||||
# clientput "Received $reply, val = $v"
|
||||
sct update [lindex $l 1]
|
||||
return idle
|
||||
}
|
||||
#--------------------------------------------------------------
|
||||
proc slsecho::sendwrite {num} {
|
||||
set val [sct target]
|
||||
hupdate [sct]/stop 0
|
||||
# sct send "$num:w:0x90:$val:write"
|
||||
sct send "$num:s:0x9c:$val:write"
|
||||
return readreply
|
||||
}
|
||||
#--------------------------------------------------------------
|
||||
proc slsecho::writereply {} {
|
||||
set path [sct]
|
||||
set root [file dirname $path]
|
||||
[sct controller] queue $root/error progress read
|
||||
return idle
|
||||
}
|
||||
#--------------------------------------------------------------
|
||||
proc slsecho::readupper {num} {
|
||||
sct send "$num:r:0x76:0:read"
|
||||
return readreply
|
||||
}
|
||||
#--------------------------------------------------------------
|
||||
proc slsecho::readlower {num} {
|
||||
sct send "$num:r:0x77:0:read"
|
||||
return readreply
|
||||
}
|
||||
#--------------------------------------------------------------
|
||||
proc slsecho::readonoff {num} {
|
||||
sct send "$num:r:0x24:0:none"
|
||||
return onoffreply
|
||||
}
|
||||
#---------------------------------------------------------------
|
||||
proc slsecho::onoffreply {} {
|
||||
set reply [sct result]
|
||||
set l [split $reply :]
|
||||
set val [lindex $l 1]
|
||||
if {$val == 1} {
|
||||
sct update on
|
||||
} else {
|
||||
sct update off
|
||||
}
|
||||
return idle
|
||||
}
|
||||
#---------------------------------------------------------------
|
||||
proc slsecho::writeonoff {num} {
|
||||
set val [sct target]
|
||||
if {[string compare $val on] == 0} {
|
||||
set val 1
|
||||
} elseif {[string compare $val off] == 0} {
|
||||
set val 0
|
||||
} else {
|
||||
clientput "ERROR: Invalid target $val requested, only on/off"
|
||||
return idle
|
||||
}
|
||||
sct send "$num:w:0x3c:$val:none"
|
||||
[sct controller] queue [sct] progress read
|
||||
return writereply
|
||||
}
|
||||
#--------------------------------------------------------------
|
||||
proc slsecho::readerror {num} {
|
||||
sct send "$num:r:0x29:0:none"
|
||||
return errorreply
|
||||
}
|
||||
#--------------------------------------------------------------
|
||||
proc slsecho::errorreply {} {
|
||||
global slsecho::error
|
||||
set reply [sct result]
|
||||
set l [split $reply :]
|
||||
set val [lindex $l 1]
|
||||
set key [format "0x%x" [expr int($val)]]
|
||||
clientput "$key"
|
||||
clientput "$slsecho::error($key)"
|
||||
sct update $slsecho::error($key)
|
||||
return idle
|
||||
}
|
||||
#---------------------------------------------------------------
|
||||
proc slsecho::makeslsecho {name num sct} {
|
||||
makesctdriveobj $name float user SLSEchoMagnet $sct
|
||||
hfactory /sics/${name}/tolerance plain internal float
|
||||
hset /sics/${name}/tolerance .1
|
||||
hfactory /sics/${name}/upperlimit plain internal float
|
||||
hset /sics/${name}/upperlimit 10
|
||||
hfactory /sics/${name}/lowerlimit plain internal float
|
||||
hset /sics/${name}/lowerlimit -10
|
||||
hfactory /sics/${name}/stop plain user int
|
||||
hset /sics/${name}/stop 0
|
||||
|
||||
hsetprop /sics/${name} checklimits stddrive::stdcheck $name
|
||||
hsetprop /sics/${name} checkstatus stddrive::stdstatus $name
|
||||
hsetprop /sics/${name} halt stddrive::stop $name
|
||||
|
||||
set path /sics/${name}
|
||||
hsetprop $path read slsecho::sendread $num
|
||||
hsetprop $path readreply slsecho::readreply
|
||||
$sct poll $path 10
|
||||
hsetprop $path write slsecho::sendwrite $num
|
||||
hsetprop $path writereply slsecho::writereply
|
||||
$sct write $path
|
||||
|
||||
hsetprop /sics/${name}/upperlimit read slsecho::readupper $num
|
||||
hsetprop /sics/${name}/upperlimit readreply slsecho::readreply
|
||||
$sct poll /sics/${name}/upperlimit 60
|
||||
|
||||
hsetprop /sics/${name}/lowerlimit read slsecho::readlower $num
|
||||
hsetprop /sics/${name}/lowerlimit readreply slsecho::readreply
|
||||
$sct poll /sics/${name}/lowerlimit 60
|
||||
|
||||
hfactory /sics/${name}/onoff plain user text
|
||||
hsetprop /sics/${name}/onoff read slsecho::readonoff $num
|
||||
hsetprop /sics/${name}/onoff onoffreply slsecho::onoffreply
|
||||
$sct poll /sics/${name}/onoff 60
|
||||
hsetprop /sics/${name}/onoff write slsecho::writeonoff $num
|
||||
hsetprop /sics/${name}/onoff writereply slsecho::writereply
|
||||
$sct write /sics/${name}/onoff
|
||||
|
||||
hfactory /sics/${name}/error plain internal text
|
||||
hsetprop /sics/${name}/error read slsecho::readerror $num
|
||||
hsetprop /sics/${name}/error errorreply slsecho::errorreply
|
||||
$sct poll /sics/${name}/error 10
|
||||
|
||||
#----------------- update everything
|
||||
hset /sics/${name}/onoff on
|
||||
$sct queue /sics/${name} progress read
|
||||
$sct queue /sics/${name}/upperlimit progress read
|
||||
$sct queue /sics/${name}/lowerlimit progress read
|
||||
$sct queue /sics/${name}/onoff progress read
|
||||
$sct queue /sics/${name}/error progress read
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------------------------
|
||||
# error codes
|
||||
#-------------------------------------------------------------------------------------------------
|
||||
set slsecho::error(0x0) "NO"
|
||||
set slsecho::error(0x1) "DEVICE_STATE_ERROR"
|
||||
set slsecho::error(0x2) "DEVICE_SUPERVISOR_DISABLED"
|
||||
set slsecho::error(0x3) "COMMAND_ABORT"
|
||||
set slsecho::error(0x4) "DATA_NOT_STORED"
|
||||
set slsecho::error(0x5) "ERROR_ERASING_FLASH"
|
||||
set slsecho::error(0x6) "COMMUNICATION_BREAK"
|
||||
set slsecho::error(0x7) "INTERNAL_COMMUNICATION_ERROR"
|
||||
set slsecho::error(0x8) "MASTER_CARD_ERROR"
|
||||
set slsecho::error(0x9) "INTERNAL_BUFFER_FULL"
|
||||
set slsecho::error(0xa) "WRONG_SECTOR"
|
||||
set slsecho::error(0xb) "DATA_NOT_COPIED"
|
||||
set slsecho::error(0xc) "WRONG_DOWNLOAD_PARAMETERS"
|
||||
set slsecho::error(0xd) "DEVICE_PARAMETRIZATION_ERROR"
|
||||
set slsecho::error(0x10) "TIMEOUT_DC_LINK_VOLTAGE"
|
||||
set slsecho::error(0x11) "TIMEOUT_AUXILIARY_RELAY_ON"
|
||||
set slsecho::error(0x12) "TIMEOUT_AUXILIARY_RELAY_OFF"
|
||||
set slsecho::error(0x13) "TIMEOUT_MAIN_RELAY_ON"
|
||||
set slsecho::error(0x14) "TIMEOUT_MAIN_RELAY_OFF"
|
||||
set slsecho::error(0x15) "TIMEOUT_DATA_DOWNLOAD"
|
||||
set slsecho::error(0x20) "INTERLOCK"
|
||||
set slsecho::error(0x21) "MASTER_SWITCH"
|
||||
set slsecho::error(0x22) "MAGNET_INTERLOCK"
|
||||
set slsecho::error(0x23) "TEMPERATURE_TRANSFORMER"
|
||||
set slsecho::error(0x24) "TEMPERATURE_RECTIFIER"
|
||||
set slsecho::error(0x25) "TEMPERATURE_CONVERTER"
|
||||
set slsecho::error(0x26) "CURRENT_TRANSDUCER"
|
||||
set slsecho::error(0x27) "TEMPERATURE_POLARITY_SWITCH"
|
||||
set slsecho::error(0x28) "POWER_SEMICONDUCTOR"
|
||||
set slsecho::error(0x29) "MAIN_RELAY"
|
||||
set slsecho::error(0x2a) "AD_CONVERTER_CARD"
|
||||
set slsecho::error(0x2b) "POLARITY_SWITCH"
|
||||
set slsecho::error(0x2c) "AUXILIARY_RELAY"
|
||||
set slsecho::error(0x2d) "MASTER_SWITCH_T1"
|
||||
set slsecho::error(0x2e) "MASTER_SWITCH_T2"
|
||||
set slsecho::error(0x2f) "TEMPERATURE_MAGNET"
|
||||
set slsecho::error(0x30) "WATER_MAGNET"
|
||||
set slsecho::error(0x31) "WATER_RACK"
|
||||
set slsecho::error(0x40) "LOAD_CURRENT_TOO_HIGH"
|
||||
set slsecho::error(0x41) "DC_LINK_VOLTAGE_TOO_LOW"
|
||||
set slsecho::error(0x42) "DC_LINK_VOLTAGE_TOO_HIGH"
|
||||
set slsecho::error(0x43) "LOAD_VOLTAGE_TOO_HIGH"
|
||||
set slsecho::error(0x44) "LOAD_CURRENT_RIPPLE_TOO_HIGH"
|
||||
set slsecho::error(0x45) "DC_LINK_ISOLATION_NOT_OK"
|
||||
set slsecho::error(0x46) "LOAD_ISOLATION_NOT_OK"
|
||||
set slsecho::error(0x47) "LOAD_IMPEDANCE_OUT_OF_RANGE"
|
||||
set slsecho::error(0x48) "SHUT_OFF_CURRENT_TOO_HIGH"
|
||||
set slsecho::error(0x49) "LOAD_DC_CURRENT_TOO_HIGH"
|
||||
set slsecho::error(0x4a) "CURRENT_I1A1_TOO_HIGH"
|
||||
set slsecho::error(0x4b) "CURRENT_I1B1_TOO_HIGH"
|
||||
set slsecho::error(0x4c) "CURRENT_I1A2_TOO_HIGH"
|
||||
set slsecho::error(0x4d) "CURRENT_I1B2_TOO_HIGH"
|
||||
set slsecho::error(0x4e) "CURRENT_I2A1_TOO_HIGH"
|
||||
set slsecho::error(0x4f) "CURRENT_I2B1_TOO_HIGH"
|
||||
set slsecho::error(0x50) "CURRENT_I2A2_TOO_HIGH"
|
||||
set slsecho::error(0x51) "CURRENT_I2B2_TOO_HIGH"
|
||||
set slsecho::error(0x52) "CURRENT_I3P_TOO_HIGH"
|
||||
set slsecho::error(0x53) "CURRENT_I3N_TOO_HIGH"
|
||||
set slsecho::error(0x54) "CURRENT_IE_TOO_HIGH"
|
||||
set slsecho::error(0x55) "VOLTAGE_U1A_TOO_LOW"
|
||||
set slsecho::error(0x56) "VOLTAGE_U1B_TOO_LOW"
|
||||
set slsecho::error(0x57) "DIFF_CURRENT_I1A1_I1A2_TOO_HIGH"
|
||||
set slsecho::error(0x58) "DIFF_CURRENT_I1B1_I1B2_TOO_HIGH"
|
||||
set slsecho::error(0x59) "DIFF_CURRENT_I2A1_I2A2_TOO_HIGH"
|
||||
set slsecho::error(0x5a) "DIFF_CURRENT_I2B1_I2B2_TOO_HIGH"
|
||||
set slsecho::error(0x5b) "DIFF_CURRENT_I3P_I3N_TOO_HIGH"
|
||||
set slsecho::error(0x5c) "CURRENT_I1A_TOO_HIGH"
|
||||
set slsecho::error(0x5d) "CURRENT_I1B_TOO_HIGH"
|
||||
set slsecho::error(0x5e) "CURRENT_I3A1_TOO_HIGH"
|
||||
set slsecho::error(0x5f) "CURRENT_I3B1_TOO_HIGH"
|
||||
set slsecho::error(0x60) "CURRENT_I3A2_TOO_HIGH"
|
||||
set slsecho::error(0x61) "CURRENT_I3B2_TOO_HIGH"
|
||||
set slsecho::error(0x62) "CURRENT_I4_TOO_HIGH"
|
||||
set slsecho::error(0x63) "CURRENT_I5_TOO_HIGH"
|
||||
set slsecho::error(0x64) "DIFF_CURRENT_I3A1_I3A2_TOO_HIGH"
|
||||
set slsecho::error(0x65) "DIFF_CURRENT_I3B1_I3B2_TOO_HIGH"
|
||||
set slsecho::error(0x66) "DIFF_CURRENT_I4_I5_TOO_HIGH"
|
||||
set slsecho::error(0x67) "VOLTAGE_U3A_TOO_LOW"
|
||||
set slsecho::error(0x68) "VOLTAGE_U3B_TOO_LOW"
|
||||
set slsecho::error(0x69) "VOLTAGE_U1_TOO_LOW"
|
||||
set slsecho::error(0x6a) "VOLTAGE_U3A_TOO_HIGH"
|
||||
set slsecho::error(0x6b) "VOLTAGE_U3B_TOO_HIGH"
|
||||
set slsecho::error(0x6c) "SPEED_ERROR_TOO_HIGH"
|
||||
set slsecho::error(0x70) "MAIN_RELAY_A"
|
||||
set slsecho::error(0x71) "MAIN_RELAY_B"
|
||||
set slsecho::error(0x72) "POWER_SWITCH_A"
|
||||
set slsecho::error(0x73) "POWER_SWITCH_B"
|
||||
set slsecho::error(0x74) "MONITOR_TRAFO_A"
|
||||
set slsecho::error(0x75) "MONITOR_TRAFO_B"
|
||||
set slsecho::error(0x76) "TEMPERATURE_RECTIFIER_A"
|
||||
set slsecho::error(0x77) "TEMPERATURE_RECTIFIER_B"
|
||||
set slsecho::error(0x78) "TEMPERATURE_CONVERTER_A"
|
||||
set slsecho::error(0x79) "TEMPERATURE_CONVERTER_B"
|
||||
set slsecho::error(0x7a) "TEMPERATURE_CONVERTER_A1"
|
||||
set slsecho::error(0x7b) "TEMPERATURE_CONVERTER_B1"
|
||||
set slsecho::error(0x7c) "TEMPERATURE_CONVERTER_A2"
|
||||
set slsecho::error(0x7d) "TEMPERATURE_CONVERTER_B2"
|
||||
set slsecho::error(0x7e) "TEMPERATURE_TRANSFORMER_A"
|
||||
set slsecho::error(0x7f) "TEMPERATURE_TRANSFORMER_B"
|
||||
set slsecho::error(0x80) "WATER_RECTIFIER_A"
|
||||
set slsecho::error(0x81) "WATER_RECTIFIER_B"
|
||||
set slsecho::error(0x82) "WATER_CONVERTER_A"
|
||||
set slsecho::error(0x83) "WATER_CONVERTER_B"
|
||||
set slsecho::error(0x84) "WATER_CONVERTER_A1"
|
||||
set slsecho::error(0x85) "WATER_CONVERTER_B1"
|
||||
set slsecho::error(0x86) "WATER_CONVERTER_A2"
|
||||
set slsecho::error(0x87) "WATER_CONVERTER_B2"
|
||||
set slsecho::error(0x88) "WATER_TRANSFORMER_A"
|
||||
set slsecho::error(0x89) "WATER_TRANSFORMER_B"
|
||||
set slsecho::error(0x8a) "DOOR_A"
|
||||
set slsecho::error(0x8b) "DOOR_B"
|
||||
set slsecho::error(0x8c) "DOOR_C"
|
||||
set slsecho::error(0x8d) "POWER_SEMICONDUCTOR_CONVERTER_A"
|
||||
set slsecho::error(0x8e) "POWER_SEMICONDUCTOR_CONVERTER_B"
|
||||
set slsecho::error(0x8f) "POWER_SEMICONDUCTOR_CONVERTER_A1"
|
||||
set slsecho::error(0x90) "POWER_SEMICONDUCTOR_CONVERTER_B1"
|
||||
set slsecho::error(0x91) "POWER_SEMICONDUCTOR_CONVERTER_A2"
|
||||
set slsecho::error(0x92) "POWER_SEMICONDUCTOR_CONVERTER_B2"
|
||||
set slsecho::error(0x93) "CURRENT_TRANSDUCER_I3P"
|
||||
set slsecho::error(0x94) "CURRENT_TRANSDUCER_I3N"
|
||||
set slsecho::error(0x95) "MAGNET_INTERLOCK_1"
|
||||
set slsecho::error(0x96) "MAGNET_INTERLOCK_2"
|
||||
set slsecho::error(0x97) "VENTILATOR"
|
||||
set slsecho::error(0x98) "EMERGENCY_SWITCH"
|
||||
set slsecho::error(0x99) "CAPACITOR_DISCHARGE_A_ON"
|
||||
set slsecho::error(0x9a) "CAPACITOR_DISCHARGE_B_ON"
|
||||
set slsecho::error(0x9b) "CURRENT_TRANSDUCER_I4"
|
||||
set slsecho::error(0x9c) "CURRENT_TRANSDUCER_I5"
|
||||
set slsecho::error(0xb0) "TIMEOUT_DC_LINK_VOLTAGE_PART_A"
|
||||
set slsecho::error(0xb1) "TIMEOUT_DC_LINK_VOLTAGE_PART_B"
|
||||
set slsecho::error(0xb2) "TIMEOUT_AUXILIARY_RELAY_A_ON"
|
||||
set slsecho::error(0xb3) "TIMEOUT_AUXILIARY_RELAY_B_ON"
|
||||
set slsecho::error(0xb4) "TIMEOUT_AUXILIARY_RELAY_A_OFF"
|
||||
set slsecho::error(0xb5) "TIMEOUT_AUXILIARY_RELAY_B_OFF"
|
||||
set slsecho::error(0xb6) "TIMEOUT_MAIN_RELAY_A_ON"
|
||||
set slsecho::error(0xb7) "TIMEOUT_MAIN_RELAY_B_ON"
|
||||
set slsecho::error(0xb8) "TIMEOUT_MAIN_RELAY_A_OFF"
|
||||
set slsecho::error(0xb9) "TIMEOUT_MAIN_RELAY_B_OFF"
|
||||
|
||||
100
tcl/stddrive.tcl
100
tcl/stddrive.tcl
@ -1,100 +0,0 @@
|
||||
#------------------------------------------------------
|
||||
# This is some code for a standard drivable object in
|
||||
# the scriptcontext system. It implements an empty
|
||||
# object which throws errors when accessed. Users
|
||||
# of such an object can override it to do
|
||||
# something more acceptable. This object also
|
||||
# provides for basic limit checking and status
|
||||
# checking. It can serve as a basis for creating
|
||||
# new drivable objects, for instance environment
|
||||
# control devices. A possible user has as the
|
||||
# first thing in a write script to set the target
|
||||
# node to the desired value.
|
||||
#
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# Mark Koennecke, November 2009
|
||||
#--------------------------------------------------------
|
||||
|
||||
namespace eval stddrive {}
|
||||
|
||||
proc stddrive::stdcheck {name} {
|
||||
set val [sct target]
|
||||
set upper [hval /sics/${name}/upperlimit]
|
||||
set lower [hval /sics/${name}/lowerlimit]
|
||||
if {$val < $lower || $val > $upper} {
|
||||
error "$val is out of range $lower - $upper for $name"
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#-------------------------------------------------------
|
||||
proc stddrive::stdstatus {name} {
|
||||
set test [catch {sct geterror} errortxt]
|
||||
if {$test == 0} {
|
||||
return fault
|
||||
}
|
||||
set stop [hval /sics/${name}/stop]
|
||||
if {$stop == 1} {
|
||||
return fault
|
||||
}
|
||||
set target [sct target]
|
||||
set tol [hval /sics/${name}/tolerance]
|
||||
set is [hval /sics/${name}]
|
||||
if {abs($target - $is) < $tol} {
|
||||
return idle
|
||||
} else {
|
||||
[sct controller] queue /sics/${name} progress read
|
||||
return busy
|
||||
}
|
||||
}
|
||||
#-------------------------------------------------------
|
||||
proc stddrive::stop {name} {
|
||||
hset /sics/${name}/stop 1
|
||||
return idle
|
||||
}
|
||||
#-------------------------------------------------------
|
||||
proc stddrive::deread {} {
|
||||
sct update -9999.99
|
||||
return idle
|
||||
}
|
||||
#--------------------------------------------------------
|
||||
proc stddrive::dewrite {name} {
|
||||
# hset /sics/${name}/stop 1
|
||||
error "$name is not configured, cannot drive"
|
||||
}
|
||||
#--------------------------------------------------------
|
||||
proc stddrive::deconfigure {name} {
|
||||
set allowed [list upperlimit lowerlimit tolerance stop]
|
||||
set nodelist [split [hlist /sics/${name}] \n]
|
||||
foreach node $nodelist {
|
||||
if {[string length $node] < 1} {
|
||||
continue
|
||||
}
|
||||
if {[lsearch -exact $allowed [string trim $node]] < 0} {
|
||||
clientput "Deleting $node"
|
||||
hdel /sics/${name}/${node}
|
||||
}
|
||||
}
|
||||
hsetprop /sics/${name} read stddrive::deread
|
||||
hsetprop /sics/${name} write stddrive::dewrite $name
|
||||
}
|
||||
#--------------------------------------------------------
|
||||
proc stddrive::makestddrive {name sicsclass sct} {
|
||||
makesctdriveobj $name float user $sicsclass $sct
|
||||
hfactory /sics/${name}/tolerance plain user float
|
||||
hset /sics/${name}/tolerance 2.0
|
||||
hfactory /sics/${name}/upperlimit plain user float
|
||||
hset /sics/${name}/upperlimit 300
|
||||
hfactory /sics/${name}/lowerlimit plain user float
|
||||
hset /sics/${name}/lowerlimit 10
|
||||
hfactory /sics/${name}/stop plain user int
|
||||
hset /sics/${name}/stop 0
|
||||
|
||||
hsetprop /sics/${name} checklimits stddrive::stdcheck $name
|
||||
hsetprop /sics/${name} checkstatus stddrive::stdstatus $name
|
||||
hsetprop /sics/${name} halt stddrive::stop $name
|
||||
deconfigure $name
|
||||
$sct write /sics/${name}
|
||||
$sct poll /sics/${name} 60
|
||||
hupdate /sics/${name} -9999.99
|
||||
}
|
||||
@ -1,23 +0,0 @@
|
||||
|
||||
proc readProgA {pid} {
|
||||
global readProgADone;
|
||||
|
||||
# read outputs of schemdb
|
||||
set tmpbuf [gets $pid];
|
||||
puts "received $tmpbuf\n";
|
||||
|
||||
set readProgADone [eof $pid];
|
||||
|
||||
if {$readProgADone} {
|
||||
puts "closing...";
|
||||
catch [close $pid] aa;
|
||||
if {$aa != ""} {
|
||||
puts "HERE1: Error on closing";
|
||||
exit 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# set the "read" event
|
||||
fileevent stdin readable {readProgA stdin};
|
||||
|
||||
@ -1,62 +0,0 @@
|
||||
#----------------------------------------------------------------------------
|
||||
# suchscan : a very fast scan. A motor is set to run, the counter is started
|
||||
# and the counter read as fast as possible. Current motor position and
|
||||
# counts are printed. For quick and dirty location of peaks.
|
||||
#
|
||||
# Mark Koennecke, October 1998
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
proc scGetNum { text } {
|
||||
set list [split $text =]
|
||||
return [lindex $list 1]
|
||||
}
|
||||
|
||||
|
||||
# set the counter name
|
||||
set ctr counter
|
||||
|
||||
#----------- check if var still driving
|
||||
proc runtest {var } {
|
||||
set t [listexe]
|
||||
if {[string first $var $t] >= 0} {
|
||||
return 1
|
||||
} else {
|
||||
return 0
|
||||
}
|
||||
}
|
||||
#-------------------------- the actual susca
|
||||
proc susca args {
|
||||
global ctr
|
||||
if {[llength $args] < 4} {
|
||||
ClientPut "USAGE: susca var start length time"
|
||||
error "ERROR: Insufficient number of arguments to susca"
|
||||
}
|
||||
#------ drive to start position
|
||||
set var [lindex $args 0]
|
||||
set start [lindex $args 1]
|
||||
set end [lindex $args 2]
|
||||
set ctime [lindex $args 3]
|
||||
set ret [catch {drive $var $start} msg]
|
||||
if {$ret != 0 } {
|
||||
error "ERROR: $msg"
|
||||
}
|
||||
set last 0
|
||||
#------- start counter
|
||||
$ctr setmode timer
|
||||
$ctr countnb $ctime
|
||||
#-------- start motor
|
||||
set ret [catch {run $var $end} msg]
|
||||
if {$ret != 0 } {
|
||||
error "ERROR: $msg"
|
||||
}
|
||||
#------ scan loop
|
||||
while {[runtest $var] == 1} {
|
||||
set ct [scGetNum [$ctr getcounts]]
|
||||
set ncts [expr abs($ct - $last)]
|
||||
set last $ct
|
||||
set vp [scGetNum [$var]]
|
||||
ClientPut [format "%8.2f %12.2f" $vp $ncts]
|
||||
}
|
||||
ClientPut "OK"
|
||||
}
|
||||
|
||||
317
tcl/table.tcl
317
tcl/table.tcl
@ -1,317 +0,0 @@
|
||||
#----------------------------------------------------------------------
|
||||
# Support functions for table processing in SICS
|
||||
#
|
||||
# This includes a CSV processing module from someone else. See below.
|
||||
#
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# Mark Koennecke, November 2008
|
||||
#----------------------------------------------------------------------
|
||||
if { [info exists __tableheader] == 0 } {
|
||||
set __tableheader NULL
|
||||
Publish tableexe User
|
||||
Publish loop User
|
||||
}
|
||||
#=====================================================================
|
||||
# Csv tcl package version 2.0
|
||||
# A tcl library to deal with CSV (comma separated value)
|
||||
# files, generated and readable by some DOS/Windows programs
|
||||
# Contain two functions:
|
||||
# csv2list string ?separator?
|
||||
# and
|
||||
# list2csv list ?separator?
|
||||
# which converts line from CSV file to list and vice versa.
|
||||
#
|
||||
# Both functions have optional "separator argument" becouse some silly
|
||||
# Windows
|
||||
# program might use semicomon as delimiter in COMMA separated values
|
||||
# file.
|
||||
#
|
||||
# Copyright (c) SoftWeyr, 1997-99
|
||||
# Many thanks to Robert Seeger <rseeger1@nycap.rr.com>
|
||||
# for beta-testing and fixing my misprints
|
||||
# This file is distributed under GNU Library Public License. Visit
|
||||
# http://www.gnu.org/copyleft/gpl.html
|
||||
# for details.
|
||||
|
||||
#
|
||||
# Convert line, read from CSV file into proper TCL list
|
||||
# Commas inside quoted strings are not considered list delimiters,
|
||||
# Double quotes inside quoted strings are converted to single quotes
|
||||
# Double quotes are stripped out and replaced with correct Tcl quoting
|
||||
#
|
||||
|
||||
proc csv2list {str {separator ","}} {
|
||||
#build a regexp>
|
||||
set regexp [subst -nocommands \
|
||||
{^[ \t\r\n]*("(([^"]|"")*)"|[^"$separator \t\r]*)}]
|
||||
set regexp1 [subst -nocommands {$regexp[ \t\r\n]*$separator\(.*)$}]
|
||||
set regexp2 [subst -nocommands {$regexp[ \t\r\n]*\$}]
|
||||
set list {}
|
||||
while {[regexp $regexp1 $str junk1 unquoted quoted\
|
||||
junk2 str]} {
|
||||
if {[string length $quoted]||$unquoted=="\"\""} {
|
||||
regsub -all {""} $quoted \" unquoted
|
||||
}
|
||||
lappend list $unquoted
|
||||
}
|
||||
if {[regexp $regexp2 $str junk unquoted quoted]} {
|
||||
if {[string length $quoted]||$unquoted=="\"\""} {
|
||||
regsub -all {""} $quoted \" unquoted
|
||||
}
|
||||
lappend list $unquoted
|
||||
if {[uplevel info exist csvtail]} {
|
||||
uplevel set csvtail {""}
|
||||
}
|
||||
} else {
|
||||
if {[uplevel info exist csvtail]} {
|
||||
uplevel [list set csvtail $str]
|
||||
} else {
|
||||
return -code error -errorcode {CSV 1 "CSV parse error"}\
|
||||
"CSV parse error: unparsed tail \"$str\""
|
||||
}
|
||||
}
|
||||
return $list
|
||||
}
|
||||
|
||||
proc list2csv {list {separator ","}} {
|
||||
set l {}
|
||||
foreach elem $list {
|
||||
if {[string match {} $elem]||
|
||||
[regexp {^[+-]?([0-9]+|([0-9]+\.?[0-9]*|\.[0-9]+)([eE][+-]?[0-9]+)?)$}\
|
||||
$elem]} {
|
||||
lappend l $elem
|
||||
} else {
|
||||
regsub -all {"} $elem {""} selem
|
||||
lappend l "\"$selem\""
|
||||
}
|
||||
}
|
||||
return [join $l $separator]
|
||||
}
|
||||
|
||||
proc csvfile {f {separator ","}} {
|
||||
set csvtail ""
|
||||
set list {}
|
||||
set buffer {}
|
||||
while {[gets $f line]>=0} {
|
||||
if {[string length $csvtail]} {
|
||||
set line "$csvtail\n$line"
|
||||
} elseif {![string length $line]} {
|
||||
lappend list {}
|
||||
continue
|
||||
}
|
||||
set rec [csv2list $line $separator]
|
||||
set buffer [concat $buffer $rec]
|
||||
if {![ string length $csvtail]} {
|
||||
lappend list $buffer
|
||||
set buffer {}
|
||||
}
|
||||
}
|
||||
if {[string length $csvtail]} {
|
||||
return -code error -errorcode {CSV 2 "Multiline parse error"}\
|
||||
"CSV file parse error"
|
||||
}
|
||||
return $list
|
||||
}
|
||||
|
||||
proc csvstring {str {separator ","}} {
|
||||
set csvtail ""
|
||||
set list {}
|
||||
set buffer {}
|
||||
foreach line [split $str "\n"] {
|
||||
if {[string length $csvtail]} {
|
||||
set line "$csvtail\n$line"
|
||||
} elseif {![string length $line]} {
|
||||
lappend list {}
|
||||
continue
|
||||
}
|
||||
set rec [csv2list $line $separator]
|
||||
set buffer [concat $buffer $rec]
|
||||
if {![ string length $csvtail]} {
|
||||
lappend list $buffer
|
||||
set buffer {}
|
||||
}
|
||||
}
|
||||
if {[string length $cvstail]} {
|
||||
return -code error -errorcode {CSV 2 "Multiline parse error"}\
|
||||
"CSV string parse error"
|
||||
}
|
||||
return $list
|
||||
}
|
||||
|
||||
package provide Csv 2.1
|
||||
#========================================================================
|
||||
# The plan here is such: operations which happen fast or immediatly are
|
||||
# done at once. Count commands or anything given as command is appended
|
||||
# to a list for later execution. The idea is that this contains the
|
||||
# actual measuring payload of the row.
|
||||
# Drivables are immediatly started.
|
||||
# After processing the rows, there is a success to wait for motors to arrive
|
||||
# Then the commands for later execution are run. This frees the user of the
|
||||
# the necessity to have the count or whatever command as the last thing in the row
|
||||
#--------------------------------------------------------------------------------
|
||||
proc testinterrupt {} {
|
||||
set int [getint]
|
||||
if {[string first continue $int] < 0} {
|
||||
error "Interrupted"
|
||||
}
|
||||
}
|
||||
#--------------------------------------------------------------------------------
|
||||
proc processtablerow {line} {
|
||||
global __tableheader
|
||||
set parlist [csv2list $line]
|
||||
for {set i 0} {$i < [llength $__tableheader]} {incr i} {
|
||||
set type [lindex $__tableheader $i]
|
||||
set data [lindex $parlist $i]
|
||||
#--------- first process special types
|
||||
switch $type {
|
||||
monitor {
|
||||
lappend laterExe "count monitor $data"
|
||||
continue
|
||||
}
|
||||
timer {
|
||||
lappend laterExe "count timer $data"
|
||||
continue
|
||||
}
|
||||
compar {
|
||||
append command [join [lrange $parlist $i end]]
|
||||
lappend laterExe $command
|
||||
break
|
||||
}
|
||||
command {
|
||||
lappend laterExe $data
|
||||
continue
|
||||
}
|
||||
batch {
|
||||
lappend laterExe "exe $data"
|
||||
continue
|
||||
}
|
||||
}
|
||||
#----------- now look for drivables
|
||||
set test [sicstype $type]
|
||||
if {[string compare $test DRIV] == 0} {
|
||||
set status [catch {run $type $data} msg]
|
||||
if {$status != 0} {
|
||||
clientput "ERROR: $msg for $type with $data"
|
||||
}
|
||||
continue
|
||||
}
|
||||
#------------- now look for special objects
|
||||
set objtype [sicsdescriptor $type]
|
||||
switch $objtype {
|
||||
SicsVariable -
|
||||
MulMot -
|
||||
Macro {
|
||||
set status [catch {eval $type $data} msg]
|
||||
if {$status != 0} {
|
||||
clientput "ERROR: $msg for $type with $data"
|
||||
}
|
||||
continue
|
||||
}
|
||||
default {
|
||||
clientput "Skipping non recognized column $type with data $data"
|
||||
}
|
||||
}
|
||||
}
|
||||
set status [catch {success} msg]
|
||||
if {$status != 0} {
|
||||
clientput "ERROR: $msg while waiting for motors to arrive"
|
||||
}
|
||||
testinterrupt
|
||||
foreach command $laterExe {
|
||||
eval $command
|
||||
testinterrupt
|
||||
}
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc tableexe {tablefile} {
|
||||
global __tableheader
|
||||
if {[string first NULL $__tableheader] < 0} {
|
||||
error "Tableexe already running, terminated"
|
||||
}
|
||||
set fullfile [SplitReply [exe fullpath $tablefile]]
|
||||
set in [open $fullfile r]
|
||||
gets $in header
|
||||
set __tableheader [csv2list $header]
|
||||
while {[gets $in line] > 0} {
|
||||
set status [catch {processtablerow $line} msg]
|
||||
if {$status != 0} {
|
||||
set int [getint]
|
||||
if {[string first continue $int] < 0} {
|
||||
break
|
||||
} else {
|
||||
clientput "ERROR: $msg while processing row"
|
||||
}
|
||||
}
|
||||
}
|
||||
close $in
|
||||
set __tableheader NULL
|
||||
return "Done processing table"
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
proc loop args {
|
||||
clientput $args
|
||||
if {[llength $args] < 2} {
|
||||
error \
|
||||
"Usage: loop <no> <sicscommand>\n\t<no> number of repetions\n\t<sicscommand> any SICS command"
|
||||
}
|
||||
set len [lindex $args 0]
|
||||
set command [lrange $args 1 end]
|
||||
for {set i 1} {$i <= $len} {incr i} {
|
||||
clientput "Repetition $i of $len"
|
||||
set status [catch {eval [join $command]} msg]
|
||||
if {$status != 0} {
|
||||
clientput "ERROR: $msg while processing loop command"
|
||||
}
|
||||
testinterrupt
|
||||
}
|
||||
}
|
||||
#==============================================================================
|
||||
# This is an old attempt
|
||||
#=============================================================================
|
||||
proc __tablescan__ args {
|
||||
global __tableheader
|
||||
|
||||
set idx [lsearch $__tableheader monitor]
|
||||
if {$idx >= 0} {
|
||||
set preset [lindex $args $idx]
|
||||
set mode monitor
|
||||
}
|
||||
set idx [lsearch $__tableheader timer]
|
||||
if {$idx >= 0} {
|
||||
set preset [lindex $args $idx]
|
||||
set mode timer
|
||||
}
|
||||
|
||||
set idx [lsearch $__tableheader scanvar]
|
||||
if {$idx >= 0} {
|
||||
set var [lindex $args $idx]
|
||||
} else {
|
||||
error "ERROR: No scan variable in table"
|
||||
}
|
||||
|
||||
set idx [lsearch $__tableheader scanstart]
|
||||
if {$idx >= 0} {
|
||||
set start [lindex $args $idx]
|
||||
} else {
|
||||
error "ERROR: No scan start in table"
|
||||
}
|
||||
|
||||
set idx [lsearch $__tableheader scanend]
|
||||
if {$idx >= 0} {
|
||||
set end [lindex $args $idx]
|
||||
} else {
|
||||
error "ERROR: No scan end in table"
|
||||
}
|
||||
|
||||
set idx [lsearch $__tableheader scanstep]
|
||||
if {$idx >= 0} {
|
||||
set step [lindex $args $idx]
|
||||
} else {
|
||||
error "ERROR: No scan step in table"
|
||||
}
|
||||
|
||||
set np [expr abs($end - $start)/$step]
|
||||
xxxscan var $var $start $step
|
||||
xxxscan run $np $mode $preset
|
||||
}
|
||||
12
tcl/tail.tcl
12
tcl/tail.tcl
@ -1,12 +0,0 @@
|
||||
#--------------------------------------------------------------------------
|
||||
# Implementation of the SICS tail command. This uses the unix sicstail
|
||||
# command which is defined for the instrument user.
|
||||
#
|
||||
# Mark Koennecke, June 1999
|
||||
#-------------------------------------------------------------------------
|
||||
|
||||
proc tail { {n 20} } {
|
||||
set txt [exec sicstail $n]
|
||||
ClientPut $txt
|
||||
return
|
||||
}
|
||||
772
tcl/topsiold.tcl
772
tcl/topsiold.tcl
@ -1,772 +0,0 @@
|
||||
#----------------------------------------------------------------------------
|
||||
# Scan command implementation for TOPSI
|
||||
# Test version, Mark Koennecke, February 1997
|
||||
#----------------------------------------------------------------------------
|
||||
set home /data/koenneck/src/sics/tcl
|
||||
set datapath /data/koenneck/src/sics/tmp
|
||||
set recoverfil /data/koenneck/src/sics/recover.dat
|
||||
|
||||
bpOn
|
||||
|
||||
source $home/utils.tcl
|
||||
source $home/base.tcl
|
||||
source $home/inherit.tcl
|
||||
source $home/obtcl.tcl
|
||||
#-------------------------- some utility functions -------------------------
|
||||
proc MC { t n } {
|
||||
set string $t
|
||||
for { set i 1 } { $i < $n } { incr i } {
|
||||
set string [format "%s%s" $string $t]
|
||||
}
|
||||
return $string
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc GetNum { text } {
|
||||
set list [split $text =]
|
||||
return [lindex $list 1]
|
||||
}
|
||||
#-------------------------- String list for writing ------------------------
|
||||
class DataSet
|
||||
DataSet method init { } {
|
||||
instvar N
|
||||
instvar Data
|
||||
next
|
||||
set Data(0) " Bla"
|
||||
set N 0
|
||||
}
|
||||
|
||||
DataSet method add { text } {
|
||||
instvar N
|
||||
instvar Data
|
||||
set Data($N) $text
|
||||
incr N
|
||||
}
|
||||
|
||||
DataSet method ins { text i } {
|
||||
instvar Data
|
||||
instvar N
|
||||
if { $i >= $N } {
|
||||
set N [expr $i + 1]
|
||||
} else {
|
||||
unset Data($i)
|
||||
}
|
||||
set Data($i) $text
|
||||
}
|
||||
DataSet method put { file } {
|
||||
instvar Data
|
||||
instvar N
|
||||
|
||||
for { set i 0 } { $i < $N } { incr i } {
|
||||
puts $file $Data($i)
|
||||
}
|
||||
}
|
||||
|
||||
DataSet method clear { } {
|
||||
instvar Data
|
||||
instvar N
|
||||
unset Data
|
||||
set Data(0) "Bla"
|
||||
set N 0
|
||||
}
|
||||
DataSet method GetN { } {
|
||||
instvar N
|
||||
return $N
|
||||
}
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
# scan class initialization
|
||||
class ScanCommand
|
||||
|
||||
ScanCommand method init { counter } {
|
||||
instvar ScanData
|
||||
instvar [DataSet new Data]
|
||||
instvar Active
|
||||
instvar Recover
|
||||
next
|
||||
set ScanData(Mode) Timer
|
||||
set ScanData(NP) 1
|
||||
set ScanData(counter) $counter
|
||||
set ScanData(NoVar) 0
|
||||
set ScanData(Preset) 10.
|
||||
set ScanData(File) Default.dat
|
||||
set ScanData(Counts) " "
|
||||
set ScanData(cinterest) " "
|
||||
set ScanData(pinterest) " "
|
||||
set Active 0
|
||||
set Recover 0
|
||||
}
|
||||
#-------------add scan variables---------------------------------------------
|
||||
ScanCommand method var { name start step } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
instvar Active
|
||||
# check for activity
|
||||
if {$Active} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
# check parameters
|
||||
set t [SICSType $name]
|
||||
if { [string compare $t DRIV] != 0 } {
|
||||
ClientPut [format "ERROR: %s is not drivable" $name] error
|
||||
return 0
|
||||
}
|
||||
set t [SICSType $start]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $start] error
|
||||
return 0
|
||||
}
|
||||
set t [SICSType $step]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $step] error
|
||||
return 0
|
||||
}
|
||||
# install the variable
|
||||
set i $ScanData(NoVar)
|
||||
set ScanData(NoVar) [incr ScanData(NoVar)]
|
||||
set ScanVar($i,Var) $name
|
||||
set ScanVar($i,Start) $start
|
||||
set ScanVar($i,Step) $step
|
||||
set ScanVar($i,Value) " "
|
||||
$self SendInterest pinterest ScanVarChange
|
||||
ClientPut OK
|
||||
}
|
||||
#---------------------- getvars ------------------------------------------
|
||||
ScanCommand method getvars {} {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
set list ""
|
||||
for {set i 0} { $i < $ScanData(NoVar) } { incr i} {
|
||||
lappend list $ScanVar($i,Var)
|
||||
}
|
||||
return [format "scan.Vars = %s -END-" $list]
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
ScanCommand method xaxis {} {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
if { $ScanData(NoVar) <= 0} {
|
||||
#---- default Answer
|
||||
set t [format "%s.xaxis = %f %f" $self 0 1]
|
||||
} else {
|
||||
set t [format "%s.xaxis = %f %f" $self $ScanVar(0,Start) \
|
||||
$ScanVar(0,Step)]
|
||||
}
|
||||
ClientPut $t
|
||||
}
|
||||
#--------------------- modvar --------------------------------------------
|
||||
ScanCommand method modvar {name start step } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
for {set i 0} { $i < $ScanData(NoVar) } { incr i} {
|
||||
if { [string compare $name $ScanVar($i,Var)] == 0} {
|
||||
set t [SICSType $start]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $start] error
|
||||
return 0
|
||||
}
|
||||
set t [SICSType $step]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $step] error
|
||||
return 0
|
||||
}
|
||||
#-------- do it
|
||||
set ScanVar($i,Start) $start
|
||||
set ScanVar($i,Step) $step
|
||||
return OK
|
||||
}
|
||||
}
|
||||
error [format "Scan Variable %s NOT found" $name]
|
||||
}
|
||||
#----------------- interests ----------------------------------------------
|
||||
ScanCommand method cinterest {} {
|
||||
instvar ScanData
|
||||
set nam [GetNum [config MyName]]
|
||||
lappend ScanData(cinterest) $nam
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
ScanCommand method pinterest {} {
|
||||
instvar ScanData
|
||||
set nam [GetNum [config MyName]]
|
||||
lappend ScanData(pinterest) $nam
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
ScanCommand method SendInterest { type text } {
|
||||
instvar ScanData
|
||||
#------ check list first
|
||||
set l1 $ScanData($type)
|
||||
set l2 ""
|
||||
foreach e $l1 {
|
||||
set b [string trim $e]
|
||||
set g [string trim $b "{}"]
|
||||
set ret [SICSType $g]
|
||||
if { [string first COM $ret] >= 0 } {
|
||||
lappend l2 $e
|
||||
}
|
||||
}
|
||||
#-------- update scan data and write
|
||||
set ScanData($type) $l2
|
||||
foreach e $l2 {
|
||||
set b [string trim $e]
|
||||
$b put $text
|
||||
}
|
||||
}
|
||||
#---------------- Change Mode ----------------------------------------------
|
||||
ScanCommand method Mode { {NewVal NULL } } {
|
||||
instvar ScanData
|
||||
instvar Active
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%.Mode = %s" $self $ScanData(Mode)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$Active} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
if { ([string compare $NewVal "Timer"] == 0) || \
|
||||
([string compare $NewVal Monitor] ==0) } {
|
||||
set ScanData(Mode) $NewVal
|
||||
ClientPut OK
|
||||
} else {
|
||||
ClientPut [format "ERROR: %s not recognized as ScanMode" $NewVal]
|
||||
}
|
||||
}
|
||||
}
|
||||
#----------------------------- NP -------------------------------------------
|
||||
ScanCommand method NP { { NewVal NULL } } {
|
||||
instvar ScanData
|
||||
instvar Active
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.NP = %d" $self $ScanData(NP)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$Active} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
set t [SICSType $NewVal]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number" $NewVal] error
|
||||
return
|
||||
}
|
||||
set ScanData(NP) $NewVal
|
||||
ClientPut OK
|
||||
}
|
||||
}
|
||||
#------------------------------ Preset ------------------------------------
|
||||
ScanCommand method Preset { {NewVal NULL} } {
|
||||
instvar ScanData
|
||||
instvar Active
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.Preset = %f" $self $ScanData(Preset)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$Active} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
set ScanData(Preset) $NewVal
|
||||
set t [SICSType $NewVal]
|
||||
if { [string compare $t NUM] != 0} {
|
||||
ClientPut [format "ERROR: %s is no number" $NewVal] error
|
||||
return
|
||||
}
|
||||
ClientPut OK
|
||||
}
|
||||
}
|
||||
#------------------------------ File ------------------------------------
|
||||
ScanCommand method File { {NewVal NULL} } {
|
||||
instvar ScanData
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.File = %s" $self $ScanData(File)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
set ScanData(File) $NewVal
|
||||
ClientPut OK
|
||||
}
|
||||
}
|
||||
#--------------------------- Count ---------------------------------------
|
||||
# These and the commands below are for use in recovery only
|
||||
ScanCommand method RecoCount { val } {
|
||||
instvar Recover
|
||||
instvar ScanData
|
||||
if { ! $Recover } {
|
||||
ClientPut \
|
||||
"ERROR: This command may only be used in Recovery Operations" \
|
||||
error
|
||||
return
|
||||
}
|
||||
set ScanData(Counts) $val
|
||||
}
|
||||
#--------------------------- monitor -------------------------------------
|
||||
ScanCommand method RecoMonitor { val } {
|
||||
instvar Recover
|
||||
instvar ScanData
|
||||
if { ! $Recover } {
|
||||
ClientPut \
|
||||
"ERROR: This command may only be used in Recovery Operations" \
|
||||
error
|
||||
return
|
||||
}
|
||||
set ScanData(Monitor) $val
|
||||
}
|
||||
#--------------------------- var -------------------------------------
|
||||
ScanCommand method RecoVar { var val } {
|
||||
instvar Recover
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
if { ! $Recover } {
|
||||
ClientPut \
|
||||
"ERROR: This command may only be used in Recovery Operations" \
|
||||
error
|
||||
return
|
||||
}
|
||||
set ScanVar($var,Value) $val
|
||||
}
|
||||
#--------------------------- WriteRecover --------------------------------
|
||||
ScanCommand method WriteRecover { } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
global recoverfil
|
||||
|
||||
set fd [open $recoverfil w]
|
||||
puts $fd [format "%s Preset %s " $self $ScanData(Preset)]
|
||||
puts $fd [format "%s Mode %s " $self $ScanData(Mode)]
|
||||
puts $fd [format "%s NP %s " $self $ScanData(NP)]
|
||||
puts $fd [format "%s File %s " $self $ScanData(File)]
|
||||
for { set i 0 } { $i < $ScanData(NoVar) } { incr i } {
|
||||
puts $fd [format "%s var %s %s %s" $self $ScanVar($i,Var) \
|
||||
$ScanVar($i,Start) $ScanVar($i,Step)]
|
||||
puts $fd [format "%s RecoVar %d %s" $self $i [list $ScanVar($i,Value)]]
|
||||
}
|
||||
puts $fd [format "%s RecoCount %s" $self [list $ScanData(Counts)]]
|
||||
puts $fd [format "%s RecoMonitor %s" $self [list $ScanData(Monitor)]]
|
||||
close $fd
|
||||
}
|
||||
#-------------------------- list ------------------------------------------
|
||||
ScanCommand method list { } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
ClientPut [format "%s.Preset = %f" $self $ScanData(Preset)]
|
||||
ClientPut [format "%s.Mode = %s" $self $ScanData(Mode)]
|
||||
ClientPut [format "%s.File = %s" $self $ScanData(File)]
|
||||
ClientPut [format "%s.NP = %d" $self $ScanData(NP)]
|
||||
ClientPut "ScanVariables:"
|
||||
for { set i 0 } {$i < $ScanData(NoVar) } { incr i } {
|
||||
ClientPut [format " %s %f %f" $ScanVar($i,Var) $ScanVar($i,Start) \
|
||||
$ScanVar($i,Step)]
|
||||
}
|
||||
}
|
||||
#--------------------------------- clear ---------------------------------
|
||||
ScanCommand method clear { } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
instvar Data
|
||||
instvar Active
|
||||
# check for activity
|
||||
if {$Active} {
|
||||
ClientPut "ERROR: cannot clear running scan" error
|
||||
return
|
||||
}
|
||||
|
||||
set ScanData(NP) 0
|
||||
set ScanData(NoVar) 0
|
||||
set ScanData(Counts) " "
|
||||
set ScanData(Monitor) " "
|
||||
Data clear
|
||||
$self SendInterest pinterest ScanVarChange
|
||||
ClientPut OK
|
||||
}
|
||||
#--------------------------- Store Initial data -----------------------------
|
||||
ScanCommand method SaveHeader { } {
|
||||
instvar Data
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
Data clear
|
||||
# administrative header
|
||||
Data add [format "%s TOPSI Data File %s" [MC * 30] \
|
||||
[MC * 30]]
|
||||
Data add [Title]
|
||||
Data add [User]
|
||||
Data add [format "File created: %s" [sicstime]]
|
||||
Data add [MC * 75]
|
||||
Data add [format " %s Setting %s " [MC * 30] [MC * 30]]
|
||||
# settings of instrument variables
|
||||
Data add [format "%s Monochromator %s" [MC - 30] [MC - 30]]
|
||||
Data add [lambda]
|
||||
Data add [MTL position]
|
||||
Data add [MTU position]
|
||||
Data add [MGU position]
|
||||
# diaphragm should go here
|
||||
# sample info
|
||||
Data add [format "%s Sample %s" [MC - 30] [MC - 30]]
|
||||
Data add [STL position]
|
||||
Data add [STU position]
|
||||
Data add [SGL position]
|
||||
Data add [SGU position]
|
||||
Data add [MC * 75]
|
||||
# counter info
|
||||
Data add [format "CountMode = %s" $ScanData(Mode)]
|
||||
Data add [format "Count Preset = %s" $ScanData(Preset)]
|
||||
Data add [MC * 75]
|
||||
Data add [format "%s DATA %s" [MC * 30] [MC * 30]]
|
||||
set val "Variables scanned: "
|
||||
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
|
||||
append val " " $ScanVar($i,Var)
|
||||
}
|
||||
Data add "$val"
|
||||
append t [LeftAlign NP 5]
|
||||
append t [LeftAlign Counts 12]
|
||||
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
|
||||
append t [LeftAlign $ScanVar($i,Var) 10]
|
||||
}
|
||||
Data add $t
|
||||
set ScanData(Ptr) [Data GetN]
|
||||
}
|
||||
#-----------------------------------------------------------------------------
|
||||
ScanCommand method ConfigureDevices { } {
|
||||
instvar ScanData
|
||||
$ScanData(counter) SetMode $ScanData(Mode)
|
||||
$ScanData(counter) SetPreset $ScanData(Preset)
|
||||
}
|
||||
#----------------------------------------------------------------------------
|
||||
ScanCommand method StoreScanPoint { } {
|
||||
instvar ScanData
|
||||
instvar Data
|
||||
instvar ScanVar
|
||||
lappend ScanData(Counts) [GetNum [$ScanData(counter) GetCounts]]
|
||||
lappend ScanData(Monitor) [GetNum [$ScanData(counter) GetMonitor 1]]
|
||||
#------------ get Scan Var Values
|
||||
for { set i 0 } { $i < $ScanData(NoVar) } { incr i } {
|
||||
lappend ScanVar($i,Value) [GetNum [$ScanVar($i,Var) position]]
|
||||
}
|
||||
set iFile $ScanData(Ptr)
|
||||
#------------ write it
|
||||
set length [llength $ScanData(Counts)]
|
||||
for { set i 0 } { $i < $length} { incr i} {
|
||||
set t " "
|
||||
append t [LeftAlign $i 5]
|
||||
append t [LeftAlign [lindex $ScanData(Counts) $i ] 12]
|
||||
for { set ii 0 } { $ii < $ScanData(NoVar) } { incr ii} {
|
||||
append t [LeftAlign [lindex $ScanVar($ii,Value) $i] 10]
|
||||
}
|
||||
Data ins $t $iFile
|
||||
incr iFile
|
||||
}
|
||||
set fd [open $ScanData(File) w]
|
||||
Data put $fd
|
||||
close $fd
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
ScanCommand method GetCounts { } {
|
||||
instvar ScanData
|
||||
#------- get data available
|
||||
set length [llength $ScanData(Counts)]
|
||||
for { set i 0 } { $i < $length } { incr i} {
|
||||
lappend result [lindex $ScanData(Counts) $i]
|
||||
}
|
||||
#------ put zero in those which are not yet measured
|
||||
if { $length < $ScanData(NP) } {
|
||||
for { set i $length } { $i < $ScanData(NP) } { incr i } {
|
||||
lappend result 0
|
||||
}
|
||||
}
|
||||
return "scan.Counts= $result"
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
ScanCommand method EndScan { } {
|
||||
instvar Data
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
Data add [format "%s End of Data %s" [MC * 30] [MC * 30]]
|
||||
set fd [open $ScanData(File) w]
|
||||
Data put $fd
|
||||
close $fd
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
ScanCommand method EvalInt { } {
|
||||
set int [GetInt]
|
||||
ClientPut [format "Interrupt %s detected" $int]
|
||||
switch -exact $int {
|
||||
continue {
|
||||
return OK
|
||||
}
|
||||
abortop {
|
||||
SetInt continue
|
||||
return SKIP
|
||||
}
|
||||
abortscan {
|
||||
SetInt continue
|
||||
return ABORT
|
||||
}
|
||||
default {
|
||||
return ABORT
|
||||
}
|
||||
}
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
ScanCommand method DriveTo { iNP } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
set command "drive "
|
||||
for { set i 0 } { $i < $ScanData(NoVar) } { incr i } {
|
||||
set ScanVar($i,NewVal) [expr $ScanVar($i,Start) + $iNP * \
|
||||
$ScanVar($i,Step)]
|
||||
# append ScanVar($i,Value) " " $ScanVar($i,NewVal)
|
||||
append command " " $ScanVar($i,Var) " " $ScanVar($i,NewVal)
|
||||
}
|
||||
set ret [catch {eval $command } msg ]
|
||||
if { $ret != 0 } {
|
||||
ClientPut $msg error
|
||||
return [$self EvalInt]
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
ScanCommand method CheckScanBounds { } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
for { set i 0} { $i < $ScanData(NP) } { incr i } {
|
||||
for { set ii 0 } { $ii < $ScanData(NoVar) } { incr ii } {
|
||||
set NewVal [expr $ScanVar($ii,Start) + $i*$ScanVar($ii,Step)]
|
||||
set iRet [catch {SICSBounds $ScanVar($ii,Var) $NewVal} msg]
|
||||
if { $iRet != 0 } {
|
||||
ClientPut $msg error
|
||||
return 0
|
||||
}
|
||||
}
|
||||
}
|
||||
return 1
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
ScanCommand method Count { } {
|
||||
instvar ScanData
|
||||
set command $ScanData(counter)
|
||||
append command " Count "
|
||||
append command $ScanData(Preset)
|
||||
set ret [catch {eval $command } msg ]
|
||||
if { $ret != 0 } {
|
||||
ClientPut $msg error
|
||||
return [$self EvalInt]
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
proc LeftAlign { text iField } {
|
||||
set item $text
|
||||
append item [MC " " $iField]
|
||||
return [string range $item 0 $iField]
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
ScanCommand method ScanStatusHeader { } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
append t [LeftAlign NP 5]
|
||||
append t [LeftAlign Counts 12]
|
||||
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
|
||||
append t [LeftAlign $ScanVar($i,Var) 10]
|
||||
}
|
||||
ClientPut $t status
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
ScanCommand method ProgressReport { i } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
$self ScanStatusHeader
|
||||
append t [LeftAlign $i 5]
|
||||
append t [LeftAlign [lindex $ScanData(Counts) $i ] 12]
|
||||
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
|
||||
append t [LeftAlign $ScanVar($i,NewVal) 10]
|
||||
}
|
||||
ClientPut $t status
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
ScanCommand method MakeFile { } {
|
||||
global datapath
|
||||
instvar ScanData
|
||||
SicsDataNumber incr
|
||||
set num1 [SicsDataNumber]
|
||||
set num [GetNum $num1]
|
||||
set fil [ format "%s/topsi%4.4d%2.2d.dat" $datapath $num 97]
|
||||
set ScanData(File) $fil
|
||||
}
|
||||
|
||||
#--------------------------------------------------------------------------
|
||||
ScanCommand method run { } {
|
||||
instvar ScanData
|
||||
instvar Data
|
||||
instvar ScanVar
|
||||
instvar Active
|
||||
# start with error checking
|
||||
if { $ScanData(NP) < 1 } {
|
||||
ClientPut "ERROR: Insufficient Number of ScanPoints"
|
||||
return
|
||||
}
|
||||
if { $ScanData(NoVar) < 1 } {
|
||||
ClientPut "ERROR: No variables to scan given!"
|
||||
return
|
||||
}
|
||||
#------- check for activity
|
||||
if {$Active} {
|
||||
ClientPut "ERROR: Scan already in progress" error
|
||||
return
|
||||
}
|
||||
#------- check Bounds
|
||||
if { [$self CheckScanBounds] != 1 } {
|
||||
return
|
||||
}
|
||||
|
||||
# clean data space from relicts of previous scans
|
||||
Data clear
|
||||
set ScanData(Counts) " "
|
||||
set ScanData(Monitor) " "
|
||||
for {set i 0} { $i < $ScanData(NoVar) } { incr i } {
|
||||
set ScanVar($i,Value) " "
|
||||
}
|
||||
|
||||
# configure and save data header
|
||||
$self ConfigureDevices
|
||||
$self MakeFile
|
||||
$self SaveHeader
|
||||
ClientPut [format "Writing %s" $ScanData(File)]
|
||||
|
||||
|
||||
# the actual scan loop
|
||||
SetStatus Scanning
|
||||
$self SendInterest cinterest NewScan
|
||||
set Active 1
|
||||
for { set i 0 } { $i < $ScanData(NP) } { incr i } {
|
||||
#---- driving
|
||||
set ret [$self DriveTo $i]
|
||||
switch -exact $ret {
|
||||
OK { }
|
||||
SKIP { continue }
|
||||
ABORT { ClientPut "\nERROR: Scan Aborted at drive"
|
||||
SetStatus Eager
|
||||
set Active 0
|
||||
error "Abort"
|
||||
}
|
||||
}
|
||||
#---- counting
|
||||
set ret [$self Count]
|
||||
switch -exact $ret {
|
||||
OK { }
|
||||
SKIP { continue }
|
||||
ABORT { ClientPut "\nERROR: Scan Aborted at counting"
|
||||
SetStatus Eager
|
||||
set Active 0
|
||||
error "Abort"
|
||||
}
|
||||
}
|
||||
#--- save data
|
||||
$self StoreScanPoint
|
||||
$self WriteRecover
|
||||
#--- invoke interests
|
||||
$self SendInterest cinterest [$self GetCounts]
|
||||
#--- Status Report
|
||||
$self ProgressReport $i
|
||||
}
|
||||
#---- final processing
|
||||
$self EndScan
|
||||
ClientPut "OK"
|
||||
SetStatus Eager
|
||||
set Active 0
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
ScanCommand method Recover { } {
|
||||
instvar ScanData
|
||||
instvar Data
|
||||
instvar ScanVar
|
||||
instvar Active
|
||||
instvar Recover
|
||||
global recoverfil
|
||||
|
||||
# ---- read Recover Information
|
||||
set Recover 1
|
||||
$self clear
|
||||
source $recoverfil
|
||||
|
||||
# configure and save data header
|
||||
$self ConfigureDevices
|
||||
$self SaveHeader
|
||||
|
||||
# Write scan start info
|
||||
$self ScanStatusHeader
|
||||
|
||||
# --- figure out where we are
|
||||
set Recover 0
|
||||
set pos [llength $ScanData(Counts)]
|
||||
|
||||
# ----------------------the actual scan loop
|
||||
set OldStat [status]
|
||||
SetStatus Scanning
|
||||
set Active 1
|
||||
for { set i $pos } { $i < $ScanData(NP) } { incr i } {
|
||||
#---- driving
|
||||
set ret [$self DriveTo $i]
|
||||
switch -exact $ret {
|
||||
OK { }
|
||||
SKIP { continue }
|
||||
ABORT { ClientPut "\nERROR: Scan Aborted"
|
||||
SetStatus $OldStat
|
||||
set Active 0
|
||||
return
|
||||
}
|
||||
}
|
||||
#---- counting
|
||||
set ret [$self Count]
|
||||
switch -exact $ret {
|
||||
OK { }
|
||||
SKIP { continue }
|
||||
ABORT { ClientPut "\nERROR: Scan Aborted"
|
||||
SetStatus $OldStat
|
||||
set Active 0
|
||||
return
|
||||
}
|
||||
}
|
||||
#--- save data
|
||||
$self StoreScanPoint
|
||||
$self WriteRecover
|
||||
#--- Status Report
|
||||
$self ProgressReport $i
|
||||
}
|
||||
#---- final processing
|
||||
$self EndScan
|
||||
ClientPut "OK"
|
||||
SetStatus $OldStat
|
||||
set Active 0
|
||||
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
# finally initialise the scan command
|
||||
ScanCommand new scan counter
|
||||
#---------------------------------------------------------------------------
|
||||
# a new user command which allows status clients to read the counts in a scan
|
||||
# This is just to circumvent the user protection on scan
|
||||
proc ScanCounts { } {
|
||||
set status [ catch {scan GetCounts} result]
|
||||
if { $status == 0 } {
|
||||
return $result
|
||||
} else {
|
||||
return "scan.Counts= 0"
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
# This is just another utilility function which helps in implementing the
|
||||
# status display client
|
||||
proc TextStatus { } {
|
||||
set text [status]
|
||||
return [format "Status = %s" $text]
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
# Dumps time in a useful format
|
||||
proc sftime {} {
|
||||
return [format "sicstime = %s" [sicstime]]
|
||||
}
|
||||
@ -1,43 +0,0 @@
|
||||
#------------------------------------------------------------------------
|
||||
# This implements the wwwsics command which generates a listing of
|
||||
# important experiment parameters in html format for the SICS WWW Status
|
||||
# application. This version is for the powder diffractometers DMC and
|
||||
# HRPT.
|
||||
#
|
||||
# Mark Koennecke, March 2000
|
||||
#------------------------------------------------------------------------
|
||||
proc wwwsics {} {
|
||||
#----- get all the data we need
|
||||
set user [GetNum [user]]
|
||||
set sample [GetNum [sample]]
|
||||
set tit [GetNum [title]]
|
||||
set ret [catch {lambda} msg]
|
||||
if {$ret != 0 } {
|
||||
set lam Undetermined
|
||||
} else {
|
||||
set lam [GetNum $msg]
|
||||
}
|
||||
set ret [catch {temperature} msg]
|
||||
if {$ret != 0 } {
|
||||
set tem Undetermined
|
||||
} else {
|
||||
set tem [GetNum $msg]
|
||||
}
|
||||
set run [GetNum [sicsdatanumber]]
|
||||
catch {incr run} msg
|
||||
set stat [GetNum [status]]
|
||||
#------- html format the reply
|
||||
append result "<table BORDER=2>"
|
||||
append result <tr> <th>Run Number</th> <td> $run </td> </tr>
|
||||
append result <tr> <th>Title</th> <td> $tit </td> </tr>
|
||||
append result <tr> <th>User</th> <td> $user </td> </tr>
|
||||
append result <tr> <th>Sample </th> <td> $sample </td> </tr>
|
||||
append result <tr> <th>wavelength</th> <td> $lam</td> </tr>
|
||||
append result <tr> <th>Sample Temperature</th> <td> $tem</td> </tr>
|
||||
append result <tr> <th>Status</th> <td> $stat</td> </tr>
|
||||
append result </table>
|
||||
return $result
|
||||
}
|
||||
|
||||
#------------ install command
|
||||
catch {Publish wwwsics Spy} msg
|
||||
Reference in New Issue
Block a user