linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Cleanup of the repository before pushing to gitorious

Browse Source 
Refs #201
This commit is contained in:
koennecke
2014-02-18 16:41:37 +01:00
parent 33e122ea9e
commit 810a3cbd94
112 changed files with 0 additions and 20155 deletions
Download Patch File Download Diff File Expand all files Collapse all files

23
amorpar.tcl
View File

@ -1,23 +0,0 @@
#--------------------------------------------------------------------------
# A SICS-tcl-macro script for formatting the parameters for the
# reflectometer AMOR's status display.
#
# Mark Koennecke, October 1999
#-------------------------------------------------------------------------
proc amorpar {} {
lappend list "amorpar == "
lappend list [lastscancommand] ";"
catch {scan getvars} msg
lappend list $msg ";"
lappend list [xxxscan getfile] ";"
lappend list [sicstime] ";"
set ret [catch {temperature} msg]
if {$ret == 0} {
lappend list $msg
}
set ret [catch {magnet} msg]
if {$ret == 0} {
lappend list $msg
}
return [join $list]
}

358
amortest.tcl
View File

@ -1,358 +0,0 @@
# --------------------------------------------------------------------------
# Initialization script for a simulated AMOR instrument
#
#
# Dr. Mark Koennecke September,1999 - ??, ????
#---------------------------------------------------------------------------
#------------ our home
set home /data/koenneck/src/sics
#----------- first all the server options are set
ServerOption ReadTimeOut 100
# timeout when checking for commands. In the main loop SICS checks for
# pending commands on each connection with the above timeout, has
# PERFORMANCE impact!
ServerOption AcceptTimeOut 100
# timeout when checking for connection req.
# Similar to above, but for connections
ServerOption ReadUserPasswdTimeout 7000
# time to wiat for a user/passwd to be sent from a client. Increase this
# if there is a problem connecting to a server due to network overload\
ServerOption LogFileDir $home/tmp
#LogFileDir is the directory where the command log is going
ServerOption LogFileBaseName $home/tmp/server
# the path and base name of the internal server logfile to which all
# activity will be logged.
ServerOption statusfile $home/tmp/sicsstatus.tcl
ServerOption ServerPort 2911
# the port number the server is going to listen at. The client MUST know
# this number in order to connect. It is in client.ini
ServerOption InterruptPort 2914
# The UDP port where the server will wait for Interrupts from clients.
# Obviously, clients wishing to interrupt need to know this number.
# Telnet options
ServerOption TelnetPort 1301
ServerOption TelWord sicslogin
ServerOption DefaultTclDirectory $home/tcl
ServerOption DefaultCommandFile topsicom.tcl
#------ a port for broadcasting UDP messages
ServerOption QuieckPort 2108
#---------------------------------------------------------------------------
# U S E R S
# than the SICS users are specified
# Syntax: SicsUser name password userRightsCode
SicsUser Mugger Diethelm 1
SicsUser User Rosy 2
SicsUser Spy 007 1
#--------------------------------------------------------------------------
# G E N E R A L V A R I A B L E S
# now a few general variables are created
# Syntax: VarMake name type access
# type can be one of: Text, Int, Float
#access can be one of: Internal, Mugger, user, Spy
VarMake Instrument Text Internal
Instrument AMOR
Instrument lock
VarMake Title Text User
VarMake sample Text User
sample "DanielSulfid"
Title "Amore mio in SINQ"
VarMake User Text User
User The reflective looser
VarMake lastscancommand Text User
VarMake Adress Text User
VarMake phone Text User
VarMake fax Text User
VarMake email Text User
VarMake sample_mur Float User
#--------------------------------------------------------------------------
# B u i l d i n g B l o c k s
#--------------------------------------------------------------------------
#
#=================== Chopper
VarMake chopperrotation Float User
chopperrotation 10000.
ClientPut "Starting motor initialization ....."
#=================== frame overlap mirror
VarMake fomname Text Mugger
fomname Super Duper Mirror
fomname lock
VarMake fomdist Float Mugger
fomdist 120
Motor FTZ SIM 0. 120. .1 2. # fom height
Motor FOM SIM -30. 30. .1 2. # fom omega
#================== first diaphragm
VarMake d1dist Float Mugger
d1dist 200.
Motor D1L SIM 0. 120. .1 2. # left
Motor D1R SIM 0. 120. .1 2. # right
Motor D1T SIM 0. 120. .1 2. # top
Motor D1B SIM 0. 1000. .1 2. # bottom
#================== polarizer
VarMake polname Text Mugger
polname Daniels Special Edition Polarizer
polname lock
VarMake poldist Float Mugger
fomdist 200
Motor MOZ SIM 0. 1000. .1 2. # pol table height
Motor MTY SIM -60. 60. .1 2. # pol y movement
Motor MOM SIM -30. 30. .1 2. # pol omega
Motor MTZ SIM -30. 30. .1 2. # pol omega height
#=================== diaphragm 2
VarMake d2dist Float Mugger
d2dist 200.
Motor D2L SIM 0. 120. .1 2. # left
Motor D2R SIM 0. 120. .1 2. # right
Motor D2T SIM 0. 120. .1 2. # top
Motor D2B SIM 0. 1000. .1 2. # bottom
#==================== diaphragm 3
VarMake d3dist Float Mugger
d3dist 200.
Motor D3L SIM 0. 120. .1 2. # left
Motor D3R SIM 0. 120. .1 2. # right
Motor D3T SIM 0. 120. .1 2. # top
Motor D3B SIM 0. 1000. .1 2. # bottom
#===================== sample table
VarMake sampledist Float Mugger
sampledist 200
Motor STZ SIM -50. 50. .1 2. # sample height
Motor SOM SIM -30. 30. .1 2. # sample omega
Motor SCH SIM -30. 30. .1 2. # sample chi
Motor SOZ SIM 0. 1000. .1 2. # table height
#====================== diaphragm 4
VarMake d4dist Float Mugger
d4dist 200.
Motor D4L SIM 0. 120. .1 2. # left
Motor D4R SIM 0. 120. .1 2. # right
Motor D4T SIM 0. 120. .1 2. # top
Motor D4B SIM 0. 1000. .1 2. # bottom
#======================= analyzer
VarMake ananame Text Mugger
ananame Daniels Special Edition Analyzer
ananame lock
VarMake anadist Float Mugger
anadist 200
Motor AOZ SIM 0. 1000. .1 2. # analyzer table height
Motor AOM SIM -30. 30. .1 2. # analyzer omega
Motor ATZ SIM -30. 30. .1 2. # analyzer omega height
#======================== diaphragm 5
VarMake d5dist Float Mugger
d5dist 200.
Motor D5L SIM 0. 120. .1 2. # left
Motor D5R SIM 0. 120. .1 2. # right
Motor D5T SIM 0. 120. .1 2. # top
Motor D5B SIM 0. 1000. .1 2. # bottom
#======================== counter
VarMake detectordist Float Mugger
detectordist 200.
MakeCounter counter SIM .0001
Motor COZ SIM 0. 1000. .1 2. # counter table height
Motor C3Z SIM 0. 300. .1 2. # counter height
Motor COM SIM -30. 30. .1 2. # counter omega
Motor COX SIM -100. 100. .1 2. # counter x
ClientPut "Motors initialized"
#======================== histogram memory
#MakeHM hm SinqHM
MakeHM hm SIM
hm configure OverFlowMode Ceil
hm configure HistMode PSD
hm configure Rank 2
hm configure dim0 128
hm configure dim1 256
hm configure xfac 10
hm configure yfac 10
hm configure xoff 64
hm configure yoff 128
hm configure BinWidth 4
hm preset 100.
hm CountMode Timer
hm configure HMComputer psds03.psi.ch
hm configure HMPort 2400
hm configure Counter counter
hm configure init 0
hm genbin 0. 33 5
hm init
ClientPut "Histogram Memory Initialized"
#--------------------------------------------------------------------------
# D a t a S t o r a g e
#------------------------------------------------------------------------
VarMake SicsDataPath Text Mugger
SicsDataPath $home/
SicsDataPath lock
VarMake SicsDataPrefix Text Mugger
SicsDataPrefix amortest
SicsDataPrefix lock
VarMake SicsDataPostFix Text Mugger
SicsDataPostFix ".hdf"
SicsDataPostFix lock
MakeDataNumber SicsDataNumber $home/danu.dat
#--------------------------------------------------------------------------
# C o m m a n d I n i t i a l i z a t i o n
#-------------------------------------------------------------------------
#======== Drive
MakeDrive
#======== scan
source $home/object.tcl
source $home/tcl/scancom.tcl
MakeScanCommand xxxscan counter topsi.hdd recover.bin
xxxscan configure amor
#========== peak & center
MakePeakCenter xxxscan
source /data/koenneck/src/sics/countf.tcl
#========== serial port general purpose
SerialInit
Publish serialport User
Publish p1 User
#=========== the optimiser
MakeOptimise opti counter
#=========== Amor2T
set a2t(mom) mom
set a2t(som) som
set a2t(coz) coz
set a2t(cox) cox
set a2t(stz) stz
set a2t(soz) soz
set a2t(d4b) d4b
set a2t(d5b) d5b
set a2t(com) com
set a2t(aom) aom
set a2t(aoz) aoz
set a2t(c3z) c3z
MakeAmor2T a2t a2t aom2t
MakeStoreAmor hm a2t
#=========== Status Display Support
MakeAmorStatus amorstatus xxxscan hm
source amorpar.tcl
Publish amorpar Spy
ClientPut "Done Initializing"
scriptcallback connect xxxscan SCANSTART scanmode
scriptcallback connect hm COUNTSTART tofmode
sicsdatafactory new wwwdata
Publish getmode Spy
Publish wwwgetdata Spy
Publish wwwsics Spy
Publish wwwgetaxis Spy
#-----------------------------------------------------------------
set mode 0
proc tofmode {} {
global mode
set mode 1
}
#---------------------------------------------------------------------
proc scanmode {} {
global mode
set mode 0
}
#------------------------------------------------------------------
proc getmode {} {
global mode
return $mode
}
#--------------------------------------------------------------------
proc wwwgetdata {} {
global mode
if {$mode == 1} {
wwwtofdata
} else {
wwwscandata
}
wwwdata writeuu wwwdata
}
#---------------------------------------------------------------------
proc wwwscandata {} {
wwwdata clear
set np [string trim [SplitReply [xxxscan np]]]
wwwdata putint 0 $np
if {$np > 0} {
wwwdata copyscanvar 1 xxxscan 0
wwwdata copyscancounts [expr $np + 1] xxxscan
wwwdata copyscanmon [expr $np*2 + 1] xxxscan 2
}
}
#----------------------------------------------------------------------
proc wwwtofdata {} {
wwwdata clear
set ntime [string trim [SplitReply [hm notimebin]]]
set dim0 [string trim [SplitReply [hm configure dim0]]]
set dim1 [string trim [SplitReply [hm configure dim1]]]
wwwdata putint 0 $ntime
wwwdata copytimebin 1 hm
set start [expr $dim0*$dim1*$ntime]
set end [expr $start + 2*$ntime]
wwwdata copyhm [expr $ntime + 1] hm $start $end
}
#---------------------------------------------------------------------------
proc wwwsics {} {
global mode
append result "<table BORDER=2>\n"
append result "<tr><th>User</th> <td>" [SplitReply [user]] "</td></tr>\n"
append result "<tr><th>Title</th> <td>"
append result [SplitReply [title]] "</td></tr>\n"
append result "<tr><th>Status</th> <td>"
append result [SplitReply [status]] "</td></tr>\n"
append result "<tr><th>Mode</th><td>"
if {$mode == 1} {
append result "time-of-flight"
} else {
append result "scan mode"
}
append result "</td></tr>\n"
append result "</table>\n"
}
#-------------------------------------------------------------------------
proc wwwgetaxis {} {
global mode
if {$mode == 1} {
return time-of-flight
} else {
set res [scan info]
set l [split $res ,]
return [lindex $l 2]
}
}

7
ati.tcl
View File

@ -1,7 +0,0 @@
drive mom 3.
scan var a2t 0. .2
scan var som 0. .1
scan preset 1
scan mode timer
scan np 20
scan run

211
autofile.tcl
View File

@ -1,211 +0,0 @@
#----------------------------------------------------------------------------
# This is part of the WWW-interface to SICS. This interface allows to
# create batch files to be run automatically by SICS. These files are
# stored in a special directory as files with the ending .sip by the
# CGI-scripts or servlets creating them. Now, a system is needed which
# checks this directory regularly for new files and executes them in SICS.
# This is the purpose of the SICS-Tcl macros defined in this file.
#
# First edition: Mark Koennecke, December 1999
#----------------------------------------------------------------------------
#----------- !!!! the path where the automatic files reside
set autofpath "/data/koenneck/tmp/auto"
#------- a variable which defines if we should operate and the current file.
set __autofile_run 0
set __auto_exe_file ""
#!!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# There is a name command between the Tcl internal scan command and the
# SICS scan command. The Tcl internal has to be renamed. The following
# variable defines the name of the Tcl scan command
set tclscan stscan
#---------- do initializing things when called first time
set ret [catch [catch {autofile} msg]
if {$ret != 0} {
VarMake autofilepath Text Mugger
autofilepath $autofpath
autofilepath lock
Publish autofileexecute User
Publish autofile Mugger
Publish autostart User
Publish autoadd User
Publish autoend User
#------- for automatic file name creation
catch {MakeDataNumber autonumber $autofpath/autonumber.dat}
#------- check any 30 seconds
sicscron 30 autofileexecute
}
#--------------------------------------------------------------------------
proc autofile { {action null} } {
upvar #0 __autofile_run ar
if { [string compare $action start] == 0} {
set ar 1
return OK
} elseif { [string compare $action stop] == 0 } {
set ar 0
return OK
} else {
if {$ar == 1} {
return on
} else {
return off
}
}
}
#--------------------------------------------------------------------------
proc autofileexecute { } {
upvar #0 __autofile_run ar
upvar #0 __auto_exe_file aef
upvar #0 tclscan filescan
#--------- no operation if not activated
if {$ar != 1} {
return
}
#--------- aquire a list of candidate batch files
set tmp [autofilepath]
set ltmp [split $tmp =]
set tmp [lindex $ltmp 1]
set tmp2 [string trim $tmp]/*.inp
set ret [catch {set filelist [glob $tmp2]} msg]
if {$ret != 0} {
return "Nothing to do"
}
if { [llength $filelist] < 1 } {
return "Nothing to do"
}
#--------- now, in each file the second line contains the order number,
# find the lowest one which is the next one to execute
set minnum 999999
set file2exe null
foreach fil $filelist {
set f [open $fil r]
gets $f
set numline [gets $f]
set ret [catch {$filescan $numline "# %d" numi} msg]
close $f
if { $ret == 0 } {
if { $numi < $minnum } {
set minnum $numi
set file2exe $fil
}
} else {
ClientPut $msg
}
}
#------------ having found an input file, execute it
if { [string compare $file2exe null] != 0 } {
set aef $file2exe
set ret [catch {interneval $file2exe} msg]
#------ after execution rename it with a different extension
set fil2 [file rootname $file2exe].old
file rename -force $file2exe $fil2
if {$ret != 0 } {
error $msg
} else {
return $msg
}
}
return "Invalid autobatch files"
}
#=========================================================================
# File management functions
#
# autostart creates a fresh file. The data is stored in a SICS runbuffer.
# autoadd adds a line to the runbuffer
# autoend writes the file to disk then.
#=========================================================================
proc autostart {} {
catch {buf del autobuffer}
Buf new autobuffer
}
proc autoadd args {
autobuffer append $args
}
proc autoend {} {
upvar #0 autofpath ap
autonumber incr
set txt [autonumber]
set l [split $txt =]
set txt [string trim [lindex $l 1]]
set fil [format "$ap/auto%7.7d.inp" $txt]
set filnum [format "# %d" $txt]
autobuffer ins 1 $filnum
autobuffer save $fil
Buf del autobuffer
}
#============================================================================
# file list management
#============================================================================
proc buildsortedlist {filar} {
upvar #0 autofpath ap
upvar $filar list
set i 0
#----------- build arrays of all relevant files
set ret [catch {set l1 [glob $ap/*.inp]}]
if { $ret == 0 } {
foreach fil $l1 {
set list($i)
incr i
set f [open $fil r]
set $fil(title) [gets $f]
set txt [gets $f]
close $f
set ret [catch {$filescan $txt "# %d" numi} msg]
if { $ret == 0} {
set fil(no) $numi
}else {
set fil(no) -10
}
}
}
set ret [catch {set l1 [glob $ap/*.old]}]
if { $ret == 0 } {
foreach fil $l1 {
set list($i)
incr i
set f [open $fil r]
set $fil(title) [gets $f]
set txt [gets $f]
close $f
set ret [catch {$filescan $txt "# %d" numi} msg]
if { $ret == 0} {
set fil(no) $numi
}else {
set fil(no) -10
}
}
}
set nfil i
#--------- now selection sort this list
for {set i 0} { i < $nfil} {incr i} {
set min $i
set ff $list($min)
for {set j [expr $i + 1]} {$j < $nfil} {incr j} {
set ff $list($j)
set fff $list($min)
if { $ff(no) < $fff(no)} {
set min $j
}
}
set t $list($min)
set list($min) $list($min)
set list($i) $t
}
}
proc autolist {} {
}

137
backup.tcl
View File

@ -1,137 +0,0 @@
# RuenBuffer Renate
Buf new Renate
Renate append Alle Fische sind schon da
Renate append Alle Nixen auch
Renate append Nur die dummen Neutronen kommen nicht
Renate append Und die Schluempfe kriegen es auch nicht gebacken
# RuenBuffer Kunigunde
Buf new Kunigunde
Kunigunde append Alle Fische sind schon da
Kunigunde append Alle Nixen auch
Kunigunde append Nur die dummen Neutronen kommen nicht
Kunigunde append Und die Schluempfe kriegen es auch nicht gebacken
# RuenBuffer Walter
Buf new Walter
Walter append Alle Fische sind schon da
Walter append Alle Nixen auch
Walter append Nur die dummen Neutronen kommen nicht
Walter append Und die Schluempfe kriegen es auch nicht gebacken
# RuenBuffer Willi
Buf new Willi
Willi append Alle Nixen auch
Willi append Und die Schluempfe kriegen es auch nicht gebacken
# RuenBuffer Heinz
Buf new Heinz
Heinz append GGG Fische sind schon da
Heinz append GGG Nixen auch
Heinz append Nur die dummen Neutronen kommen schon
Heinz append Und die Schluempfe kriegen es auch schon gebacken
Curve SoftLowerLim 0.000000
Curve SoftUpperLim 1000.000000
Curve SoftZero 0.000000
Curve Fixed -1.000000
Curve InterruptMode 0.000000
Curve AccessCode 2.000000
TwoTheta SoftLowerLim -140.000000
TwoTheta SoftUpperLim 140.000000
TwoTheta SoftZero 0.000000
TwoTheta Fixed -1.000000
TwoTheta InterruptMode 0.000000
TwoTheta AccessCode 2.000000
Theta SoftLowerLim -70.000000
Theta SoftUpperLim 70.000000
Theta SoftZero 0.000000
Theta Fixed -1.000000
Theta InterruptMode 0.000000
Theta AccessCode 2.000000
bsy SoftLowerLim -50.000000
bsy SoftUpperLim 50.000000
bsy SoftZero 0.000000
bsy Fixed -1.000000
bsy InterruptMode 0.000000
bsy AccessCode 2.000000
bsx SoftLowerLim -50.000000
bsx SoftUpperLim 50.000000
bsx SoftZero 0.000000
bsx Fixed -1.000000
bsx InterruptMode 0.000000
bsx AccessCode 2.000000
dphi SoftLowerLim 0.000000
dphi SoftUpperLim 360.000000
dphi SoftZero 0.000000
dphi Fixed -1.000000
dphi InterruptMode 0.000000
dphi AccessCode 2.000000
dsy SoftLowerLim -50.000000
dsy SoftUpperLim 50.000000
dsy SoftZero 0.000000
dsy Fixed -1.000000
dsy InterruptMode 0.000000
dsy AccessCode 2.000000
dsd SoftLowerLim 0.000000
dsd SoftUpperLim 18000.000000
dsd SoftZero 0.000000
dsd Fixed -1.000000
dsd InterruptMode 0.000000
dsd AccessCode 2.000000
saz SoftLowerLim 0.000000
saz SoftUpperLim 30.000000
saz SoftZero 0.000000
saz Fixed -1.000000
saz InterruptMode 0.000000
saz AccessCode 2.000000
say SoftLowerLim -22.000000
say SoftUpperLim 22.000000
say SoftZero 0.000000
say Fixed -1.000000
say InterruptMode 0.000000
say AccessCode 2.000000
sax SoftLowerLim -30.000000
sax SoftUpperLim 30.000000
sax SoftZero 0.000000
sax Fixed -1.000000
sax InterruptMode 0.000000
sax AccessCode 2.000000
som SoftLowerLim -180.000000
som SoftUpperLim 360.000000
som SoftZero 0.000000
som Fixed -1.000000
som InterruptMode 0.000000
som AccessCode 2.000000
sphi SoftLowerLim -22.000000
sphi SoftUpperLim 22.000000
sphi SoftZero 0.000000
sphi Fixed -1.000000
sphi InterruptMode 0.000000
sphi AccessCode 2.000000
schi SoftLowerLim -22.000000
schi SoftUpperLim 22.000000
schi SoftZero 0.000000
schi Fixed -1.000000
schi InterruptMode 0.000000
schi AccessCode 2.000000
comment (null)
comment setAccess 2
environment (null)
environment setAccess 2
SubTitle (null)
SubTitle setAccess 2
User set
User setAccess 2
Title Alle meine Entchen sind schon da
Title setAccess 2
Instrument set
Instrument setAccess 0

20
beam.tcl
View File

@ -1,20 +0,0 @@
#------------------------------------------------------------------------
# install a SPS-Controller
MakeSPS sps1 lnsp25.psi.ch 4000 7
#----------------- the beam command
proc beam {} {
#---------- read the SPS
set ret [catch {SPS1 adc 3} msg]
if {$ret != 0} {
ClientPut $msg
ClientPut "ERROR: SPS reading failed"
return
}
#--------- convert the data
set l [split $msg "="]
set raw [lindex $l 1]
set val [expr $raw/13.96]
return [format "beam = %f" $val]
}
Publish beam Spy

20
beamdt.tcl
View File

@ -1,20 +0,0 @@
#------------------------------------------------------------------------
# install a SPS-Controller
MakeSPS sps1 lnsp23.psi.ch 4000 6
#----------------- the beam command
proc beam {} {
#---------- read the SPS
set ret [catch {SPS1 adc 7} msg]
if {$ret != 0} {
ClientPut $msg
ClientPut "ERROR: SPS reading failed"
return
}
#--------- convert the data
set l [split $msg "="]
set raw [lindex $l 1]
set val [expr $raw/13.96]
return [format "beam = %f" $val]
}
Publish beam Spy

229
coll.tcl
View File

@ -1,229 +0,0 @@
#----------------------------------------------------------------------------
# This file implements the collimator commands for SANS. It requires an
# SPS named sps2 within SICS.
#
# Mark Koennecke, March 1999
#----------------------------------------------------------------------------
proc coll args {
#-------- set case
if { [llength $args] > 0 ] } {
set length [lindex $args 0]
switch $length {
18 {
set command "sps2 push 200 0"
break
}
15 {
set command "sps2 push 200 1"
break
}
11 {
set command "sps2 push 200 2"
break
}
8 {
set command "sps2 push 200 3"
break
}
6 {
set command "sps2 push 200 4"
break
}
4.5 {
set command "sps2 push 200 5"
break
}
3 {
set command "sps2 push 200 6"
break
}
2 {
set command "sps2 push 200 7"
break
}
1.4 {
set command "sps2 push 201 0"
break
}
1 {
set command "sps2 push 201 1"
break
}
default {
append text \
[format "ERROR: collimation length %s invalid\n" $length]
append text "Possible length are: 18,15,11,8,6,4.5,3,2,1.4,1\n"
append text \
"Extraneous . or other characters will yield this error too\n"
append text "SPS programming courtesy Enzo Manfrin\n"
return $text
}
#------- command has been built, execute it!
set ret [catch {$command} msg]
if {$ret != 0} {
error $msg
}
setstatus Driving
#------- wait till finish, check for interrupts on the way
set exe 1
while {$exe} {
set ret [catch {sps2 colli} msg]
if {$ret != 0 } {
setstatus Eager
error $msg
}
set l [split $msg =]
set cval [lindex $l 1]
if { [expr $cval - $length] < 0.2 } {
set exe 0
}
set rupt [getint]
if {[string compare $rupt continue] != 0 } {
setstatus Eager
error "ERROR: driving collimator interrupted"
}
}
setstatus Eager
return OK
} else {
#-------- get case
set ret [catch {sps2 colli} msg]
if {$ret != 0} {
error $msg
}
return $msg
}
}
#--------------------------------------------------------------------------
# Another procedure for handling the attenuator.
#
# Mark Koennecke, March 1999
#--------------------------------------------------------------------------
proc findatt { } {
#----------- find the current attenuator
set ret [catch {sps2 stat2 9 5} msg]
if { $ret != 0 } {
error $msg
}
set l [split $msg =]
if { [lindex $l 1] == 1} {
return 0
}
set ret [catch {sps2 stat2 9 6} msg]
if { $ret != 0 } {
error $msg
}
set l [split $msg =]
if { [lindex $l 1] == 1} {
return 1
}
set ret [catch {sps2 stat2 9 7} msg]
if { $ret != 0 } {
error $msg
}
set l [split $msg =]
if { [lindex $l 1] == 1} {
return 2
}
set ret [catch {sps2 stat2 10 0} msg]
if { $ret != 0 } {
error $msg
}
set l [split $msg =]
if { [lindex $l 1] == 1} {
return 3
}
set ret [catch {sps2 stat2 10 1} msg]
if { $ret != 0 } {
error $msg
}
set l [split $msg =]
if { [lindex $l 1] == 1} {
return 4
}
set ret [catch {sps2 stat2 10 2} msg]
if { $ret != 0 } {
error $msg
}
set l [split $msg =]
if { [lindex $l 1] == 1} {
return 5
}
}
#--------------------------------------------------------------------------
proc att args {
if [ llength $args] > 0} {
#------- set case
set aat [lindex $args 0]
switch $aat {
0 {
set command "sps2 push 210 7"
break
}
1 {
set command "sps2 push 220 0"
break
}
2 {
set command "sps2 push 220 1"
break
}
3 {
set command "sps2 push 230 0"
break
}
4 {
set command "sps2 push 230 1"
break
}
5 {
set command "sps2 push 230 2"
break
}
default {
error [format "ERROR: attenuator %s unknown" $aat]
}
}
#-----send command
set ret [catch {$command} msg]
if {$ret != 0} {
error $msg
}
#------ wait till done
setstatus Driving
set exe 1
while {$exe} {
set ret [catch {findatt} msg]
if {$ret != 0 } {
setstatus Eager
error $msg
}
if { [expr $msg - $aat] < 0.2 } {
set exe 0
}
set rupt [getint]
if {[string compare $rupt continue] != 0 } {
setstatus Eager
error "ERROR: driving attenuator interrupted"
}
}
setstatus Eager
return OK
} else {
#----------- get case
set ret [catch {findatt} msg]
if {$ret != 0 } {
error $msg
} else {
return [format "att = %s" $msg]
}
}
}

79
collidertest.tcl
View File

@ -1,79 +0,0 @@
#--------------------------------------------------------------------------
# test and example script for the anticollider
#
# Mark Koennecke, August 2002
#------------------------------------------------------------------------
proc testlimits tg {
upvar $tg targets
if { abs( $targets(om) - $targets(stt)) < 30 } {
error "!!!!! two theta - omega CRASH!!!!!!!"
}
if {$targets(chi) > 190.} {
error "chi upperlimit crashed"
}
if { $targets(om) > -90 && $targets(om) <= -81.5 && $targets(chi) < 152} {
error "!!!!!! chi - omega CRASH aborted !!!!!"
}
if { $targets(om) > -81.5 && $targets(om) <= -55 && $targets(chi) < 137} {
error "!!!!!! chi - omega CRASH aborted !!!!!"
}
if { $targets(om) > -55 && $targets(om) <= -52 && $targets(chi) < 132} {
error "!!!!!! chi - omega CRASH aborted !!!!!"
}
if { $targets(om) > -52 && $targets(om) <= -30 && $targets(chi) < 75} {
error "!!!!!! chi - omega CRASH aborted !!!!!"
}
return
}
#-------------------------------------------------------------------------
proc chiFirst? tg {
upvar $tg targets
set om [SplitReply [om]]
set chi [SplitReply [chi]]
if {$chi < $targets(chi) } {
return 1
} else {
return 0
}
}
#---------------------------------------------------------------------------
proc collidertest args {
#----------- read command line targets
set entries [expr [llength $args] / 2]
for {set i 0} {$i < $entries} {incr i} {
set ind [expr $i * 2]
set targets([lindex $args $ind]) [lindex $args [expr $ind +1]]
}
#--------- check if all motors are there. If not get targets from
# current position
if { [info exists targets(om)] == 0} {
set targets(om) [SplitReply [om]]
}
if { [info exists targets(stt)] == 0} {
set targets(stt) [SplitReply [stt]]
}
if { [info exists targets(chi)] == 0} {
set targets(chi) [SplitReply [chi]]
}
if { [info exists targets(phi)] == 0} {
set targets(phi) [SplitReply [phi]]
}
#---------- proceed to real collision detection hydraulics
# first: test complex limits
set ret [catch {testlimits targets} msg]
if {$ret != 0} {
clientput [format "ERROR %s" $msg]
error $msg
}
anticollision add 1 stt $targets(stt)
if { [chiFirst? targets] == 1} {
anticollision add 2 chi $targets(chi)
anticollision add 3 om $targets(om)
} else {
anticollision add 2 om $targets(om)
anticollision add 3 chi $targets(chi)
}
anticollision add 3 phi $targets(phi)
}

37
cotop.tcl
View File

@ -1,37 +0,0 @@
#--------------------------------------------------------------------------
# A MAD lookalike co command for TOPSI
# All arguments are optional. The current values will be used if not
# specified
# Dr. Mark Koennecke, November 1999
#--------------------------------------------------------------------------
proc SplitReply { text } {
set l [split $text =]
return [lindex $l 1]
}
#--------------------------------------------------------------------------
proc co { {mode NULL } { preset NULL } } {
starttime [sicstime]
#----- 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 } {
counter setMode Timer
} elseif { [string compare $mc M] == 0 } {
counter setMode Monitor
}
#------ deal with preset
if { [string compare $preset NULL] != 0 } {
set pre $preset
} else {
set pre [SplitReply [counter getpreset]]
}
#------ count
set ret [catch {counter count $pre} msg]
if { $ret != 0 } {
error [format "Counting ended with error: %s" $msg]
} else {
set cts [SplitReply [counter getcounts]]
}
return $cts
}

50
countf.tcl
View File

@ -1,50 +0,0 @@
#--------------------------------------------------------------------------
# A count command for FOCUS
# 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]
#----- 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 } {
hm CountMode Timer
} elseif { [string compare $mc M] == 0 } {
hm CountMode Monitor
}
#------ deal with preset
if { [string compare $preset NULL] != 0 } {
hm preset $preset
}
#------ prepare a count message
set a [hm preset]
set aa [SplitReply $a]
set b [hm CountMode]
set bb [SplitReply $b]
ClientPut [format " Starting counting in %s mode with a preset of %s" \
$bb $aa]
#------- count
# hm InitVal 0
wait 1
set ret [catch {hm countblock} msg]
#------- StoreData
storefocus update
# wait 5
if { $ret != 0 } {
error [format "Counting ended with error: %s" $msg]
}
}
#---------------- Repeat -----------------------------------------------
proc repeat { num {mode NULL} {preset NULL} } {
for { set i 0 } { $i < $num } { incr i } {
count $mode $preset
}
}

187
dmc.tcl
View File

@ -1,187 +0,0 @@
# --------------------------------------------------------------------------
# Initialization script for DMC at SINQ, SICS server.
#
# Dr. Mark Koennecke Juli 1997
#---------------------------------------------------------------------------
# O P T I O N S
set auto_path "/home/DMC/bin"
# first all the server options are set
ServerOption ReadTimeOut 100
# timeout when checking for commands. In the main loop SICS checks for
# pending commands on each connection with the above timeout, has
# PERFORMANCE impact!
ServerOption AcceptTimeOut 100
# timeout when checking for connection req.
# Similar to above, but for connections
ServerOption ReadUserPasswdTimeout 500000
# time to wiat for a user/passwd to be sent from a client. Increase this
# if there is a problem connecting to a server due to network overload\
ServerOption LogFileBaseName "/home/DMC/log/dmclog"
# the path and base name of the internal server logfile to which all
# activity will be logged.
ServerOption ServerPort 3006
# the port number the server is going to listen at. The client MUST know
# this number in order to connect. It is in client.ini
ServerOption StatusFile /home/DMC/log/status.tcl
ServerOption InterruptPort 3007
# The UDP port where the server will wait for Interrupts from clients.
# Obviously, clients wishing to interrupt need to know this number.
# Telnet Options
ServerOption TelnetPort 1301
ServerOption TelWord sicslogin
#The UDP port for sending quieck messages, telling the world of new data
ServerOption QuieckPort 2108
#the token system + the token force grab password
TokenInit connan
#---------------------------------------------------------------------------
# U S E R S
# than the SICS users are specified
# Syntax: SicsUser name password userRightsCode
SicsUser Manager Lucas 1
SicsUser lnsmanager lnsSICSlns 1
SicsUser User DMC 2
SicsUser lnsuser 98lns2 2
SicsUser Spy 007 3
#--------------------------------------------------------------------------
# D E V I C E S : M O T O R S
#Motor a4 EL734 LNSP22 4000 5 6
# EL734 motor with parameters: hostname PortNumber Channel MotorID
# Motor nam SIM -20. 20. 5. 1.0
# Simulated motor with name nam, lower limit -20, upper limit +20,
# error ratio 5% and speed 1.0. Speed may be omitted
# Monochromator motors
ClientPut "Installing Motors"
Motor OmegaM EL734 lnsp19.psi.ch 4000 2 1
Motor TwoThetaM EL734 lnsp19.psi.ch 4000 2 2
Motor MonoX EL734 lnsp19.psi.ch 4000 2 5
Motor MonoY EL734 lnsp19.psi.ch 4000 2 6
Motor CurveM EL734 lnsp19.psi.ch 4000 2 9
Motor MonoPhi EL734 lnsp19.psi.ch 4000 2 7
Motor MonoChi EL734 lnsp19.psi.ch 4000 2 8
# sample Table
Motor Table EL734 lnsp19.psi.ch 4000 2 3
Motor TwoThetaD EL734 lnsp19.psi.ch 4000 2 4
#--------------------------------------------------------------------------
# Configure Detector
# needs a EL737 or simualation for count control
ClientPut "Installing counter"
MakeCounter counter EL737 lnsp19.psi.ch 4000 4
counter SetExponent 6
MakeHM banana SINQHM
banana configure HistMode Normal
banana configure OverFlowMode Ceil
banana configure Rank 1
banana configure Length 400
banana configure BinWidth 4
banana preset 100.
banana CountMode Timer
banana configure HMComputer lnse01.psi.ch
banana configure HMPort 2400
banana configure Counter counter
banana init
banana exponent 6
#--------------------------------------------------------------------------
# V A R I A B L E S
# now a few general variables are created
# Syntax: VarMake name type access
# type can be one of: Text, Int, Float
#access can be one of: Internal, Mugger, User, Spy
VarMake SicsDataPath Text Internal
SicsDataPath "/home/DMC/data/"
VarMake DetStepWidth Float Internal
DetStepWidth 0.2
DetStepWidth lock
VarMake Instrument Text Internal
Instrument "DMC"
Instrument lock
#initialisation
VarMake Title Text User
VarMake User Text User
VarMake Collimation Text User
VarMake Sample Text User
Sample Kellerit
VarMake comment1 Text User
VarMake comment2 Text User
VarMake comment3 Text User
VarMake SicsDataPrefix Text Internal
SicsDataPrefix dmc
#--------- make data number
MakeDataNumber SicsDataNumber /home/DMC/data/DataNumber
VarMake SicsDataPostFix Text Internal
SicsDataPostFix ".hdf"
VarMake Adress Text User
VarMake phone Text User
VarMake fax Text User
VarMake email Text User
VarMake sample_mur Float User
# Monochromator variables
# Syntax MakeMono name type OmegaMotor 2ThetaMotor CurveMotor1 CurveMotor2
MakeMono Mono "Ge-111" OmegaM TwoThetaM
Mono DD 3.3537
# Syntax MakeWaveLength name MonochromatorToUse
MakeWaveLength lambda Mono
#--------------------------------------------------------------------------
# P R O C E D U R E S
# create the drive command
MakeDrive
#start RuenBuffer system
MakeRuenBuffer
# aliases
SicsAlias OmegaM A1
SicsAlias TwoThetaM A2
SicsAlias Table A3
SicsAlias TwoThetaD A4
SicsAlias MonoX A5
SicsAlias MonoY A6
SicsAlias MonoPhi A7
SicsAlias MonoChi A8
SicsAlias CurveM A9
InitDMC
#----- The Logbook stuff
source "/home/DMC/bin/log.tcl"
Publish LogBook Spy
#------ The count command
source "/home/DMC/bin/count.tcl"
Publish count User
Publish Repeat User
#------ The scan command for Managers
source "/home/DMC/bin/scan.tcl"
Publish scan Mugger
#---------install beam command
source beamdt.tcl

174
dmca.tcl
View File

@ -1,174 +0,0 @@
# --------------------------------------------------------------------------
# Initialization script for DMC at SINQ, SICS server.
#
# Dr. Mark Koennecke March 1997
#---------------------------------------------------------------------------
# O P T I O N S
set auto_path "/data/koenneck/src/sics/tcl"
source $auto_path/dmccom.tcl
# first all the server options are set
ServerOption ReadTimeOut 100
# timeout when checking for commands. In the main loop SICS checks for
# pending commands on each connection with the above timeout, has
# PERFORMANCE impact!
ServerOption AcceptTimeOut 100
# timeout when checking for connection req.
# Similar to above, but for connections
ServerOption ReadUserPasswdTimeout 500000
# time to wiat for a user/passwd to be sent from a client. Increase this
# if there is a problem connecting to a server due to network overload\
ServerOption ServerLogBaseName /data/koenneck/src/sics/server
# the path and base name of the internal server logfile to which all
# activity will be logged.
ServerOption ServerPort 2910
# the port number the server is going to listen at. The client MUST know
# this number in order to connect. It is in client.ini
ServerOption InterruptPort 2913
# The UDP port where the server will wait for Interrupts from clients.
# Obviously, clients wishing to interrupt need to know this number.
ServerOption DefaultCommandFile dmccom.tcl
# The path to the file containing common Tcl-commands and procedures.
# Every connection is initialized with this
#---------------------------------------------------------------------------
# U S E R S
# than the SICS users are specified
# Syntax: SicsUser name password userRightsCode
SicsUser Mugger Diethelm 1
SicsUser User Rosy 2
SicsUser Spy 007 3
#--------------------------------------------------------------------------
# D E V I C E S : M O T O R S
#Motor a4 EL734 LNSP22 4000 5 6
# EL734 motor with parameters: hostname PortNumber Channel MotorID
# Motor nam SIM -20. 20. 5. 1.0
# Simulated motor with name nam, lower limit -20, upper limit +20,
# error ratio 5% and speed 1.0. Speed may be omitted
# Monochromator motors
Motor OmegaM SIM 20. 120. 5. 2.0
Motor TwoThetaM SIM 20. 120. 5. 0.5
Motor MonoX SIM -20. 20. 5. 5.0
Motor MonoY SIM -20. 20. 5. 5.0
Motor CurveM SIM 0. 1000. 10. 5.0
Motor MonoPhi SIM -20. 20. 5. 5.0
Motor MonoChi SIM -20. 20. 5. 5.0
# sample Table
Motor Table SIM -180. 180. 5. 7.0
Motor TwoThetaD SIM 10. 330. 5. 1.0
#--------------------------------------------------------------------------
# Configure Detector
# needs a EL737 or simualation for count control
MakeCounter xxxNo SIM
#MakeHM banana SINQHM
MakeHM banana SIM
banana configure HistMode Normal
banana configure OverFlowMode Ceil
banana configure Rank 1
banana configure Length 400
banana configure BinWidth 4
banana configure Time 10. 12. 14 16. 17.
banana preset 100.
banana CountMode Timer
#banana configure HMComputer psds02.psi.ch
#banana configure HMport 2400
#banana configure Counter xxxNo
banana init
#--------------------------------------------------------------------------
# C O N F I G U R E D E V I C E S T O H A L T I N
# I N T E R R U P T
AddHalt OmegaM TwoThetaM MonoX MonoY MonoChi MonoPhi CurveM Table TwoThetaD
#--------------------------------------------------------------------------
# V A R I A B L E S
# now a few general variables are created
# Syntax: VarMake name type access
# type can be one of: Text, Int, Float
#access can be one of: Internal, Mugger, User, Spy
VarMake Instrument Text Internal
Instrument "DMC at SINQ,PSI"
#initialisation
VarMake Title Text User
VarMake User Text User
VarMake Collimation Text User
VarMake Sample Text User
VarMake comment1 Text User
VarMake comment2 Text User
VarMake Comment3 Text User
VarMake SicsDataPath Text Internal
SicsDataPath "/data/koenneck/src/sics/"
VarMake SicsDataPrefix Text Internal
SicsDataPrefix DMC
VarMake SicsDataNumber Int Internal
SicsDataNumber 0
VarMake SicsDataPostFix Text Internal
SicsDataPostFix ".hdf"
VarMake Adress Text User
VarMake phone Text User
VarMake fax Text User
VarMake email Text User
VarMake sample_mur Float User
VarMake DetStepWidth Float Internal
DetStepWidth 0.02
# Monochromator variables
# Syntax MakeMono name type OmegaMotor 2ThetaMotor CurveMotor1 CurveMotor2
MakeMono Mono "Ge-111" OmegaM TwoThetaM CurveM
# Syntax MakeWaveLength name MonochromatorToUse
MakeWaveLength lambda Mono
#--------------------------------------------------------------------------
# P R O C E D U R E S
# create the drive command
MakeDrive
#start RuenBuffer system
MakeRuenBuffer
if { 0 } {
DMCInit 5 2.0 1
# end -------- of ------------- file -------------------------------------
# test code for powder diagrams, merging etc.
set id1 [DMCShot set 1 2 2 2 2 2 2]
set id2 [DMCShot set 2 3 3 3 3 3 3]
set id3 [DMCShot set 6 1 1 1 1 1 1]
set id4 [DMCShot set 7 5 5 5 5 5 5]
set p1 [DMCPowder merge $id1 $id2 $id3 $id4]
ClientPut [DMCPowder info $p1]
ClientPut [DMCPowder list $p1 0 17]
ClientPut [DMCPowder Start $p1]
ClientPut [DMCPowder Step $p1]
ClientPut [DMCPowder Stop $p1]
DMCReset
}
# test of alias
SicsAlias OmegaM A1
SicsAlias TwoThetaM A2
SicsAlias Table A3
SicsAlias TwoThetaD A4
InitDMC

13
dmccom.tcl
View File

@ -1,13 +0,0 @@
#----------------------------------------------------------------------------
# Common Tcl-command procedures for DMC
# Mark Koennecke February 1997
#--------------------------------------------------------------------------
proc Milch { n } {
for {set i 0 } { $i < $n } { incr i} {
ClientPut "Milch ist gesund"
}
}
proc Kaba { text } {
return $text
}

8
dmcscan.tcl
View File

@ -1,8 +0,0 @@
#----------------------------------------------------------------------------
# Common Tcl-command procedures for DMC
# Mark Koennecke February 1997
#--------------------------------------------------------------------------
source "/data/koenneck/src/sics/obtcl.tcl
# define DMC scan class
class DMCScanClass

167
dmcsim.tcl
View File

@ -1,167 +0,0 @@
# --------------------------------------------------------------------------
# Initialization script for DMC at SINQ, SICS server.
#
# Dr. Mark Koennecke Juli 1997
#---------------------------------------------------------------------------
# O P T I O N S
set auto_path "/home/DMC/bin"
# first all the server options are set
ServerOption ReadTimeOut 100
# timeout when checking for commands. In the main loop SICS checks for
# pending commands on each connection with the above timeout, has
# PERFORMANCE impact!
ServerOption AcceptTimeOut 100
# timeout when checking for connection req.
# Similar to above, but for connections
ServerOption ReadUserPasswdTimeout 500000
# time to wiat for a user/passwd to be sent from a client. Increase this
# if there is a problem connecting to a server due to network overload\
ServerOption LogFileBaseName "/home/DMC/log/dmclog"
# the path and base name of the internal server logfile to which all
# activity will be logged.
ServerOption ServerPort 3009
# the port number the server is going to listen at. The client MUST know
# this number in order to connect. It is in client.ini
ServerOption StatusFile /home/DMC/log/simstatus.tcl
ServerOption InterruptPort 3010
# The UDP port where the server will wait for Interrupts from clients.
# Obviously, clients wishing to interrupt need to know this number.
#---------------------------------------------------------------------------
# U S E R S
# than the SICS users are specified
# Syntax: SicsUser name password userRightsCode
SicsUser Manager Lucas 1
SicsUser User DMC 2
SicsUser Spy 007 3
#--------------------------------------------------------------------------
# D E V I C E S : M O T O R S
#Motor a4 EL734 LNSP22 4000 5 6
# EL734 motor with parameters: hostname PortNumber Channel MotorID
# Motor nam SIM -20. 20. 5. 1.0
# Simulated motor with name nam, lower limit -20, upper limit +20,
# error ratio 5% and speed 1.0. Speed may be omitted
# Monochromator motors
Motor OmegaM SIM 0 120 1 2.0
Motor TwoThetaM SIM 30 100 1 1.0
Motor MonoX SIM -30 30 1 3.0
Motor MonoY SIM -30 30 1 3.0
Motor CurveM SIM 0 20 1 3.0
Motor MonoPhi SIM -30 30 1 3.0
Motor MonoChi SIM -30 30 1 3.0
# sample Table
Motor Table SIM -180 360 1 2.
Motor TwoThetaD SIM -10 120 1 1.
#--------------------------------------------------------------------------
# Configure Detector
# needs a EL737 or simualation for count control
MakeCounter counter SIM
MakeHM banana SIM
banana configure HistMode Normal
banana configure OverFlowMode Ceil
banana configure Rank 1
banana configure Length 400
banana configure BinWidth 4
banana preset 100.
banana CountMode Timer
#banana configure HMComputer psds04.psi.ch
#banana configure HMPort 2400
#banana configure Counter counter
banana init
#--------------------------------------------------------------------------
# C O N F I G U R E D E V I C E S T O H A L T I N
# I N T E R R U P T
AddHalt OmegaM TwoThetaM MonoX MonoY MonoChi MonoPhi CurveM Table TwoThetaD
#--------------------------------------------------------------------------
# V A R I A B L E S
# now a few general variables are created
# Syntax: VarMake name type access
# type can be one of: Text, Int, Float
#access can be one of: Internal, Mugger, User, Spy
VarMake SicsDataPath Text Internal
SicsDataPath "/home/DMC/sim/"
VarMake DetStepWidth Float Internal
DetStepWidth 0.02
VarMake Instrument Text Internal
Instrument "DMC at SINQ,PSI"
#initialisation
VarMake Title Text User
VarMake User Text User
VarMake Collimation Text User
VarMake Sample Text User
Sample Kellerit
VarMake Temperature Float User
Temperature 21.3897
VarMake comment1 Text User
VarMake comment2 Text User
VarMake comment3 Text User
VarMake SicsDataPrefix Text Internal
SicsDataPrefix dmc
VarMake SicsDataNumber Int Mugger
SicsDataNumber 0
VarMake SicsDataPostFix Text Internal
SicsDataPostFix "97.hdf"
VarMake Adress Text User
VarMake phone Text User
VarMake fax Text User
VarMake email Text User
VarMake sample_mur Float User
# Monochromator variables
# Syntax MakeMono name type OmegaMotor 2ThetaMotor CurveMotor1 CurveMotor2
MakeMono Mono "Ge-111" OmegaM TwoThetaM
Mono DD 3.3537
# Syntax MakeWaveLength name MonochromatorToUse
MakeWaveLength lambda Mono
#--------------------------------------------------------------------------
# P R O C E D U R E S
# create the drive command
MakeDrive
#start RuenBuffer system
MakeRuenBuffer
# aliases
SicsAlias OmegaM A1
SicsAlias TwoThetaM A2
SicsAlias Table A3
SicsAlias TwoThetaD A4
InitDMC
#----- The Logbook stuff
source "/home/DMC/bin/log.tcl"
Publish LogBook User
#------ The count command
source "/home/DMC/bin/count.tcl"
Publish count User
Publish Repeat User
#------ The scan command for Managers
source "/home/DMC/bin/scan.tcl"
Publish scan Mugger

355
fcircle.tcl
View File

@ -1,355 +0,0 @@
#----------------------------------------------------------------------------
# fcircle is a collection of SICS-Tcl macro scripts which help with
# the running of a four circle diffractometer. The central idea is
# a data base file which can be manipulated both from SICS and from
# external programs. The name of this database file is expected to live in
# the SICS variable dbfile.
#
# Mark Koennecke, November 1999
#---------------------------------------------------------------------------
#----------- fcircleinit
# fcircleinit must be called from the SICS initialization script and will
# then install all necessary variables and the commands defined by this
# script into SICS.
proc fcircleinit {} {
VarMake dbfile Text User
Publish writepos User
Publish writerefl User
Publish clearrefl User
Publish listrefl User
Publish updateub User
Publish setlambda User
Publish fcentre User
}
#------------fsplit
# returns the answer part of a SICS reply of the form something = something
proc fsplit {text} {
set l [split $text =]
set t [lindex $l 1]
return [string trim $t]
}
#----------- locate
# This is an internal routine and tries to locate a section in the database
# file. The database file is plain ASCII. There are sections in the file
# separated by lines starting with ####. The #### is followed by the title
# name of the section. Then follow lines of section specific data in variable
# syntax. Another complication is that we need to be able to update the data
# in the file. In order to do that the whole file is first read into an array
# before the search is started. This is feasible as we have at max a hundred
# lines. The array receives a member nl which is the number of lines read.
# The parameters are:
# ar the array of lines.
# fd a file descriptor as created by open
# keyword the keyword to search for
# The function returns the line number where the keyword was found on success,
# else -1 is returned.
#proc dbfile {} {
# return "dbfile = test.db"
#}
proc locate { data keyword} {
upvar $data ar
#--------- read file
set ret [catch {open [fsplit [dbfile]] r} fd]
if {$ret == 1} {
set ar(nl) 0
return -1
}
#----- read whole file
set i 0
while {[gets $fd line] > 0 } {
set ar($i) $line
incr i
}
set ar(nl) $i
close $fd
#----- start search
for {set i 0} {$i < $ar(nl)} { incr i} {
#------ look for delimiter
set delim [string range $ar($i) 0 3]
if {[string compare $delim ####] == 0} {
#----------- check keyword
if {[string first $keyword $ar($i) ] > 0} {
return $i
}
}
}
return -1;
}
#--------------- writerange
# writerange writes a range of lines from an array created by locate
# to the file specicified by fd. Ranges are automaticcaly adjusted to
# data limits
proc writerange { data fd start end } {
upvar $data ar
#----- adjust ranges
if {$start < 0} {
set start 0
}
if {$start > $ar(nl) } {
set start $ar(nl)
}
if { $end > $ar(nl) } {
set end $ar(nl)
}
#---- write!
for {set i $start} {$i < $end} {incr i} {
puts $fd $ar($i)
}
}
#----------- writepos
# writepos writes the current positions of stt, om, ch, ph motors as a A type
# line into the reflection section of the data base file. This is used after
# centering an unindexed reflection.
proc writepos { } {
#----- get positions
set ret [catch {fsplit [stt]} mystt]
if {$ret == 1} {
error $myom
}
set ret [catch {fsplit [om]} myom]
if {$ret == 1} {
error $myom
}
set ret [catch {fsplit [ch]} mych]
if {$ret == 1} {
error $myom
}
set ret [catch {fsplit [ph]} myph]
if {$ret == 1} {
error $myom
}
#----- find position in file
set ret [catch {locate data reflections} ind]
#----- write
set ret [catch {open [fsplit [dbfile]] w} fd]
if { $ret == 1} {
error $fd
}
if { $ind < 0 } {
writerange data $fd 0 $data(nl)
puts $fd "#### reflections"
puts $fd [format "A %8.2f %8.2f %8.2f %8.2f" \
$mystt $myom $mych $myph]
} else {
incr ind
writerange data $fd 0 $ind
puts $fd [format "A %8.2f %8.2f %8.2f %8.2f" \
$mystt $myom $mych $myph]
writerange data $fd $ind $data(nl)
}
close $fd
return OK
}
#------------ writerefl
# writerefl writes a reflection with indexes. This makes an I record in
# the reflections list of the database file. This is meant to be used
# after centering a reflection after the UB-matrix is known
proc writerefl { } {
#----- get positions
set ret [catch {fsplit [stt]} mystt]
if {$ret == 1} {
error $myom
}
set ret [catch {fsplit [om]} myom]
if {$ret == 1} {
error $myom
}
set ret [catch {fsplit [ch]} mych]
if {$ret == 1} {
error $myom
}
set ret [catch {fsplit [ph]} myph]
if {$ret == 1} {
error $myom
}
#------ get hkl
set ret [catch {hkl current} txt]
if {$ret == 1} {
error $txt
}
set l [split $txt]
set H [lindex $txt 2]
set K [lindex $txt 3]
set L [lindex $txt 4]
#----- find position in file
set ret [catch {locate data reflections} ind]
#----- write
set ret [catch {open [fsplit [dbfile]] w} fd]
if { $ret == 1} {
error $fd
}
if { $ind < 0 } {
writerange data $fd 0 $data(nl)
puts $fd "#### reflections"
puts $fd [format "I %5.2f %5.2f %5.2f %8.2f %8.2f %8.2f %8.2f" \
$H $K $L $mystt $myom $mych $myph]
} else {
incr ind
writerange data $fd 0 $ind
puts $fd [format "I %5.2f %5.2f %5.2f %8.2f %8.2f %8.2f %8.2f" \
$H $K $L $mystt $myom $mych $myph]
writerange data $fd $ind $data(nl)
}
close $fd
return OK
}
#----------- clearrefl
# clearrefl clears the list of reflections as stored in the database file
proc clearrefl {} {
#----- find position in file
set ret [catch {locate data reflections} ind]
#---- nothing to do if no entry
if {$ind < 0} {
return "Nothing to do"
}
#----- write
set ret [catch {open [fsplit [dbfile]] w} fd]
if { $ret == 1} {
error $fd
}
incr ind
writerange data $fd 0 $ind
for {set i $ind} {$i < $data(nl)} {incr i} {
set delim [string range $data($i) 0 3]
if {[string compare $delim ####] == 0} {
break
}
}
set ind [expr $ind + $i - 1]
writerange data $fd $ind $data(nl)
close $fd
return OK
}
#-------- listrefl
# listrefl lists all the entries in the reflection list
proc listrefl {} {
#----- find position in file
set ret [catch {locate data reflections} ind]
#---- nothing to do if no entry
if {$ind < 0} {
return "Nothing to do"
}
#------ list
incr ind
for {set i $ind} {$i < $data(nl)} {incr i} {
set delim [string range $data($i) 0 3]
if {[string compare $delim ####] == 0} {
break
} else {
ClientPut $data($i)
}
}
return OK
}
#---------- updateub
# updateub reads a UB matrix from the file and replaces the current SICS
# UB matrix with the one from the file. To be used after another program
# created a UB matrix in the first place or after refining the UB matrix
# following a centering operation.
# WARNING: this requires that the Tcl internal scan command has been r
# renamed BEFORE loading the scan command to stscan. Otherwise there is
# as conflict with the scan routine!
proc updateub {} {
#----- find position in file
set ret [catch {locate data UB} ind]
if { $ind < 0} {
error "ERROR: No UB matrix in database"
}
incr ind
#------ read three lines of UB
stscan $data($ind) "%f%f%f" ub11 ub12 ub13
ClientPut $ub11 $ub12 $ub13
incr ind
stscan $data($ind) "%f%f%f" ub21 ub22 ub23
incr ind
stscan $data($ind) "%f%f%f" ub31 ub32 ub33
hkl setub $ub11 $ub12 $ub13 $ub21 $ub22 $ub23 $ub31 $ub32 $ub33
return OK
}
#--------- setlambda
# setlambda sets the wavelength
proc setlambda {newval} {
set ret [catch {hkl lambda $newval} msg]
if {$ret == 1} {
error $msg
}
#----- find position in file
set ret [catch {locate data lambda} ind]
#----- write
set ret [catch {open [fsplit [dbfile]] w} fd]
if { $ret == 1} {
error $fd
}
if { $ind < 0 } {
writerange data $fd 0 $data(nl)
puts $fd "#### lambda"
puts $fd [format " %12.6f" $newval]
} else {
incr ind
writerange data $fd 0 $ind
puts $fd [format " %12.6f" $newval]
incr ind
writerange data $fd $ind $data(nl)
}
close $fd
return OK
}
#------- fcentre
# fcentre centers a reflection
proc fcentre {} {
#----- rough centering
opti clear
opti countmode monitor
opti preset 1000
opti threshold 30
opti addvar om .1 25 .10
opti addvar stt .20 25 .25
opti addvar ch 1.0 20 1.
set ret [catch {opti run} msg]
if {$ret == 1} {
error $msg
}
#----- fine centering
opti preset 5000
opti threshold 50
set ret [catch {opti run} msg]
if {$ret != 0 } {
error $msg
}
set txt [om]
set l [split $txt =]
set tom [lindex $l 1]
set txt [stt]
set l [split $txt =]
set tstt [lindex $l 1]
set txt [ch]
set l [split $txt =]
set tch [lindex $l 1]
set txt [ph]
set l [split $txt =]
set tph [lindex $l 1]
ClientPut "Two-Theta Omega Chi Phi"
ClientPut [format "%-10.2f%-10.2f%-10.2f%-10.2f" $tstt $tom $tch $tph]
storepos
}

4
fetest.tcl
View File

@ -1,4 +0,0 @@
cscan a4 0. .2 10 2
for {set i 0} { $i < 5} { incr i} {
count timer 200
}

178
ftest.tcl
View File

@ -1,178 +0,0 @@
# --------------------------------------------------------------------------
# Initialization script for a simulated FOCUS instrument
#
#
# Dr. Mark Koennecke November 1998
#---------------------------------------------------------------------------
# O P T I O N S
ServerOption ReadTimeOut 100
# timeout when checking for commands. In the main loop SICS checks for
# pending commands on each connection with the above timeout, has
# PERFORMANCE impact!
ServerOption AcceptTimeOut 100
# timeout when checking for connection req.
# Similar to above, but for connections
ServerOption ReadUserPasswdTimeout 7000
# time to wiat for a user/passwd to be sent from a client. Increase this
# if there is a problem connecting to a server due to network overload\
ServerOption LogFileDir /data/koenneck/src/sics/tmp
#LogFileDir is the directory where the command log is going
ServerOption LogFileBaseName /data/koenneck/src/sics/tmp/server
# the path and base name of the internal server logfile to which all
# activity will be logged.
ServerOption ServerPort 2911
# the port number the server is going to listen at. The client MUST know
# this number in order to connect. It is in client.ini
ServerOption InterruptPort 2914
# The UDP port where the server will wait for Interrupts from clients.
# Obviously, clients wishing to interrupt need to know this number.
# Telnet options
ServerOption TelnetPort 1301
ServerOption TelWord sicslogin
ServerOption DefaultTclDirectory /data/koenneck/src/sics/tcl
#------ a port for broadcasting UDP messages
#ServerOption QuieckPort 2108
TokenInit connan
#---------------------------------------------------------------------------
# U S E R S
# than the SICS users are specified
# Syntax: SicsUser name password userRightsCode
SicsUser Mugger Diethelm 1
SicsUser User Rosy 2
SicsUser Spy 007 1
#--------------------------------------------------------------------------
# S I M P L E V A R I A B L E S
# now a few general variables are created
# Syntax: VarMake name type access
# type can be one of: Text, Int, Float
#access can be one of: Internal, Mugger, user, Spy
VarMake Instrument Text Internal
Instrument "FOCUS" #initialisation
Instrument lock
VarMake Title Text User
VarMake sample Text User
sample "Altorferit"
VarMake Temperature Float User
Temperature 21.5
Title "Hochdestillierter Schrott"
VarMake User Text User
User "Stefan & Felix & Lothar"
#--------- FOCUS special variables
VarMake BeStatus Int User
BeStatus 0
VarMake flightpath Text Mugger
flightpath "Standard"
VarMake flightpathlength Float Mugger
flightpathlength 3000
VarMake ferminame Text Mugger
ferminame "Dornier Fermi Chopper"
ferminame lock
VarMake fermidist Float Mugger
fermidist 3000
VarMake detectordist Float Mugger
detectordist 2500
VarMake sampledist Float Mugger
sampledist 499.7
sampledist lock
VarMake chopperrot Float User
chopperrot 10000
VarMake fermirot Float User
fermirot 12000
VarMake fermiphase Float User
fermiphase 22.23
VarMake environment Text User
environment Void
VarMake delay Float User
delay 155.8
VarMake sampleangle Float User
sampleangle 0.0
#--------------------------------------------------------------------------
# D E V I C E S : M O T O R S
# Motor a4 EL734 LNSP22 4000 5 6
# EL734 motor with parameters: hostname PortNumber Channel MotorID
#Motor D1V EL734 lnsp22.psi.ch 4000 3 3
Motor A1 SIM 30.0 120. .1 2. # Monochromator Theta
Motor A2 SIM 30. 120. .1 1. # Monochromator 2Theta
Motor MTL SIM -30. 30. .1 3. # mono lower translation
Motor MTU SIM -30. 30. .1 3. # mono upper translation
Motor MGU SIM -50. 50. .1 3. # mono upper goniometer
Motor MGL SIM -50. 50. .1 3. # mono lower goniometer
ClientPut "Motors done"
#--------------------------------------------------------------------------
# C O U N T E R S
MakeCounter counter SIM
#MakeCounter counter EL737 lnsp19.psi.ch 4000 4
#--------------------------------------------------------------------------
# M U L T I D E V I C E V A R I A B L E S
MakeMono Mono "Ge-111" A1 A2
MakeWaveLength lambda Mono
MakeEnergy qi Mono
#--------------------------------------------------------------------------
# P R O C E D U R E S
MakeDrive
MakeRuenBuffer
#---------------- TestVariables for Storage
VarMake SicsDataPath Text Mugger
SicsDataPath "/data/koenneck/src/sics/"
SicsDataPath lock
VarMake SicsDataPrefix Text Mugger
SicsDataPrefix test
SicsDataPrefix lock
VarMake SicsDataPostFix Text Mugger
SicsDataPostFix ".hdf"
SicsDataPostFix lock
VarMake Adress Text User
VarMake phone Text User
VarMake fax Text User
VarMake email Text User
VarMake sample_mur Float User
MakeDataNumber SicsDataNumber "/data/koenneck/src/sics/danu.dat"
SerialInit
Publish serialport User
Publish p1 User
Publish HakleGet User
#------------------ Focus tests
proc chopper {text } {
ClientPut "chopper.speed = 17050"
ClientPut "chopper.phase = 13.33"
}
Publish chopper Spy
#--------- create a time array for histogramming
MakeHM banana SIM
banana configure HistMode TOF
banana configure OverFlowMode Ceil
banana configure Rank 1
banana configure Length 76800
banana configure BinWidth 4
banana preset 100.
banana CountMode Timer
banana genbin 120. 35. 512
banana init
MakeFocusAverager average banana
FocusInstall banana focus.dic

273
hakle.tcl
View File

@ -1,273 +0,0 @@
#----------------------------------------------------------------------------
# H A K L E
#
# Driver for the Haake water bath thermostat in the SINQ setup. This driver
# is realised in Tcl and uses the tclev interface for talking to SICS.
#
# copyright: see copyright.h
#
# Mark Koennecke, February 1998
#----------------------------------------------------------------------------
set HakleNUM 0
proc HakleSend args {
upvar #0 [lindex $args 0] ar
set command [lrange $args 1 end]
set ret [catch {$ar(socket) $command} msg]
if {$ret != 0} {
ClientPut $msg
error -701
}
return $msg
}
#--------------------------------------------------------------------------
# HakleCheck tests a answer from the Hake for validity. Valid answers
# contain a $. Errors no $ and and F as first character.
proc HakleCheck {text } {
if { [string match *\$ $text]} {
return 1
}
if { [string match F* $text] } {
error -703
}
}
#---------------------------------------------------------------------------
proc HakleCommand args {
upvar #0 [lindex $args 0] ar
set ret [catch {eval HakleSend $args} msg]
if {$ret != 0} {
error $msg
}
set ret [catch {HakleCheck $msg} msg2]
if {$ret != 0} {
error $msg2
}
return $msg
}
#----------------------------------------------------------------------------
proc HakleInit {Hakle} {
upvar $Hakle ar
global HakleNUM
#------ open a connection
set nam hakle$HakleNUM
set ret [catch {serialport $nam $ar(computer) $ar(port) \
$ar(channel) 1} msg]
if {$ret != 0 } {
ClientPut $msg
error -700
}
set ar(socket) $nam
incr HakleNUM
set ar(intern) 1
set ar(pending) 0
set ar(lastread) 20.00
#----- configure
$nam -replyterm "1\r"
$nam -tmo 1800
#----- block local
set ret [catch {HakleCommand $Hakle OUT MODE 3 0} msg ]
if {$ret != 0 } {
error -$msg
}
return 1
}
#---------------------------------------------------------------------------
proc HakleClose {Hakle} {
upvar #0 $Hakle ar
set ret [catch {HakleCommand $Hakle OUT MODE 3 1} msg]
if {$ret != 0} {
ClientPut "Error resettting Haake Thermostat"
}
rename $ar(socket) ""
return 1
}
#----------------------------------------------------------------------------
proc HakleWrapper args {
upvar #0 [lindex $args 0] ar
if { [llength $args] < 2 } {
error "Insufficient number of commands"
}
set key [lindex $args 1]
switch -exact $key {
sensor {
if { [llength $args] > 2 } {
set val [lindex $args 2]
#------- switch to intern
if { [string compare $val intern] == 0 } {
set ret [catch {HakleCommand [lindex $args 0] OUT MODE 2 0} msg]
if {$ret != 0 } {
error $msg
} else {
set ar(intern) 1
}
#-------- switch to extern
} elseif { [string compare $val extern] == 0 } {
set ret [catch {HakleCommand [lindex $args 0] OUT MODE 2 1} msg]
if {$ret != 0 } {
error $msg
} else {
set ar(intern) 0
}
} else {
error -705
}
} else {
if { $ar(intern) == 1 } {
ClientPut [format "%s.sensor intern" $ar(MyName)]
return 1
} else {
ClientPut [format "%s.sensor extern" $ar(MyName)]
return 1
}
}
}
list {
if { $ar(intern) == 1 } {
ClientPut [format "%s.sensor intern" $ar(MyName)]
error -700
} else {
ClientPut [format "%s.sensor extern" $ar(MyName)]
error -700
}
}
default {
error -700
}
}
}
#----------------------------------------------------------------------------
proc HakleSet {Hakle val} {
upvar #0 $Hakle ar
# ClientPut "HakleSet"
set ret [catch {$ar(socket) [format "OUT SP 1 %f" $val]} msg]
if {$ret != 0} {
ClientPut $msg
error -701
}
set ret [catch {HakleCheck $msg} msg2]
if {$ret != 0} {
error $msg2
}
set ar(pending) 0
return $msg
}
#----------------------------------------------------------------------------
proc HakleGet {Hakle} {
upvar #0 $Hakle ar
if {$ar(intern) == 1} {
set ret [catch {eval HakleCommand $Hakle IN PV 1} msg]
if {$ret != 0 } {
error $msg
}
} else {
set ret [catch {HakleCommand IN PV 2} msg]
if {$ret != 0 } {
error $msg
}
}
set ans [string trim $msg \$]
set ans2 [string trim $ans]
set ans3 [string trim $ans2 C]
#------ fix some pecularities of the Haake, sometimes it gives empty
# messages or double +
if { [string length $ans3] < 3 } {
return $ar(lastread)
}
if { [string first "++" $ans3] >= 0 } {
set ans3 [string range $ans3 1 end]
}
set ar(lastread) $ans3
return $ans3
}
#----------------------------------------------------------------------------
proc HakleGet2 {Hakle} {
upvar #0 $Hakle ar
# ClientPut "HakleGet"
if {$ar(pending) == 0} {
if {$ar(intern) == 1} {
set ret [catch {$ar(socket) -put IN PV 1} msg]
if {$ret != 0 } {
ClientPut $msg
error -701
}
} else {
set ret [catch {$ar(socket) -put IN PV 2} msg]
if {$ret != 0 } {
ClientPut $msg
error -701
}
}
set ar(pending) 1
return $ar(lastread)
} else {
if {[$ar(socket) -readable] == 1 } {
set ar(pending) 0
set ret [catch {$ar(socket) -get} msg]
if {$ret != 0 } {
ClientPut $msg
error -701
}
set ans [string trim $msg \$]
set ans2 [string trim $ans]
set ans3 [string trim $ans2 C]
set ar(lastread) $ans3
return $ans3
} else {
return $ar(lastread)
}
}
}
#-----------------------------------------------------------------------------
proc HakleError {Hakle val} {
upvar #0 $Hakle ar
switch -exact -- $val {
-700 {
return "Cannot open socket"
}
-701 {
return "Error sending command"
}
-703 {
return "Invalid command sent"
}
default {
return "Unknown error code"
}
}
}
#-----------------------------------------------------------------------------
proc HakleFix {Hakle val} {
upvar #0 $Hakle ar
switch -exact -- $val {
-700 {
return DEVFAIL
}
-701 {
return DEVREDO
}
-703 {
return DEVREDO
}
default {
return DEVFAIL
}
}
}
#----------------------------------------------------------------------------
proc inihaakearray {ar comp port chan} {
upvar #0 $ar Hakle
set Hakle(Init) HakleInit
set Hakle(Close) HakleClose
set Hakle(Send) HakleSend
set Hakle(SetValue) HakleSet
set Hakle(GetValue) HakleGet
set Hakle(GetError) HakleError
set Hakle(TryFixIt) HakleFix
set Hakle(Wrapper) HakleWrapper
set Hakle(computer) $comp
set Hakle(port) $port
set Hakle(channel) $chan
set Hakle(num) 0
set Hakle(lastread) 20.00
}

34
helium.tcl
View File

@ -1,34 +0,0 @@
#--------------------------------------------------------------------------
# helium: a script for reading the helium level from an AMI-135 Helium Level
# Monitor.
#
# Mark Koennecke, December 1999
#-------------------------------------------------------------------------
#--------- some code to do proper initialization if necessary
set ret [catch {helium} msg]
if {$ret != 0} {
Publish heliumport Spy
Publish helium Spy
Publish heliuminit Mugger
}
#--------------- initialize things
proc heliuminit {mac chan} {
serialport heliumport $mac 4000 $chan
heliumport -tmo 2000
return OK
}
#--------------- real work
proc helium {} {
set ret [catch {heliumport cm} msg]
if {$ret != 0} {
error $msg
}
set ret [catch {heliumport level} msg]
if {$ret != 0} {
error $msg
} else {
return [format "helium = %6.2f cm" $msg]
}
}

22
inc.tcl
View File

@ -1,22 +0,0 @@
#---------------------------------------------------------------------------
# This script reads a file specified on the command line line by line.
# Each line is than enclosed with puts " line " . You obtain a tcl file
# which prints the text in the file
#
# Mark Koennecke October 1996
#--------------------------------------------------------------------------
if {$argc < 1} {
puts "Usage: tclsh inc.tcl file_to_Convert"
exit
}
set file [lindex $argv 0]
set f [open $file r ]
while { ! [eof $f] } {
gets $f line
set line [string trimleft $line]
puts [format "puts \" %s \" " $line]
}

4
inidill.tcl
View File

@ -1,4 +0,0 @@
#dillution initialisation
evfactory new temp dillu lnsp19.psi.ch 4000 1 dilu.tem
temp lowerlimit 0
temp upperlimit 5.

7
itc4.tcl
View File

@ -1,7 +0,0 @@
evfactory new temp ITC4 lnsp19 4000 7
temp lowerlimit 0
temp upperlimit 300
temp control 2
temp sensor 3
temp divisor 100
temp multiplicator 10

96
nxsupport.tcl
View File

@ -1,96 +0,0 @@
#===========================================================================
# Support routines for scripting NeXus files with nxscript.
#
# Mark Koennecke, February 2003
# Mark Koennecke, January 2004
#==========================================================================
proc makeFileName args {
sicsdatanumber incr
set num [SplitReply [sicsdatanumber]]
set p [string trim [SplitReply [sicsdatapath]]]
set pre [string trim [SplitReply [sicsdataprefix]]]
set po [string trim [SplitReply [sicsdatapostfix]]]
return [format "%s%s%5.5d2003%s" $p $pre $num $po]
}
#==========================================================================
# new version, attending to the new 1000 grouping logic
proc newFileName args {
set ret [catch {nxscript makefilename} msg]
if {$ret != 0} {
clientput "ERROR: Misconfiguration of file writing variables"
clientput "Defaulting filename to emergency.hdf"
set fil emergency.hdf
} else {
set fil $msg
}
return $fil
}
#==========================================================================
proc writeFloatVar {alias var} {
set ret [catch {set val [SplitReply [$var]]} val]
if { $ret != 0} {
clientput [format "ERROR: failed to read %s, %s" $var $val]
return
} else {
set val [string trim $val]
set ret [catch {expr $val * 1.0} val]
if { $ret == 0} {
nxscript putfloat $alias [expr $val * 1.0 ]
} else {
clientput "ERROR: bad value $val when reading $var"
}
}
}
#==========================================================================
proc writeIntVar {alias var} {
set ret [catch {set val [SplitReply [$var]]} val]
if { $ret != 0} {
clientput [format "ERROR: failed to read %s, %s" $var $val]
return
} else {
set val [string trim $val]
set ret [catch {expr $val * 1.0} val]
if { $ret == 0} {
nxscript putint $alias [expr int($val * 1.0) ]
} else {
clientput "ERROR: bad value $val when reading $var"
}
}
}
#=========================================================================
proc writeTextVar {alias var} {
set ret [catch {$var} val]
if { $ret != 0} {
clientput [format "ERROR: failed to read %s" $var]
return
} else {
set index [string first = $val]
if {$index >= 0} {
set txt [string trim [string range $val [expr $index + 1] end]]
nxscript puttext $alias $txt
} else {
clientput [format "ERROR: failed to read %s" $var]
}
}
}
#========================================================================
proc writeTextAttribute {attName var} {
set ret [catch {set val [SplitReply [$var]]} val]
if { $ret != 0} {
clientput [format "ERROR: failed to read %s" $var]
return
} else {
nxscript putglobal $attName [string trim $val]
}
}
#=======================================================================
proc writeStandardAttributes {fileName} {
nxscript putglobal file_name $fileName
nxscript putglobal file_time [sicstime]
writeTextAttribute instrument instrument
writeTextAttribute owner user
writeTextAttribute owner_telephone_number phone
writeTextAttribute owner_fax_number fax
writeTextAttribute owner_email email
writeTextAttribute owner_address adress
}

305
object.tcl
View File

@ -1,305 +0,0 @@
#
# $Id: object.tcl,v 1.1 2000/02/25 16:21:41 cvs Exp $
#
# This software is copyright (C) 1995 by the Lawrence Berkeley Laboratory.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that: (1) source code distributions
# retain the above copyright notice and this paragraph in its entirety, (2)
# distributions including binary code include the above copyright notice and
# this paragraph in its entirety in the documentation or other materials
# provided with the distribution, and (3) all advertising materials mentioning
# features or use of this software display the following acknowledgement:
# ``This product includes software developed by the University of California,
# Lawrence Berkeley Laboratory and its contributors.'' Neither the name of
# the University nor the names of its contributors may be used to endorse
# or promote products derived from this software without specific prior
# written permission.
#
# THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
set object_priv(currentClass) {}
set object_priv(objectCounter) 0
#----------------------------------------------------------------------
proc object_class {name spec} {
global object_priv
set object_priv(currentClass) $name
lappend object_priv(objects) $name
upvar #0 ${name}_priv class
set class(__members) {}
set class(__methods) {}
set class(__params) {}
set class(__class_vars) {}
set class(__class_methods) {}
uplevel $spec
proc $name:config args "uplevel \[concat object_config \$args]"
proc $name:configure args "uplevel \[concat object_config \$args]"
proc $name:cget {self option} "uplevel \[list object_cget \$self \$option]"
}
#---------------------------------------------------------------------
proc method {name args body} {
global object_priv
set className $object_priv(currentClass)
upvar #0 ${className}_priv class
if {[lsearch $class(__methods) $name] < 0} {
lappend class(__methods) $name
}
set methodArgs self
append methodArgs " " $args
proc $className:$name $methodArgs "upvar #0 \$self slot ${className}_priv class_var\n$body"
}
#------------------------------------------------------------------
proc object_method {name {defaultValue {}}} [info body method]
#------------------------------------------------------------------
proc member {name {defaultValue {}}} {
global object_priv
set className $object_priv(currentClass)
upvar #0 ${className}_priv class
lappend class(__members) [list $name $defaultValue]
}
#----------------------------------------------------------------------
proc object_member {name {defaultValue {}}} [info body member]
#---------------------------------------------------------------------
proc param {name {defaultValue {}} {resourceClass {}} {configCode {}}} {
global object_priv
set className $object_priv(currentClass)
upvar #0 ${className}_priv class
if {$resourceClass == ""} {
set resourceClass \
[string toupper [string index $name 0]][string range $name 1 end]
}
if ![info exists class(__param_info/$name)] {
lappend class(__params) $name
}
set class(__param_info/$name) [list $defaultValue $resourceClass]
if {$configCode != {}} {
proc $className:config:$name self $configCode
}
}
#-------------------------------------------------------------------------
proc object_param {name {defaultValue {}} {resourceClass {}} {configCode {}}} \
[info body param]
#--------------------------------------------------------------------------
proc object_class_var {name {initialValue ""}} {
global object_priv
set className $object_priv(currentClass)
upvar #0 ${className}_priv class
set class($name) $initialValue
set class(__initial_value.$name) $initialValue
lappend class(__class_vars) $name
}
#---------------------------------------------------------------------------
proc object_class_method {name args body} {
global object_priv
set className $object_priv(currentClass)
upvar #0 ${className}_priv class
if {[lsearch $class(__class_methods) $name] < 0} {
lappend class(__class_methods) $name
}
proc $className:$name $args "upvar #0 ${className}_priv class_var\n$body"
}
#---------------------------------------------------------------------------
proc object_include {super_class_name} {
global object_priv
set className $object_priv(currentClass)
upvar #0 ${className}_priv class
upvar #0 ${super_class_name}_priv super_class
foreach p $super_class(__params) {
lappend class(__params) $p
set class(__param_info/$p) $super_class(__param_info/$p)
}
set class(__members) [concat $super_class(__members) $class(__members)]
set class(__class_vars) \
[concat $super_class(__class_vars) $class(__class_vars)]
foreach v $super_class(__class_vars) {
set class($v) \
[set class(__initial_value.$v) $super_class(__initial_value.$v)]
}
set class(__class_methods) \
[concat $super_class(__class_methods) $class(__class_methods)]
set class(__methods) \
[concat $super_class(__methods) $class(__methods)]
foreach m $super_class(__methods) {
set proc $super_class_name:$m
proc $className:$m [object_get_formals $proc] [info body $proc]
}
foreach m $super_class(__class_methods) {
set proc $super_class_name:$m
regexp "^\[^\n\]+\n(.*)" [info body $proc] dummy body
proc $className:$m [object_get_formals $proc] \
"upvar #0 ${className}_priv class_var\n$body"
}
}
#---------------------------------------------------------------------------
proc object_new {className {name {}}} {
if {$name == {}} {
global object_priv
set name O_[incr object_priv(objectCounter)]
}
upvar #0 $name object
upvar #0 ${className}_priv class
set object(__class) $className
foreach var $class(__params) {
set info $class(__param_info/$var)
set resourceClass [lindex $info 1]
if ![catch {set val [option get $name $var $resourceClass]}] {
if {$val == ""} {
set val [lindex $info 0]
}
} else {
set val [lindex $info 0]
}
set object($var) $val
}
foreach var $class(__members) {
set object([lindex $var 0]) [lindex $var 1]
}
proc $name {method args} [format {
upvar #0 %s object
uplevel [concat $object(__class):$method %s $args]
} $name $name]
return $name
}
#---------------------------------------------------------------
proc object_define_creator {windowType name spec} {
object_class $name $spec
if {[info procs $name:create] == {}} {
error "widget \"$name\" must define a create method"
}
if {[info procs $name:reconfig] == {}} {
error "widget \"$name\" must define a reconfig method"
}
proc $name {window args} [format {
%s $window -class %s
rename $window object_window_of$window
upvar #0 $window object
set object(__window) $window
object_new %s $window
proc %s:frame {self args} \
"uplevel \[concat object_window_of$window \$args]"
uplevel [concat $window config $args]
$window create
set object(__created) 1
bind $window <Destroy> \
"if !\[string compare %%W $window\] { object_delete $window }"
$window reconfig
return $window
} $windowType \
[string toupper [string index $name 0]][string range $name 1 end] \
$name $name]
}
#------------------------------------------------------------------
proc object_config {self args} {
upvar #0 $self object
set len [llength $args]
if {$len == 0} {
upvar #0 $object(__class)_priv class
set result {}
foreach param $class(__params) {
set info $class(__param_info/$param)
lappend result \
[list -$param $param [lindex $info 1] [lindex $info 0] \
$object($param)]
}
if [info exists object(__window)] {
set result [concat $result [object_window_of$object(__window) config]]
}
return $result
}
if {$len == 1} {
upvar #0 $object(__class)_priv class
if {[string index $args 0] != "-"} {
error "param '$args' didn't start with dash"
}
set param [string range $args 1 end]
if {[set ndx [lsearch -exact $class(__params) $param]] == -1} {
if [info exists object(__window)] {
return [object_window_of$object(__window) config -$param]
}
error "no param '$args'"
}
set info $class(__param_info/$param)
return [list -$param $param [lindex $info 1] [lindex $info 0] \
$object($param)]
}
# accumulate commands and eval them later so that no changes will take
# place if we find an error
set cmds ""
while {$args != ""} {
set fieldId [lindex $args 0]
if {[string index $fieldId 0] != "-"} {
error "param '$fieldId' didn't start with dash"
}
set fieldId [string range $fieldId 1 end]
if ![info exists object($fieldId)] {
if {[info exists object(__window)]} {
if [catch [list object_window_of$object(__window) config -$fieldId]] {
error "tried to set param '$fieldId' which did not exist."
} else {
lappend cmds \
[list object_window_of$object(__window) config -$fieldId [lindex $args 1]]
set args [lrange $args 2 end]
continue
}
}
}
if {[llength $args] == 1} {
return $object($fieldId)
} else {
lappend cmds [list set object($fieldId) [lindex $args 1]]
if {[info procs $object(__class):config:$fieldId] != {}} {
lappend cmds [list $self config:$fieldId]
}
set args [lrange $args 2 end]
}
}
foreach cmd $cmds {
eval $cmd
}
if {[info exists object(__created)] && [info procs $object(__class):reconfig] != {}} {
$self reconfig
}
}
proc object_cget {self var} {
upvar #0 $self object
return [lindex [object_config $self $var] 4]
}
#---------------------------------------------------------------------------
proc object_delete self {
upvar #0 $self object
if {[info exists object(__class)] && [info commands $object(__class):destroy] != ""} {
$object(__class):destroy $self
}
if [info exists object(__window)] {
if [string length [info commands object_window_of$self]] {
catch {rename $self {}}
rename object_window_of$self $self
}
destroy $self
}
catch {unset object}
}
#--------------------------------------------------------------------------
proc object_slotname slot {
upvar self self
return [set self]($slot)
}
#--------------------------------------------------------------------------
proc object_get_formals {proc} {
set formals {}
foreach arg [info args $proc] {
if [info default $proc $arg def] {
lappend formals [list $arg $def]
} else {
lappend formals $arg
}
}
return $formals
}

37
optfn.tcl
View File

@ -1,37 +0,0 @@
fileeval /data/jschefer/sbn/sbn.ub
opti clear
opti countmode monitor
opti preset 5000
opti threshold 50
opti addvar om .1 30 .2
opti preset 5000
opti addvar stt .15 29 .3
opti addvar ch 0.9 17 .9
opti addvar om .05 25 .1
set ret [catch {opti run} msg]
if {$ret != 0 } {
error $msg
}
set txt [om]
set l [split $txt =]
set tom [lindex $l 1]
set txt [stt]
set l [split $txt =]
set tstt [lindex $l 1]
set txt [ch]
set l [split $txt =]
set tch [lindex $l 1]
set txt [ph]
set l [split $txt =]
set tph [lindex $l 1]
ClientPut "Two-Theta Omega Chi Phi"
ClientPut [format "%-10.2f%-10.2f%-10.2f%-10.2f" $tstt $tom $tch $tph]
rliste store
liste write q.q
set ttom [string trim $tom]
scan mode monitor
clientput " *** centering ------final omega scan ------------------"
cscan om $ttom 0.04 20 5678

22
optn.tcl
View File

@ -1,22 +0,0 @@
opti clear
opti countmode monitor
opti preset 1000
opti threshold 30
opti addvar om .1 25 .10
opti addvar stt .20 25 .25
opti addvar ch 1.0 20 1.
opti run
set txt [om]
set l [split $txt =]
set tom [lindex $l 1]
set txt [stt]
set l [split $txt =]
set tstt [lindex $l 1]
set txt [ch]
set l [split $txt =]
set tch [lindex $l 1]
set txt [ph]
set l [split $txt =]
set tph [lindex $l 1]
ClientPut "Two-Theta Omega Chi Phi"
ClientPut [format "%-10.2f%-10.2f%-10.2f%-10.2f" $tstt $tom $tch $tph]

499
peaksearch.tcl
View File

@ -1,499 +0,0 @@
#---------------------------------------------------------------------------
# peaksearch a peak search utility for TRICS using the PSD detectors.
#
# Mark Koennecke, November 2001
#---------------------------------------------------------------------------
proc initPeakSearch {} {
#------- phi Range
VarMake ps.phiStart Float User
ps.phiStart 0
VarMake ps.phiEnd Float User
ps.phiEnd 180
VarMake ps.phiStep Float User
ps.phiStep 3.
#-------- chi range
VarMake ps.chiStart Float User
ps.chiStart 0
VarMake ps.chiEnd Float User
ps.chiEnd 180
VarMake ps.chiStep Float User
ps.chiStep 12.
#-------- omega range
VarMake ps.omStart Float User
ps.omStart 0
VarMake ps.omEnd Float User
ps.omEnd 30
VarMake ps.omStep Float User
ps.omStep 3.
#------- two theta range
VarMake ps.sttStart Float User
ps.sttStart 5
VarMake ps.sttEnd Float User
ps.sttEnd 70
VarMake ps.sttStep Float User
ps.sttStep 3.
#------- maximum finding parameters
VarMake ps.threshold Int User
ps.threshold 30
VarMake ps.steepness Int User
ps.steepness 3
VarMake ps.window Int User
ps.window 7
VarMake ps.cogwindow Int User
ps.cogwindow 60
VarMake ps.cogcontour Float User
ps.cogcontour .2
#-------- counting parameters
VarMake ps.countmode Text User
ps.countmode monitor
VarMake ps.preset Float User
ps.preset 1000
#-------- final scan counting parameters
VarMake ps.scanpreset Float User
ps.scanpreset 1000000
VarMake ps.scansteps Int User
ps.scansteps 24
#--------- file to which to write the results
VarMake ps.listfile Text User
ps.listfile peaksearch.dat
#--------- conversion factors from Pixel to mm
VarMake xfactor Float Mugger
xfactor 0.715
VarMake yfactor Float Mugger
yfactor 1.42
#--------- published functions
Publish ps.phirange User
Publish ps.chirange User
Publish ps.omrange User
Publish ps.sttrange User
Publish ps.countpar User
Publish ps.scanpar User
Publish ps.maxpar User
Publish ps.list User
Publish ps.listpeaks User
Publish ps.run User
Publish ps.continue User
Publish ps.scanlist User
#------- these are for debugging only!
Publish checkomega User
Publish optimizedetector User
Publish optimizepeak User
Publish printpeak User
Publish initsearch User
Publish catchdrive User
Publish catchdriveval User
Publish scandetectorsD User
Publish scandetectors User
}
#--------------------------------------------------------------------------
proc ps.phirange args {
if { [llength $args] >= 3 } {
ps.phiStart [lindex $args 0]
ps.phiEnd [lindex $args 1]
ps.phiStep [lindex $args 2]
}
clientput "Peak Search Phi Range:"
return [format " Start = %6.2f, End = %6.2f, Step = %6.2f" \
[SplitReply [ps.phiStart]] [SplitReply [ps.phiEnd]] \
[SplitReply [ps.phiStep]]]
}
#--------------------------------------------------------------------------
proc ps.chirange args {
if { [llength $args] >= 3 } {
ps.chiStart [lindex $args 0]
ps.chiEnd [lindex $args 1]
ps.chiStep [lindex $args 2]
}
clientput "Peak Search Chi Range:"
return [format " Start = %6.2f, End = %6.2f, Step = %6.2f" \
[SplitReply [ps.chiStart]] [SplitReply [ps.chiEnd]] \
[SplitReply [ps.chiStep]]]
}
#--------------------------------------------------------------------------
proc ps.omrange args {
if { [llength $args] >= 3 } {
ps.omStart [lindex $args 0]
ps.omEnd [lindex $args 1]
ps.omStep [lindex $args 2]
}
clientput "Peak Search Omega Range:"
return [format " Start = %6.2f, End = %6.2f, Step = %6.2f" \
[SplitReply [ps.omStart]] [SplitReply [ps.omEnd]] \
[SplitReply [ps.omStep]]]
}
#--------------------------------------------------------------------------
proc ps.sttrange args {
if { [llength $args] >= 3 } {
ps.sttStart [lindex $args 0]
ps.sttEnd [lindex $args 1]
ps.sttStep [lindex $args 2]
}
clientput "Peak Search Two Theta Range:"
return [format " Start = %6.2f, End = %6.2f, Step = %6.2f" \
[SplitReply [ps.sttStart]] [SplitReply [ps.sttEnd]] \
[SplitReply [ps.sttStep]]]
}
#-------------------------------------------------------------------------
proc ps.countpar args {
if { [llength $args] >= 2 } {
if { [catch {counter setmode [lindex $args 0]} msg] != 0} {
error "ERROR: Invalid countmode specified"
}
ps.countmode [lindex $args 0]
ps.preset [lindex $args 1]
}
clientput "Peak Search Count Parameters:"
return [format " Mode = %s, Preset = %12.2f" \
[SplitReply [ps.countmode]] [SplitReply [ps.preset]]]
}
#-------------------------------------------------------------------------
proc ps.scanpar args {
if { [llength $args] >= 2 } {
ps.scanpreset [lindex $args 0]
ps.scansteps [lindex $args 1]
}
clientput "Peak Search Scan Parameters:"
return [format " Count Preset = %12.2f, No. Steps %4d" \
[SplitReply [ps.scanpreset]] [SplitReply [ps.scansteps]]]
}
#-------------------------------------------------------------------------
proc ps.maxpar args {
if { [llength $args] >= 5 } {
ps.window [lindex $args 0]
ps.threshold [lindex $args 1]
ps.steepness [lindex $args 2]
ps.cogwindow [lindex $args 3]
ps.cogcontour [lindex $args 4]
}
clientput "Peak Search Maximum Detection Parameters:"
set t1 [format " Window = %d, Threshold = %d * average, Steepness = %d" \
[SplitReply [ps.window]] [SplitReply [ps.threshold]] \
[SplitReply [ps.steepness] ]]
set t2 [format " COGWindow = %d, COGcontour = %f " \
[SplitReply [ps.cogwindow]] [SplitReply [ps.cogcontour]]]
return [format "%s\n%s" $t1 $t2]
}
#-----------------------------------------------------------------------
proc ps.list {} {
clientput [ps.sttrange]
clientput [ps.omrange]
clientput [ps.chirange]
clientput [ps.phirange]
clientput [ps.countpar]
clientput [ps.scanpar]
clientput [ps.maxpar]
}
#------------------------------------------------------------------------
proc string2list {txt} {
return [split [string trim $txt \{\}]]
}
#------------------------------------------------------------------------
proc checknewomega {hm x y omega maxIntensity} {
if {[catch {drive om $omega} msg] != 0} {
error $msg
}
if {[catch {hmc start [SplitReply [ps.preset]] [string trim [SplitReply \
[ps.countmode]]]} msg] != 0} {
error $msg
}
if {[catch {Success} msg] != 0} {
error $msg
}
if { [catch {lomax cog $hm $x $y} result] != 0} {
error "Failed to calculate COG: $result"
}
set result [split $result " "]
if {[lindex $result 2] > $maxIntensity } {
return $result
} else {
return 0
}
}
#------------------------------------------------------------------------
proc optimizedetector {hm} {
if { [catch {lomax stat $hm} result] != 0} {
#--- This can be due to the fact that the detector is missing. Sigh ....
return
}
set l2 [split [string trim $result]]
lomax threshold [expr [lindex $l2 0] * [SplitReply [ps.threshold]]]
set result [lomax search $hm]
set oldom [SplitReply [om]]
set result [split $result @]
for {set i 0} { $i < [llength $result]} {incr i} {
if { [catch {drive om $oldom} msg] != 0} {
error $msg
}
set piecks [split [lindex $result $i] " "]
set x [lindex $piecks 0]
set y [lindex $piecks 1]
if { [catch {optimizepeak $hm $x $y} msg] != 0} {
clientput [format "Aborted peak at %d %d with %s" $x $y $msg]
}
}
}
#------------------------------------------------------------------------
proc optimizepeak {hm x y} {
if { [catch {lomax cog $hm $x $y} result] != 0} {
error "Failed to calculate COG: $result"
}
set result [split $result " "]
set xMax [lindex $result 0]
set yMax [lindex $result 1]
set maxIntensity [lindex $result 2]
set maxOmega [SplitReply [om]]
set startOmega $maxOmega
set omSearchStep .1
#--------- move to positive omega until maximum found
while {1} {
set newOm [expr [SplitReply [om]] + $omSearchStep]
if {[catch {checknewomega $hm $xMax $yMax $newOm $maxIntensity} \
result] != 0} {
error $result
}
if {$result != 0} {
set xMax [lindex $result 0]
set yMax [lindex $result 1]
set maxIntensity [lindex $result 2]
set maxOmega [SplitReply [om]]
} else {
break
}
}
#--------- if maxOmega is still startOmega then we were on the right
# side of the peak. In this case try to find the maximum in
# negative direction
if {$maxOmega == $startOmega} {
while {1} {
set newOm [expr [SplitReply [om]] - $omSearchStep]
if {[catch {checknewomega $hm $xMax $yMax $newOm $maxIntensity} \
result] != 0} {
error $result
}
if {$result != 0} {
set xMax [lindex $result 0]
set yMax [lindex $result 1]
set maxIntensity [lindex $result 2]
set maxOmega [SplitReply [om]]
} else {
break
}
}
}
#----------- print the results we have found
printpeak $hm $xMax $yMax $maxOmega $maxIntensity
#------------ scan the peak for Oksana
# set scanStart [expr $maxOmega - 0.1*([SplitReply [ps.scansteps]]/2)]
# if { [catch {tricsscan $scanStart .1 [SplitReply [ps.scansteps]] \
# [SplitReply [ps.countmode]] [SplitReply [ps.scanpreset]]} msg] } {
# error $msg
# }
}
#---------------------------------------------------------------------------
proc printpeak {hm x y om intensity} {
set phval [SplitReply [phi]]
set chval [SplitReply [chi]]
set gamOffset .0
switch $hm {
hm1 {
set tilt [SplitReply [dg1]]
set gamOffset .0
}
hm2 {
set tilt [SplitReply [dg2]]
set gamOffset 0.
}
hm3 {
set tilt [SplitReply [dg3]]
set gamOffset 45.
}
default {error "Invalid hm requested in printpeak"}
}
set sttval [expr [SplitReply [stt]] + $gamOffset]
set zero [SplitReply [$hm configure dim0]]
set xval [expr $x * [SplitReply [xfactor]]]
set zero [SplitReply [$hm configure dim1]]
set yval [expr $y * [SplitReply [yfactor]]]
set line [format "%7.2f%7.2f%7.2f%7.2f%7.2f%7.2f%7.2f%10d" \
$xval $yval $sttval $om $chval $phval $tilt $intensity]
clientput "Found Peak at:"
clientput $line
set f [open [string trim [SplitReply [ps.listfile]]] a+]
puts $f $line
close $f
}
#--------------------------------------------------------------------------
proc ps.listpeaks {} {
clientput "Peakse found so far: "
clientput " X Y STT OM CHI PHI TILT INTENSITY"
set f [open [string trim [SplitReply [ps.listfile]]] r]
while {[gets $f line] > 0} {
clientput [format "%s" $line]
}
close $f
}
#-------------------------------------------------------------------------
proc initsearch {filename} {
#----- stow away filename and empty it
ps.listfile $filename
set f [open $filename w]
close $f
#----- tell lomax its parameters
lomax threshold [SplitReply [ps.threshold]]
lomax steepness [SplitReply [ps.steepness]]
lomax window [SplitReply [ps.window]]
lomax cogwindow [SplitReply [ps.cogwindow]]
lomax cogcontour [SplitReply [ps.cogcontour]]
#----- drive to start
if { [catch {drive stt [SplitReply [ps.sttStart]] \
om [SplitReply [ps.omStart]] \
chi [SplitReply [ps.chiStart]] \
phi [SplitReply [ps.phiStart]] } msg] != 0} {
error $msg
}
}
#------------------------------------------------------------------------
# This code means: ignore any errors except interrupts when searching
proc scandetectors {} {
# set names [list hm1 hm2 hm3]
set names [list hm2 hm3]
if {[catch {hmc start [SplitReply [ps.preset]] [string trim [SplitReply \
[ps.countmode]]]} msg] != 0} {
if{[string compare [getint] continue] != 0} {
error $msg
} else {
clientput [format "Ignoring: %s" $msg]
}
}
if {[catch {Success} msg] != 0} {
if{[string compare [getint] continue] != 0} {
error $msg
} else {
clientput [format "Ignoring: %s" $msg]
}
}
for {set i 0} { $i < [llength $names]} {incr i} {
set ret [catch {optimizedetector [lindex $names $i]} msg]
if { $ret != 0} {
if {[string compare [getint] continue] != 0} {
error $msg
} else {
clientput [format "Ignoring problem: %s" $msg]
}
}
}
}
#------------------------------------------------------------------------
# loop debugging
proc scandetectorsD {} {
clientput [format "stt = %6.2f, om = %6.2f, chi = %6.2f, phi = %6.2f" \
[SplitReply [stt]] [SplitReply [om]] \
[SplitReply [chi]] [SplitReply [phi]]]
wait 1
}
#-----------------------------------------------------------------------
proc catchdrive { mot step} {
set ret [catch {drive $mot [expr [SplitReply [$mot]] + $step]} msg]
if {$ret != 0} {
if {[string compare [getint] continue] != 0} {
error $msg
} else {
clientput [format "Ignoring: %s" $msg]
}
}
}
#-----------------------------------------------------------------------
proc catchdriveval { mot val} {
set ret [catch {drive $mot $val} msg]
if {$ret != 0} {
if {[string compare [getint] continue] != 0} {
error $msg
} else {
clientput [format "Ignoring: %s" $msg]
}
}
}
#------------------------------------------------------------------------
# The actual loop. It is written in a way which allows for the continuation
# of a search
proc searchloop { } {
set sttStep [SplitReply [ps.sttStep]]
set sttEnd [SplitReply [ps.sttEnd]]
set chiStep [SplitReply [ps.chiStep]]
set chiEnd [SplitReply [ps.chiEnd]]
set phiStep [SplitReply [ps.phiStep]]
set phiEnd [SplitReply [ps.phiEnd]]
set omStep [SplitReply [ps.omStep]]
set omEnd [SplitReply [ps.omEnd]]
while {[SplitReply [stt]] + $sttStep <= $sttEnd} {
while {[SplitReply [chi]] + $chiStep <= $chiEnd} {
while {[SplitReply [om]] + $omStep <= $omEnd} {
while {[SplitReply [phi]] + $phiStep <= $phiEnd} {
scandetectors
catchdrive phi $phiStep
}
catchdrive om $omStep
catchdriveval phi [SplitReply [ps.phiStart]]
}
catchdrive chi $chiStep
catchdriveval om [SplitReply [ps.omStart]]
}
catchdrive stt $sttStep
catchdriveval chi [SplitReply [ps.chiStart]]
}
return "Peak Search finished normally"
}
#---------------------------------------------------------------------------
proc ps.run {filename} {
initsearch $filename
searchloop
}
#-------------------------------------------------------------------------
proc ps.continue {} {
searchloop
}
#------------------------------------------------------------------------
proc ps.scanlist {} {
if { [catch {set f [open [string trim [SplitReply [ps.listfile]]] "r"]} \
msg ] != 0} {
error $msg
}
while { [gets $f line] > 0} {
set n [stscan $line "%f %f %f %f %f %f" x y stt om chi phi]
if {$n < 6} {
clientput [format "Skipping invalid line: %s" line]
continue
}
if { [catch {drive stt $stt om $om chi $chi phi $phi} msg] != 0 } {
clientput $msg
if {[string compare [getint] continue] != 0} {
error "ps.scanlist interupted"
}
}
set scanStart [expr $om - 0.1*([SplitReply [ps.scansteps]]/2)]
if { [catch {tricsscan $scanStart .1 [SplitReply [ps.scansteps]] \
[SplitReply [ps.countmode]] [SplitReply [ps.scanpreset]]} msg] \
!= 0 } {
clientput $msg
if {[string compare [getint] continue] != 0} {
error "ps.scanlist interupted"
}
}
}
close $f
return "Scanning list finished"
}

9
psitest.tcl
View File

@ -1,9 +0,0 @@
#--------------------------------------------------------------------------
# some tcl for testing Tcl language environment device drivers in psish
# Mark Koennecke, February 1998
#--------------------------------------------------------------------------
rename Controller serialport
proc ClientPut {text} {
puts stdout $text
}

665
sans2.tcl
View File

@ -1,665 +0,0 @@
# --------------------------------------------------------------------------
# Initialization script for the instrument SANSII at SINQ
#
# Dr. Mark Koennecke, January - March 2003
#
# Changes:
# Pavel Strunz, 15.04.2003: - changed backlash dz (0.15 --> 0.005)
# Pavel Strunz, 16.04.2003: - changed NVS forbiden gaps according to the actual NVS037
# Pavel Strunz, 23.04.2003: - changed backlash for all ecb motors
# Pavel Strunz, 29.04.2003: - hakle.tcl sourced
# Pavel Strunz, 20.11.2003: - source sans2geometry, sans2measurement
# Pavel Strunz, 03.12.2003: - source scan_a, sans2wavelength, nvs interrupt changed from 3 to 0
#---------------------------------------------------------------------------
# O P T I O N S
set root "/home/SANS2"
set scriptroot $root/sans2_sics
# first all the server options are set
ServerOption statusfile $root/data/2003/sans2stat.tcl
# File to save the status of the instrument too
ServerOption ReadTimeOut 5
# timeout when checking for commands. In the main loop SICS checks for
# pending commands on each connection with the above timeout, has
# PERFORMANCE impact!
ServerOption AcceptTimeOut 5
# timeout when checking for connection req.
# Similar to above, but for connections
ServerOption ReadUserPasswdTimeout 500000
# time to wait for a user/passwd to be sent from a client. Increase this
# if there is a problem connecting to a server due to network overload\
ServerOption LogFileBaseName $root/log/sans2log
# the path and base name of the internal server logfile to which all
# activity will be logged.
ServerOption LogFileDir $root/log
# This is where log files from command log go
ServerOption ServerPort 2911
# the port number the server is going to listen at. The client MUST know
# this number in order to connect. It is in client.ini
ServerOption InterruptPort 2917
# The UDP port where the server will wait for Interrupts from clients.
# Obviously, clients wishing to interrupt need to know this number.
# Telnet Options
ServerOption TelnetPort 1301
ServerOption TelWord sicslogin
# The token system
TokenInit connan
#---------------------------------------------------------------------------
# U S E R S
# than the SICS users are specified
# Syntax: SicsUser name password userRightsCode
SicsUser Manager Manager 1
SicsUser lnsmanager lnsSICSlns 1
SicsUser User Looser 2
SicsUser sans2user 04lns1 2
SicsUser Spy 007 3
#--------------------------------------------------------------------------
# S I M P L E V A R I A B L E S
# now a few general variables are created
# Syntax: VarMake name type access
# type can be one of: Text, Int, Float
#access can be one of: Internal, Mugger, user, Spy
VarMake Instrument Text Internal
Instrument "SANS-II at SINQ,PSI"
#initialisation
Instrument lock
VarMake title Text User
VarMake User Text User
VarMake SubTitle Text User
VarMake environment Text User
VarMake comment Text User
#VarMake samplename Text User
VarMake email Text User
VarMake fax Text User
VarMake phone Text User
VarMake adress Text User
VarMake sample Text User
VarMake BatchRoot Text User
VarMake starttime Text User
BatchRoot $root
#BatchRoot $root/command
VarMake sampletable Text User
#----------- Initialize data storage stuff
VarMake SicsDataPath Text Mugger
SicsDataPath $root/data/2004/
SicsDataPath lock
VarMake SicsDataPrefix Text Mugger
SicsDataPrefix sans2
SicsDataPrefix lock
VarMake SicsDataPostFix Text Mugger
SicsDataPostFix ".hdf"
SicsDataPostFix lock
MakeDataNumber SicsDataNumber $root/data/2004/DataNumber
#=========================================================================
# Initialize ECB system
#========================================================================
#--------- GPIB Controller with National Instruments driver
MakeGPIB gpib ni
#-------- MakeECB name gpib-controller board-number gpib-address
MakeECB ecb1 gpib 0 5
#--------- Function to switch ecb to automatic control
proc ecbauto {} {
ecb1 func 162 1 0 0 0
}
Publish ecbauto User
ecbauto
#-------------- ECB Motors
# Motor name ecb ecb-controller ecb-motor-index hardlowerlimit hardupperlimit
Motor sr ecb ecb1 1 -17500. 17500.
sr encoder 0
sr control 0
sr range 1
sr multi 0
sr multchan 0
sr acceleration 1000
sr rotation_dir -1
sr startspeed 330
sr maxspeed 1000
sr auto 330
sr manuell 50
sr delay 50
sr offset 0
sr dtolerance .01
sr step2deg 1
sr step2dig 0
sr backlash 500
Motor stx ecb ecb1 2 -16000. 16000.
stx encoder 0
stx control 0
stx range 1
stx multi 0
stx multchan 0
stx acceleration 500
stx rotation_dir -1
stx startspeed 330
stx maxspeed 1000
stx auto 500
stx manuell 50
stx delay 50
stx offset 0
stx dtolerance .01
stx step2deg 1
stx step2dig 0
stx backlash 500
Motor stz ecb ecb1 3 6500. 20000.
stz encoder 0
stz control 0
stz range 1
stz multi 0
stz multchan 0
stz acceleration 500
stz rotation_dir -1
stz startspeed 330
stz maxspeed 1000
stz auto 500
stz manuell 50
stz delay 50
stz offset 0
stz dtolerance .01
stz step2deg 1
stz step2dig 0
stz backlash 500
Motor sc ecb ecb1 4 -2000. 70000.
sc encoder 0
sc control 0
sc range 1
sc multi 0
sc multchan 0
sc acceleration 500
sc rotation_dir -1
sc startspeed 330
sc maxspeed 1000
sc auto 500
sc manuell 50
sc delay 50
sc offset 0
sc dtolerance .01
sc step2deg 1
sc step2dig 0
sc backlash 1000
Motor gu ecb ecb1 5 -10000. 10000.
gu encoder 0
gu control 0
gu range 1
gu multi 0
gu multchan 0
gu acceleration 500
gu rotation_dir -1
gu startspeed 330
gu maxspeed 1000
gu auto 500
gu manuell 40
gu delay 50
gu offset 0
gu dtolerance .02
gu step2deg 1
gu step2dig 0
gu backlash 100
Motor gl ecb ecb1 6 -10000. 10000.
gl encoder 0
gl control 0
gl range 1
gl multi 0
gl multchan 0
gl acceleration 500
gl rotation_dir -1
gl startspeed 330
gl maxspeed 1000
gl auto 500
gl manuell 40
gl delay 50
gl offset 0
gl dtolerance .02
gl step2deg 1
gl step2dig 0
gl backlash 100
Motor tu ecb ecb1 7 -10000. 10000.
tu encoder 0
tu control 0
tu range 1
tu multi 0
tu multchan 0
tu acceleration 500
tu rotation_dir 1
tu startspeed 330
tu maxspeed 1000
tu auto 330
tu manuell 40
tu delay 50
tu offset 0
tu dtolerance .01
tu step2deg 1
tu step2dig 0
tu backlash 100
Motor tl ecb ecb1 8 -10000. 10000.
tl encoder 0
tl control 0
tl range 1
tl multi 0
tl multchan 0
tl acceleration 500
tl rotation_dir 1
tl startspeed 330
tl maxspeed 1000
tl auto 330
tl manuell 40
tl delay 50
tl offset 0
tl dtolerance .01
tl step2deg 1
tl step2dig 0
tl backlash 100
Motor om ecb ecb1 9 -10000. 10000.
om encoder 1
om control 1
om range 1
om multi 0
om multchan 0
om acceleration 500
om rotation_dir 1
om startspeed 330
om maxspeed 1000
om auto 100
om manuell 40
om delay 50
om offset 0
om dtolerance .01
om step2deg 1
om step2dig 10
om backlash 100
Motor sz ecb ecb1 10 -10000. 10000.
sz encoder 0
sz control 0
sz range 1
sz multi 0
sz multchan 0
sz acceleration 500
sz rotation_dir 1
sz startspeed 330
sz maxspeed 1000
sz auto 500
sz manuell 40
sz delay 50
sz offset 0
sz dtolerance .001
sz step2deg 1
sz step2dig 0
sz backlash 100
Motor sx ecb ecb1 11 -10000. 10000.
sx encoder 0
sx control 0
sx range 1
sx multi 0
sx multchan 0
sx acceleration 500
sx rotation_dir 1
sx startspeed 330
sx maxspeed 1000
sx auto 500
sx manuell 40
sx delay 50
sx offset 0
sx dtolerance .01
sx step2deg 1
sx step2dig 0
sx backlash 100
Motor sy ecb ecb1 12 -10000. 10000.
sy encoder 0
sy control 0
sy range 1
sy multi 0
sy multchan 0
sy acceleration 500
sy rotation_dir 1
sy startspeed 330
sy maxspeed 1000
sy auto 500
sy manuell 50
sy delay 50
sy offset 0
sy dtolerance .001
sy step2deg 1
sy step2dig 0
sy backlash 100
Motor dz ecb ecb1 13 0.905 6.015
dz encoder 0
dz control 0
dz range 1
dz multi 0
dz multchan 0
dz acceleration 2000
dz rotation_dir -1
dz startspeed 330
dz maxspeed 1000
dz auto 500
dz manuell 40
dz delay 1000
dz offset 0
dz dtolerance .001
dz step2deg 53076
dz step2dig 0
dz backlash .005
Motor dh ecb ecb1 14 -10100. 16400.
dh encoder 0
dh control 0
dh range 1
dh multi 0
dh multchan 0
dh acceleration 1000
dh rotation_dir -1
dh startspeed 330
dh maxspeed 1000
dh auto 500
dh manuell 40
dh delay 50
dh offset 0
dh dtolerance .001
dh step2deg 1
dh step2dig 0
dh backlash 100
Motor dv ecb ecb1 15 -14600. 25400.
dv encoder 0
dv control 0
dv range 1
dv multi 0
dv multchan 0
dv acceleration 2000
dv rotation_dir -1
dv startspeed 330
dv maxspeed 1000
dv auto 500
dv manuell 40
dv delay 50
dv offset 0
dv dtolerance .001
dv step2deg 1
dv step2dig 0
dv backlash 100
Motor az1 ecb ecb1 16 -3900. 0.
az1 encoder 0
az1 control 0
az1 range 1
az1 multi 0
az1 multchan 0
az1 acceleration 1000
az1 rotation_dir -1
az1 startspeed 330
az1 maxspeed 1000
az1 auto 330
az1 manuell 40
az1 delay 50
az1 offset 0
az1 dtolerance .001
az1 step2deg 1
az1 step2dig 0
az1 backlash 200
Motor atz ecb ecb1 17 -3900. 0.
atz encoder 0
atz control 0
atz range 1
atz multi 0
atz multchan 0
atz acceleration 1000
atz rotation_dir -1
atz startspeed 330
atz maxspeed 1000
atz auto 330
atz manuell 40
atz delay 50
atz offset 0
atz dtolerance .001
atz step2deg 1
atz step2dig 0
atz backlash 200
#===========================================================================
# The ECB system has the drawback that only one out of 8 motors in a rack
# can run at any given time. Access to such motors has to be serialized.
# This is done through the anticollision system originally developed for
# TRICS. This system registers requests from motors to run and then calls
# a script which serializes the running of motors. This system is used at
# SANS to deal with the rack logic. This section installs the necessary
# scripts and configures the system.
#===========================================================================
AntiCollisionInstall
anticollision register sr
anticollision register stx
anticollision register stz
anticollision register sc
anticollision register gu
anticollision register gl
anticollision register tu
anticollision register tl
anticollision register om
anticollision register sz
anticollision register sx
anticollision register sy
anticollision register dz
anticollision register dh
anticollision register dv
anticollision register az1
anticollision register atz
#------------ assignment which motors belong into which rack
set rack1 [list sr stx sty sc gu gl tu tl]
set rack2 [list om sz sx dz dh dv az1 atz]
set rack3 [list sy]
proc sans2rack args {
global rack1 rack2 rack3
set length [ expr [llength $args]/2.]
#-------- make list which motors have to be run in each rack
for { set i 0} { $i < $length} {incr i} {
set mot [lindex $args [expr $i * 2]]
set target [lindex $args [expr ($i *2) + 1]]
if { [lsearch $rack1 $mot] >= 0} {
lappend rack1mot $mot
lappend rack1target $target
}
if { [lsearch $rack2 $mot] >= 0} {
lappend rack2mot $mot
lappend rack2target $target
}
if { [lsearch $rack3 $mot] >= 0} {
lappend rack3mot $mot
lappend rack3target $target
}
}
#------- append a dummy to each in order to ensure existence
lappend rack1mot dummy
lappend rack1target 0.0
lappend rack2mot dummy
lappend rack2target 0.0
lappend rack3mot dummy
lappend rack3target 0.0
#-------- how many levels do we have?
set level -1
if { [llength $rack1mot] > $level} {
set level [llength $rack1mot]
}
if { [llength $rack2mot] > $level} {
set level [llength $rack2mot]
}
if { [llength $rack3mot] > $level} {
set level [llength $rack3mot]
}
if { $level <= 1} {
error "Nothing to do"
}
#------------ we are set to serialize
anticollision clear
for {set i 0} {$i < $level} {incr i} {
set tst [expr $i + 1]
if { [llength $rack1mot] > $tst} {
anticollision add $i [lindex $rack1mot $i] \
[lindex $rack1target $i]
}
if { [llength $rack2mot] > $tst } {
anticollision add $i [lindex $rack2mot $i] \
[lindex $rack2target $i]
}
if { [llength $rack3mot] > $tst } {
anticollision add $i [lindex $rack3mot $i] \
[lindex $rack3target $i]
}
}
return
}
Publish sans2rack User
anticollision script sans2rack
#====================== PSI Motoren ===================================
Motor ome EL734 sans2 4000 3 1
Motor chi EL734 sans2 4000 3 2
Motor phi EL734 sans2 4000 3 3
Motor tilt EL734 sans2 4000 2 1
SicsAlias ome traz "These motors are used to drive SANS I translation table"
SicsAlias chi trax "while ome is sample z and chi is sample x (TG070704)"
#====================== Multi Motor Setup ==============================
MakeMulti detector
detector alias dz x
detector endconfig
SicsAlias detector dt
MakeMulti bs
bs alias dh x
bs alias dv y
bs endconfig
MakeMulti chamber
chamber alias sr omega
chamber alias stx x
chamber alias sty y
chamber alias sc c
chamber endconfig
MakeMulti gonio
gonio alias gu chi
gonio alias gl phi
gonio alias tu xu
gonio alias tl yu
gonio endconfig
MakeMulti table
table alias om om
table alias sz z
table alias sx x
table alias sy y
table endconfig#
#====================== HISTOGRAM MEMORY ================================
MakeCounter counter ecb ecb1
MakeECB tdc gpib 0 7
MakeHM banana tdc
banana configure dim0 128
banana configure dim1 128
banana configure rank 2
banana configure Counter counter
banana configure bank 0
banana configure map 9
banana configure range 0
banana configure n 0
banana configure ecb tdc
banana configure fill 0
banana configure mode HMXY
banana init
banana exponent 6
banana CountMode timer
banana preset 100
=========================== velocity selector ========================
set dorn(Host) psts233
set dorn(Port) 3004
set dorn(Channel) 4
set dorn(Timeout) 20000
set dorn(MinControl) 6500
VelocitySelector nvs tilt dornier2003 dorn
#VelocitySelector nvs tilt SIM
nvs add -20 28800
nvs add 3600 4500
nvs add 7800 10500
nvs add 21500 23500
nvs status
nvs interrupt 0
MakeSANSWave lambda nvs
emon unregister nvswatch
#===================================== auxiliary hardware ==============
set distoCON [gpib attach 0 14 0 13 0 1]
#--------- for the Hakle Feucht
MakeRS232Controller h50 psts233 3005
#===================================== data file writing ================
MakeNXScript
#===================================== install commands ==================
MakeDrive
MakeRuenBuffer
commandlog auto
MakePSDFrame
SerialInit
#--------- drive command
MakeDrive
SicsAlias drive dr
#----------- for adding scripted content to the status file
MakeTclInt bckintern
#----- alias for temperature
DefineAlias tt temperature
#=================================== load specific command files ===========
source $scriptroot/sans2com.tcl
source $scriptroot/hakle.tcl
source $scriptroot/hakle50.tcl
source $scriptroot/HaakeSetup.tcl
source $scriptroot/A1931Setup.tcl
source $scriptroot/sans2geometry.tcl
source $scriptroot/sans2measurement.tcl
source $scriptroot/sans2wavelength.tcl
source $scriptroot/scan_a.tcl
# initialisation for IPS-120 superconducting magnet power supply
# this definition does not harm other devices used through the same channel
ips init localhost 4000 7
#=================================== load display definition =============
#source $scriptroot/sans2dis.tcl
#=======================================================================
disto

334
sans2com.tcl
View File

@ -1,334 +0,0 @@
#-----------------------------------------------------------------------
# Scripts for the SANS-II Risoe instrument as installed at PSI.
#
# Initial version: Mark Koennecke, Febrary 2003
#----------------------------------------------------------------------
#source $root/log.tcl
#source $root/batch.tcl
source $root/nxsupport.tcl
if { [info exists sansinit] == 0 } {
set sansinit 1
Publish beamstop Spy
Publish stopmot User
# Publish collRead Spy #-----for debugging
# Publish collSet Spy #-----for debugging
Publish collimator Spy
Publish coll Spy
# Publis att Spy
Publish batchrun User
Publish LogBook User
Publish count User
Publish Repeat User
Publish storedata User
Publish disto Spy
Publish statusinfo Spy
Publish displaycontrol User
Publish displayunits User
Publish setdispar User
}
#======================== general useful stuff ======================
proc SplitReply { text } {
set l [split $text =]
return [lindex $l 1]
}
#======================== Collimator stuff ===========================
proc collRead args {
set res [ecb1 func 164 0 0 0 0]
set l [split $res]
return [expr ([lindex $l 1] << 8) + [lindex $l 0]]
}
#--------------------------------------------------------------------
proc collSet {val} {
switch $val {
1 { set d 0}
2 { set d 01}
3 { set d 03}
4 { set d 07}
5 { set d 017}
6 { set d 037}
default {
error "Invalid collimation length requested"
}
}
ecb1 func 148 $d 0 0 0
return OK
}
#--------------------------------------------------------------------
proc collimator args {
if { [llength $args ] < 1} {
#------------- read case
set res [collRead]
set res [expr $res & 255]
set length -1
switch $res {
0 { set length 1}
1 { set length 2}
3 { set length 3}
7 { set length 4}
15 { set length 5}
31 { set length 6}
default {
error "Unknown reply $res from colRead"
}
}
return [format "collimator = %f" $length]
} else {
#------------- set case
set rights [SplitReply [config myrights]]
if {$rights > 2} {
error "Insufficient rights to drive collimator"
}
return [collSet [lindex $args 0]]
}
}
#----------------------------------------------------------------------
proc coll args {
return collimator $args
}
#======================== Beamstop stuff ==============================
proc beamstop args {
#----- without arguments: request
if { [llength $args] < 1} {
set res [collRead 0]
if { ($res & 256) > 0 } {
return "0 in"
} else {
return "1 out"
}
}
#---- with arguments: change, but only with at least user privilege
set rights [SplitReply [config myrights]]
if {$rights > 2} {
error "Insufficient rights to drive beamstop"
}
switch [lindex $args 0] {
0 { set d 1}
in {set d 1}
1 {set d 0}
out {set d 0}
default{
error "Invalid beamstop requested"
}
}
ecb1 func 160 $d 0 0 0
return OK
}
#================================ stopmot ================================
proc stopmot args {
ecb1 func 132 0 0 0 0
}
#=============================== counting ===============================
proc count { {mode NULL } { preset NULL } } {
#----- 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 ret [catch {Success} msg]
set a [banana preset]
set aa [SplitReply $a]
set b [banana CountMode]
set bb [SplitReply $b]
set tt [sicstime]
set sn [SplitReply [sample]]
starttime [sicstime]
ClientPut [format " Starting counting in %s mode with a preset of %s" \
$bb $aa ]
ClientPut [format "Count started at %s" $tt]
ClientPut [format " sample name: %s" $sn]
#------- count
banana count
set ret [catch {Success} msg]
#------- StoreData
storedata
set ttt [sicstime]
if { $ret != 0 } {
ClientPut [format "Counting ended at %s" $ttt]
error [format "Counting ended with error: %s" $msg]
}
ClientPut [format "Counting ended at %s" $ttt]
ClientPut "Total Counts: [SplitReply [banana sum 0 128 0 128]]"
}
#---------------- Repeat -----------------------------------------------
proc repeat { num {mode NULL} {preset NULL} } {
for { set i 0 } { $i < $num } { incr i } {
count $mode $preset
}
}
#=================== Data File Writing =================================
proc writeBeforeSample args {
writeTextVar etitle title
writeTextVar etime starttime
nxscript puttext endtime [sicstime]
writeTextVar iname instrument
nxscript puttext sname SINQ, Paul Scherrer Institut
nxscript puttext stype Continuous flux spallation source
nxscript puttext vname Dornier velocity selector
set res [nvs list]
set l [split $res "\n"]
nxscript putfloat vrot [SplitReply [lindex $l 0]]
writeFloatVar vtilt tilt
writeFloatvar vlambda lambda
writeFloatVar colli collimator
# writeFloatVar atti attenuator
}
#--------------------------------------------------------------------
proc writeSample args {
writeTextVar san sample
writeTextVar stable sampletable
#------------- sample chamber
nxscript putmot charo sr
nxscript putmot chax stx
nxscript putmot chaz stz
nxscript putmot chac sc
#------------- goniometer
nxscript putmot goniox tu
nxscript putmot gonioy tl
nxscript putmot goniochi gu
nxscript putmot goniophi gl
#------------- xyz-table
nxscript putmot tablex sx
nxscript putmot tabley sy
nxscript putmot tablez sz
nxscript putmot tableom om
#------------ sans1table
nxscript putmot sans1chi chi
nxscript putmot sans1om ome
#---------- environment
if { [catch {set tmp [SplitReply [temperature]]} tmp] == 0} {
nxscript putfloat satemp $tmp
}
if { [catch {set tmp [SplitReply [magnet]]} tmp] == 0} {
nxscript putfloat samag $tmp
}
writeTextVar saenv environment
}
#----------------------------------------------------------------------
proc writeAfterSample args {
#-------- beamstop
nxscript putmot vsx dh
nxscript putmot vsy dv
set tst [beamstop]
if { [string first in $tst] >= 0} {
nxscript putfloat bspos 0
} else {
nxscript putfloat bspos 1.
}
#------- counter
nxscript putcounter cter counter
#------- detector
nxscript putmot ddx dz
nxscript puthm ddcounts banana
for { set i 0} { $i < 128} {incr i} {
set detar($i) [expr -64. + $i]
}
nxscript putarray ddcx detar 128
nxscript putarray ddcy detar 128
}
#----------------------------------------------------------------------
proc makeLinks args {
nxscript makelink dan ddcounts
nxscript makelink dan ddcx
nxscript makelink dan ddcy
}
#-----------------------------------------------------------------------
proc storedata args {
global root
set filnam [makeFileName]
clientput [format "Writing %s" $filnam]
nxscript create5 $filnam $root/sans2.dic
writeStandardAttributes $filnam
writeBeforeSample
writeSample
writeAfterSample
makeLinks
nxscript close
}
#========================= laser distance reading ========================
proc disto args {
global distoCON
gpib sendwithterm $distoCON a 13
gpib readtillterm $distoCON 10
gpib sendwithterm $distoCON g 13
set result [gpib readtillterm $distoCON 10]
set l [split $result " +" ]
return [string trim [lindex $l 1] 0]
}
#========================= helper function for status display ============
proc statusinfo {} {
append result "SICS = " [SplitReply [status]] " \n"
append result [title] " \n"
append result [sample] " \n"
append result [user] " \n"
set tst [nvs list]
set l [split $tst "\n"]
append result "Velocity selector rotation = " \
[SplitReply [lindex $l 0]] " \n"
append result "lambda = " [SplitReply [lambda]] " \n"
append result "Collimation length = " [SplitReply [collimator]] " \n"
append result "filenumber = " [SplitReply [sicsdatanumber]] " \n"
return $result
}
#============= scripts for controlling the ECB display unit ============
proc disloadpar {unit offset val} {
ecb1 func 166 0 [expr $unit -1] $offset $val
}
#-----------------------------------------------------------------------
proc startdisplay {} {
ecb1 func 128 0 0 0 1
}
#----------------------------------------------------------------------
proc stopdisplay {} {
ecb1 func 129 0 0 0 0
}
#-----------------------------------------------------------------------
proc setdispar {unit name key parnum} {
switch $key {
timer {set type 1}
scaler {set type 2}
ratemeter {set type 4}
motor {set type 3}
encoder {set type 5}
default {
error "Unknown parameter key"
}
}
stopdisplay
disloadpar $unit 0 [ecb1 toint [string index $name 0]]
disloadpar $unit 1 [ecb1 toint [string index $name 1]]
disloadpar $unit 2 [ecb1 toint [string index $name 2]]
disloadpar $unit 3 $parnum
disloadpar $unit 4 $type
startdisplay
}
#--------------------------------------------------------------------------
proc cleardisplay {} {
ecb1 func 131 0 0 0 0
}
#-------------------------------------------------------------------------
proc defdisplay { num} {
ecb1 func 166 1 $num 0 0
}
#------------------------------------------------------------------------
proc displayunits { u1 u2 u3 u4} {
ecb1 func 130 $u1 $u2 $u3 $u4
}
#-----------------------------------------------------------------------
proc displaycontrol {command} {
ecb1 func 170 0 0 $command 0
}

39
sans2dis.tcl
View File

@ -1,39 +0,0 @@
#--------------------------------------------------------------------------
# display control file for SANS-II
#
# A place of genuine mystery and magic hacked from the appropriate TASCOM
# file.
#
# Mark Koennecke, February 2003
#------------------------------------------------------------------------
setdispar 1 RmS ratemeter 1
setdispar 2 RmM ratemeter 1
setdispar 3 RmF ratemeter 1
setdispar 4 MON scaler 1
setdispar 5 TIM timer 0
setdispar 6 "I " scaler 2
setdispar 7 "sr " motor 1
setdispar 8 stx motor 2
setdispar 9 stz motor 3
setdispar 10 "sc " motor 4
setdispar 11 "gu " motor 5
setdispar 12 "gl " motor 6
setdispar 13 "tu " motor 7
setdispar 14 "tl " motor 8
setdispar 15 "om " encoder 1
setdispar 16 "sz " motor 10
setdispar 17 "sx " motor 11
setdispar 18 "sy " motor 12
setdispar 19 "dz " motor 13
setdispar 20 "dh " motor 14
setdispar 21 "dv " motor 15
setdispar 22 at1 motor 16
setdispar 23 at2 motor 17
setdispar 24 aux scaler 3
setdispar 25 "I4 " scaler 4
setdispar 26 "I5 " scaler 5
setdispar 27 "I6 " scaler 6
setdispar 28 RdS ratemeter 2
setdispar 29 RdM ratemeter 2
setdispar 30 RdF ratemeter 2

168
sansreal.tcl
View File

@ -1,168 +0,0 @@
# --------------------------------------------------------------------------
# Initialization script the instrument SANS at SINQ
#
# Dr. Mark Koennecke, June 1997
#---------------------------------------------------------------------------
# O P T I O N S
# first all the server options are set
ServerOption SaveFile sansstat.tcl
# File to save the status of the instrument too
ServerOption ReadTimeOut 10
# timeout when checking for commands. In the main loop SICS checks for
# pending commands on each connection with the above timeout, has
# PERFORMANCE impact!
ServerOption AcceptTimeOut 10
# timeout when checking for connection req.
# Similar to above, but for connections
ServerOption ReadUserPasswdTimeout 500000
# time to wiat for a user/passwd to be sent from a client. Increase this
# if there is a problem connecting to a server due to network overload\
ServerOption LogFileBaseName /tmp/sanslog
# the path and base name of the internal server logfile to which all
# activity will be logged.
ServerOption ServerPort 2915
# the port number the server is going to listen at. The client MUST know
# this number in order to connect. It is in client.ini
ServerOption InterruptPort 2917
# The UDP port where the server will wait for Interrupts from clients.
# Obviously, clients wishing to interrupt need to know this number.
#---------------------------------------------------------------------------
# U S E R S
# than the SICS users are specified
# Syntax: SicsUser name password userRightsCode
SicsUser Manager Joachim 1
SicsUser User Kohl 2
SicsUser Spy 007 3
#--------------------------------------------------------------------------
# S I M P L E V A R I A B L E S
# now a few general variables are created
# Syntax: VarMake name type access
# type can be one of: Text, Int, Float
#access can be one of: Internal, Mugger, user, Spy
VarMake Instrument Text Internal
Instrument "SANS at SINQ,PSI"
#initialisation
VarMake Title Text User
VarMake User Text User
User "Albert von Villigen"
VarMake SubTitle Text User
VarMake environment Text User
VarMake comment Text User
#--------------------------------------------------------------------------
# D E V I C E S : M O T O R S
#Motor a4 EL734 LNSP22 4000 5 6
# EL734 motor with parameters: hostname PortNumber Channel MotorID
#Motor a4 EL734DC LNSP22 4000 5 6
# EL734DC motor with parameters: hostname PortNumber Channel MotorID
# Motor nam SIM -20. 20. 5. 1.0
# Simulated motor with name nam, lower limit -20, upper limit +20,
# error ratio 5% and speed 1.0. Speed may be omitted
# Motors for sample movement
Motor schi SIM -22.0 +22.0 10.
Motor sphi SIM -22.0 +22.0 10.
Motor som SIM -180.0 360.0 10.
Motor sax SIM -30.0 +30.0 10.
Motor say SIM -22.0 +22.0 10.
Motor saz SIM .0 30.0 10.
#Motors for detector movement
Motor DetectorX EL734DC lnsp25.psi.ch 4000 3 1
DetectorX Precision 0.5
Motor DetectorY EL734DC lnsp25.psi.ch 4000 3 2
DetectorY Precision 0.2
Motor DetectorRotation EL734DC lnsp25.psi.ch 4000 3 3
DetectorRotation Precision 0.1
#Motors for beamstop
Motor BeamStopX EL734 lnsp25.psi.ch 4000 2 3
BeamStopX Precision 0.2
Motor BeamStopY EL734 lnsp25.psi.ch 4000 2 4
BeamStopY Precision 0.2
#--------------------------------------------------------------------------
# P R O C E D U R E S
# create the drive command
MakeDrive
#--------------------------------------------------------------------------
# MultiMotor is an object which groups several motors together.
#--------------------------------- sample position
MakeMulti sample
# creates a MultiMotor with name sample
sample alias schi chi
# alias creates an internal name (chi) for motor schi
sample alias sphi phi
sample alias som omega
sample alias sax x
sample alias say y
sample alias saz z
sample pos Jo schi 0. sphi 0. som 45. sax 2. say 3. saz 10.
# define Jo as a named position. This means with sample Jo you'll reach
# the positions specified
sample pos Mo schi 0. sphi 0. som 180. sax 2. say 3. saz 10.
sample endconfig
# ends configuration of sample and install the command. This is REQUIRED
#---------------------------------- detector position
MakeMulti detector
detector alias DetectorX X
detector alias DetectorY Y
detector alias DetectorRotation phi
detector endconfig
#----------------------------------- beamstop
MakeMulti BeamStop
BeamStop alias BeamStopX X
BeamStop alias BeamStopY Y
BeamStop pos out BeamStopX 817.
BeamStop endconfig
#------------------------------------ Shortcuts
SicsAlias BeamStop bs
SicsAlias detector dt
#------------------------------------ Histogram Memory
MakeCounter counter EL737 lnsp25.psi.ch 4000 4
counter SetExponent 6
MakeHM banana SINQHM
banana configure HistMode Normal
banana configure OverFlowMode Ceil
banana configure Rank 1
banana configure Length 16384
banana configure BinWidth 4
banana preset 100.
banana CountMode Timer
banana configure HMComputer lnse02.psi.ch
banana configure HMPort 2400
banana configure Counter counter
banana init
banana exponent 6
#-----------------------------------------------------------------------------
# R U E N B U F F E R
MakeRuenBuffer
source /data/kohlb/bin/sics/log.tcl
Publish LogBook User
source /data/kohlb/bin/sics/count.tcl
Publish count User

77
servo.tcl
View File

@ -1,77 +0,0 @@
# --------------------------------------------------------------------------
# Initialization script for testing the SICS server. Also example for how
# such an insane script might look like,
#
# Dr. Mark Koennecke November 1996
#---------------------------------------------------------------------------
# O P T I O N S
# first all the server options are set
ServerOption ReadTimeOut 100
# timeout when checking for commands. In the main loop SICS checks for
# pending commands on each connection with the above timeout, has
# PERFORMANCE impact!
ServerOption AcceptTimeOut 100
# timeout when checking for connection req.
# Similar to above, but for connections
ServerOption ReadUserPasswdTimeout 500000
# time to wiat for a user/passwd to be sent from a client. Increase this
# if there is a problem connecting to a server due to network overload\
ServerOption ServerLogBaseName /data/koenneck/src/sics/server
# the path and base name of the internal server logfile to which all
# activity will be logged.
ServerOption ServerPort 2910
# the port number the server is going to listen at. The client MUST know
# this number in order to connect. It is in client.ini
ServerOption InterruptPort 2913
# The UDP port where the server will wait for Interrupts from clients.
# Obviously, clients wishing to interrupt need to know this number.
#---------------------------------------------------------------------------
# U S E R S
# than the SICS users are specified
# Syntax: SicsUser name password userRightsCode
SicsUser Mugger Diethelm 1
SicsUser User Rosy 2
SicsUser Spy 007 3
#--------------------------------------------------------------------------
# S I M P L E V A R I A B L E S
# now a few general variables are created
# Syntax: VarMake name type access
# type can be one of: Text, Int, Float
#access can be one of: Internal, Mugger, user, Spy
VarMake Instrument Text Internal
Instrument set "Druechal" #initialisation
VarMake Title Text User
VarMake User Text User
User set "Albert von Villigen"
#--------------------------------------------------------------------------
# D E V I C E S : M O T O R S
# Motor a4 EL734 LNSP22 4000 5 6
# EL734 motor with parameters: hostname PortNumber Channel MotorID
Motor s5 SIM -22.0 +22.0 90.
#--------------------------------------------------------------------------
# C O N F I G U R E D E V I C E S T O H A L T I N
# I N T E R R U P T
AddHalt a4 s5 s6
#--------------------------------------------------------------------------
# P R O C E D U R E S
MakeDrive
MakeCounter simpel SIM

295
sicsstat.tcl
View File

@ -1,295 +0,0 @@
exe batchpath ./
exe syspath ./
#--- BEGIN (commands producing errors on last restore)
#--- END (commands producing errors on last restore)
# Counter counter
counter SetPreset 3.000000
counter SetMode Timer
title UNKNOWN
title setAccess 2
user Uwe Filges
user setAccess 2
address UNKNOWN
address setAccess 2
adress UNKNOWN
adress setAccess 2
phone UNKNOWN
phone setAccess 2
email UNKNOWN
email setAccess 2
affiliation UNKNOWN
affiliation setAccess 2
countrate 0.000000
countrate setAccess 2
t2tx targetposition 0
t2tx sign 1
t2tx softzero 0
t2tx softlowerlim 0
t2tx softupperlim 2000
t2tx fixed -1
t2tx interruptmode 0
t2tx precision 0.01
t2tx accesscode 2
t2tx failafter 3
t2tx maxretry 3
t2tx ignorefault 0
t2tx movecount 10
t2ty targetposition 0
t2ty sign 1
t2ty softzero 0
t2ty softlowerlim 0
t2ty softupperlim 100
t2ty fixed -1
t2ty interruptmode 0
t2ty precision 0.01
t2ty accesscode 2
t2ty failafter 3
t2ty maxretry 3
t2ty ignorefault 0
t2ty movecount 10
sdw 0.000000
sdw setAccess 2
sdh 0.000000
sdh setAccess 2
t3tx targetposition 0
t3tx sign 1
t3tx softzero 0
t3tx softlowerlim 0
t3tx softupperlim 2000
t3tx fixed -1
t3tx interruptmode 0
t3tx precision 0.01
t3tx accesscode 2
t3tx failafter 3
t3tx maxretry 3
t3tx ignorefault 0
t3tx movecount 10
rt3 targetposition 0
rt3 sign 1
rt3 softzero 0
rt3 softlowerlim -180
rt3 softupperlim 180
rt3 fixed -1
rt3 interruptmode 0
rt3 precision 0.01
rt3 accesscode 2
rt3 failafter 3
rt3 maxretry 3
rt3 ignorefault 0
rt3 movecount 10
sew 0.000000
sew setAccess 2
seh 0.000000
seh setAccess 2
t4tx targetposition 0
t4tx sign 1
t4tx softzero 0
t4tx softlowerlim 500
t4tx softupperlim 12000
t4tx fixed -1
t4tx interruptmode 0
t4tx precision 0.01
t4tx accesscode 2
t4tx failafter 3
t4tx maxretry 3
t4tx ignorefault 0
t4tx movecount 10
t4ty targetposition 0
t4ty sign 1
t4ty softzero 0
t4ty softlowerlim 0
t4ty softupperlim 3000
t4ty fixed -1
t4ty interruptmode 0
t4ty precision 0.01
t4ty accesscode 2
t4ty failafter 3
t4ty maxretry 3
t4ty ignorefault 0
t4ty movecount 10
gau targetposition 0
gau sign 1
gau softzero 0
gau softlowerlim -25
gau softupperlim 25
gau fixed -1
gau interruptmode 0
gau precision 0.01
gau accesscode 2
gau failafter 3
gau maxretry 3
gau ignorefault 0
gau movecount 10
gal targetposition 0
gal sign 1
gal softzero 0
gal softlowerlim -25
gal softupperlim 25
gal fixed -1
gal interruptmode 0
gal precision 0.01
gal accesscode 2
gal failafter 3
gal maxretry 3
gal ignorefault 0
gal movecount 10
t5tx targetposition 0
t5tx sign 1
t5tx softzero 0
t5tx softlowerlim 500
t5tx softupperlim 12000
t5tx fixed -1
t5tx interruptmode 0
t5tx precision 0.01
t5tx accesscode 2
t5tx failafter 3
t5tx maxretry 3
t5tx ignorefault 0
t5tx movecount 10
t5ty targetposition 0
t5ty sign 1
t5ty softzero 0
t5ty softlowerlim 0
t5ty softupperlim 3000
t5ty fixed -1
t5ty interruptmode 0
t5ty precision 0.01
t5ty accesscode 2
t5ty failafter 3
t5ty maxretry 3
t5ty ignorefault 0
t5ty movecount 10
sal targetposition 0
sal sign 1
sal softzero 0
sal softlowerlim -30
sal softupperlim 30
sal fixed -1
sal interruptmode 0
sal precision 0.01
sal accesscode 2
sal failafter 3
sal maxretry 3
sal ignorefault 0
sal movecount 10
sar targetposition 0
sar sign 1
sar softzero 0
sar softlowerlim -30
sar softupperlim 30
sar fixed -1
sar interruptmode 0
sar precision 0.01
sar accesscode 2
sar failafter 3
sar maxretry 3
sar ignorefault 0
sar movecount 10
sab targetposition 0
sab sign 1
sab softzero 0
sab softlowerlim -30
sab softupperlim 30
sab fixed -1
sab interruptmode 0
sab precision 0.01
sab accesscode 2
sab failafter 3
sab maxretry 3
sab ignorefault 0
sab movecount 10
sat targetposition 0
sat sign 1
sat softzero 0
sat softlowerlim 0
sat softupperlim 1000
sat fixed -1
sat interruptmode 0
sat precision 0.01
sat accesscode 2
sat failafter 3
sat maxretry 3
sat ignorefault 0
sat movecount 10
t6tx targetposition 0
t6tx sign 1
t6tx softzero 0
t6tx softlowerlim 500
t6tx softupperlim 12000
t6tx fixed -1
t6tx interruptmode 0
t6tx precision 0.01
t6tx accesscode 2
t6tx failafter 3
t6tx maxretry 3
t6tx ignorefault 0
t6tx movecount 10
t6ty targetposition 0
t6ty sign 1
t6ty softzero 0
t6ty softlowerlim 0
t6ty softupperlim 3000
t6ty fixed -1
t6ty interruptmode 0
t6ty precision 0.01
t6ty accesscode 2
t6ty failafter 3
t6ty maxretry 3
t6ty ignorefault 0
t6ty movecount 10
sbl targetposition 0
sbl sign 1
sbl softzero 0
sbl softlowerlim -30
sbl softupperlim 30
sbl fixed -1
sbl interruptmode 0
sbl precision 0.01
sbl accesscode 2
sbl failafter 3
sbl maxretry 3
sbl ignorefault 0
sbl movecount 10
sbr targetposition 0
sbr sign 1
sbr softzero 0
sbr softlowerlim -30
sbr softupperlim 30
sbr fixed -1
sbr interruptmode 0
sbr precision 0.01
sbr accesscode 2
sbr failafter 3
sbr maxretry 3
sbr ignorefault 0
sbr movecount 10
sbb targetposition 0
sbb sign 1
sbb softzero 0
sbb softlowerlim -30
sbb softupperlim 30
sbb fixed -1
sbb interruptmode 0
sbb precision 0.01
sbb accesscode 2
sbb failafter 3
sbb maxretry 3
sbb ignorefault 0
sbb movecount 10
sbt targetposition 0
sbt sign 1
sbt softzero 0
sbt softlowerlim 0
sbt softupperlim 1000
sbt fixed -1
sbt interruptmode 0
sbt precision 0.01
sbt accesscode 2
sbt failafter 3
sbt maxretry 3
sbt ignorefault 0
sbt movecount 10
hm preset 12
hm mode timer

10
sicsstatus.tcl
View File

@ -1,10 +0,0 @@
# Motor m4
m4 sign 1.000000
m4 SoftZero 0.000000
m4 SoftLowerLim -22.004999
m4 SoftUpperLim 21.995001
m4 Fixed -1.000000
m4 InterruptMode 0.000000
m4 precision 0.010000
m4 AccessCode 2.000000
m4 poscount 10.000000

107
sicstemplates.tcl
View File

@ -1,107 +0,0 @@
#----------------------------------------------------------------------------
# This file contaisn template generation code for SICS programming
#
# copyright: see file COPYRIGHT
#
# Mark Koennecke, December 2006
#----------------------------------------------------------------------------
proc stdIncludes {} {
append txt "#include <stdlib.h>\n"
append txt "#include <assert.h>\n"
append txt "#include <sics.h>\n"
append txt "#include <splitter.h>\n"
}
#---------------------------------------------------------------------------
proc makeSicsFunc {name} {
append txt "int ${name}(SConnection *pCon,SicsInterp *pSics, void *pData,\n"
append txt " int argc, char *argv\[\])"
return $txt
}
#----------------------------------------------------------------------------
proc newStruc {name indent} {
set pre [string repeat " " $indent]
append txt "pNew = malloc(sizeof($name));\n"
append txt $pre "if(pNew == NULL){\n"
append txt $pre " return NULL;\n"
append txt $pre "}\n"
append txt $pre "memset(pNew,0,sizeof($name));\n"
return $txt
}
#----------------------------------------------------------------------------
proc newStrucRet {name indent retval} {
set pre [string repeat " " $indent]
append txt "pNew = malloc(sizeof($name));\n"
append txt $pre "if(pNew == NULL){\n"
append txt $pre " return $retval;\n"
append txt $pre "}\n"
append txt $pre "memset(pNew,0,sizeof($name));\n"
return $txt
}
#-----------------------------------------------------------------------------
proc testNoPar {noPar indent} {
set pre [string repeat " " $indent]
append txt "if(argc < $noPar){\n"
append txt $pre " SCWrite(pCon,\"ERROR: Not enough arguments\",eError);\n"
append txt $pre " return 0;\n"
append txt $pre "}\n"
return $txt
}
#-------------------------------------------------------------------------------
proc testPriv {priv indent} {
set pre [string repeat " " $indent]
append txt "if(!SCMatchRights(pCon,$priv)){\n"
append txt $pre " return 0;\n"
append txt $pre "}\n"
return $txt
}
#--------------------------------------------------------------------------------
proc sicsPar {parName parCName noPar priv type indent} {
set pre [string repeat " " $indent]
append txt "if(argc < $noPar) {\n"
switch $type {
int {
append txt $pre
append txt " snprintf(buffer,512,\"%s.%s = %d\", argv\[0\], \"$parName\", $parCName);\n"
}
float {
append txt $pre
append txt " snprintf(buffer,512,\"%s.%s = %f\", argv\[0\], \"$parName\", $parCName);\n"
}
text {
append txt $pre
append txt " snprintf(buffer,512,\"%s.%s = %s\", argv\[0\], \"$parName\", $parCName);\n"
}
default {
error "$type is unknown"
}
}
append txt $pre "} else {\n"
append txt $pre " " [testPriv $priv [expr $indent + 4]]
set n [expr $noPar -1]
switch $type {
int {
append txt $pre " status = sscanf(argv\[$n\],\"%d\",&$parCName);\n"
}
float {
append txt $pre " status = sscanf(argv\[$n\],\"%f\",&$parCName);\n"
}
text {
append txt $pre " if($parCName != NULL){\n"
append txt $pre " free($parCName);\n"
append txt $pre " }\n"
append txt $pre " $parCName = strdup(argv\[$n\]);\n"
append txt $pre " status = 1;\n"
}
}
append txt $pre " if(status != 1) {\n"
append txt $pre " snprintf(buffer,512,"
append txt "\"ERROR: failed to convert %s to $type\",argv\[$n\]);\n"
append txt $pre " SCWrite(pCon,buffer,eError);\n"
append txt $pre " return 0;\n"
append txt $pre " } else {\n"
append txt $pre " SCSendOK(pCon);\n"
append txt $pre " return 1;\n"
append txt $pre " }\n"
append txt $pre "}"
return $txt
}

387
sinfo.tcl
View File

@ -1,387 +0,0 @@
# requires stooop package from tcllib
# loaded from sycamore.tcl
proc arga argStr {
set args [ split $argStr ]
set argc [llength $args]
# syc::debug "arga.argc = %s" $argc
set objName ""
set key ""
set name ""
set val ""
set bObj [expr $argc > 0]
set bKey [expr $argc > 1]
set bName [expr $argc > 2]
set bVal [expr $argc > 3]
if $bObj {
set objName [string tolower [lindex $args 0]]
#syc::debug "arga.objName = %s" $objName
}
if $bKey {
set key [string tolower [lindex $args 1]]
#syc::debug "arga.key = %s" $key
}
if $bName {
set name [string tolower [lindex $args 2]]
}
if $bVal {
set val [string tolower [lindex $args 3]]
}
# ? cannot get 'array set' to work in the form:
# array set argv {
# argc $argc
# objName $objName
# ... etcetera
# }
set argv(argc) $argc
set argv(bObj) $bObj
set argv(bKey) $bKey
set argv(bName) $bName
set argv(bVal) $bVal
set argv(objName) $objName
set argv(key) $key
set argv(name) $name
set argv(val) $val
# would like to return associative array
# for now, settle for list
# syc::debug "arga.argv = { %s }" [array get argv]
return [array get argv]
}
# -----------------------------------------------------------------------------
class sinfo { ;# base class definition
proc sinfo {this} { ;# base class constructor
# non-static data member initialisation
set ($this,objectID) $this
}
proc ~sinfo {this} {} ;# base class destructor
proc id {this} {
return [format "sin.objectID = \{ %s \}" $($this,objectID)]
}
# static data member variables
# set File default.dat
set delimiter ", "
set debug 0
set init 0
set name "sinfo"
set usage {sinfo init|diag|config|server|device|command [parameter]}
set version 0.6
class server {
proc server {this name} {
set ($this,name) $name
proc name {this} {
return [format "server.name = \{ %s \}" $($this,name)]
}
}
proc ~server {this} {}
}
class sinfot {
proc sinfot {this} {}
proc ~sinfot {this} {}
}
proc helpMsgStr args {
return [formatMsg $sinfo::name "usage" $sinfo::usage]
}
proc debug args {
if {$sinfo::debug < 1} {
return
}
set l [llength $args]
set dMsg "Script code event"
set dVal " "
if {$l > 0} {
set dMsg [lindex $args 0]
if {$l > 1} {
set dVal [lindex $args 1]
}
}
sinWrite [format "sinfo::debug: %s" [format $dMsg $dVal]] "value"
}
proc diag args {
set flag [lindex $args 0]
set msg [format "diag=%s" $flag]
switch $flag {
"on" {
set sinfo::debug 1
}
"off" {
set sinfo::debug 0
}
default {
if {1 == $sinfo::debug} {
set msg "diag=on"
} else {
set msg "diag=off"
}
}
}
return [format "sinfo.diag = \{ %s \}" $msg]
}
proc formatMsg {objName parName msg} {
# return [format "%s.%s = \{ %s \}" $objName $parName $msg]
# set msgStr [format "%s.%s = %s " $objName $parName $msg]
#sinWrite "DEBUG formatMsg: msg = $msg" "value"
return "$objName.$parName=$msg"
}
proc writeObjPar {objName parName} {
return [format "%s.%s = \{ %s \}" \
$objName $parName [set ::$objName::$parName]]
}
proc writeError {objName msg} {
# return [format "%s.error = \{ %s \}" $objName $msg]
set msg [format "%s.error = \{ %s \}" $objName $msg]
sinWrite $msg "error"
return $msg
}
proc writeNspPar {objName parName} {
set result ::
append result $objName :: $parName
# return [format "%s.%s = \{ %s \}" $objName $parName [set $result]]
sinWrite [format "%s" [set $result]] "value"
}
proc writeList {objName parName parList} {
# return [format "%s.%s = %s " $objName $parName \
# [join $parList $sinfo::delimiter]]
set msg [format "%s" [join $parList $sinfo::delimiter]]
sinWrite $msg "value"
#return $msg
}
proc writeNamespaceChildren {obj key nsp} {
set chList {}
set nameList {}
set chList [namespace children $nsp]
set l [llength $chList]
for {set i 0} {$i < $l} {incr i} {
lappend nameList [namespace tail [lindex $chList $i]]
}
writeList $obj $key $nameList
}
proc writeNamespaceList {obj key nsp} {
set nameList {}
foreach v [info vars ${nsp}::*] {
lappend nameList [namespace tail $v]
}
writeList $obj $key $nameList
}
}
proc sinfo::server args {
array set argv [arga $args]
debug "sinfo::server, server.argv = { %s }" [array get argv]
set parSet {}
set parNames {}
if {$argv(bKey)} {
set key $argv(key)
debug "sinfo::server, key = $key"
switch $key {
"connection" -
"experiment" -
"help" -
"key" -
"list"
{
debug "sinfo::server, in switch $key, sinfox list server $key"
set nameList [sinfox list server $key]
sinfo::writeList "server" $key $nameList
}
"command" -
"device" -
"devicetype" -
"group" -
"interface"
{
if {$argv(bName)} {
set name $argv(name)
debug "sinfo::server, using name $name"
#sinWrite [format "DEBUG: if bname, key = %s, name = %s" $key $name] "value"
set nameList [sinfox list server $key $name]
sinfo::writeList "server" $name $nameList
#todo: improve response for unknown name
# eg server.error={device=foo}
} else {
set nameList [sinfox list server $key]
debug "sinfo::server, key=$key, nameList = $nameList"
sinfo::writeList "server" $key $nameList
}
}
"gtdevice"
{
if {$argv(bName)} {
set name $argv(name)
if [info exists ::server::gtDeviceList::$name] {
sinfo::writeNspPar server::gtDeviceList $name
} else {
set msg [format "key=%s.%s" "server" $key]
return [sinfo::writeList "server" error $msg]
}
} else {
writeList "server" $key [gumtree::gtDeviceList]
# sinfo::writeNamespaceList "server" $key \
# [ ::server::gtDeviceList
}
}
default {
puts default
if [info exists ::server::$key] {
sinfo::writeNspPar server $key
} else {
set msg [format "key=%s.%s" "server" $key]
return [sinfo::writeList "server" error $msg]
}
}
}
} else {
# writeNamespaceList $objName
set nameList [sinfox list server list]
writeList "server" "list" $nameList
}
}
proc sinfo::checkType {objName} {
if { [string compare -nocase $objName server] == 0 } then {
set return "server"
} elseif { [string compare -nocase $objName sequencer] == 0 } then {
set return "sequencer"
} else {
switch [SICSType $objName] {
COUNT -
DRIV { return "device" }
COM { return "command" }
TEXT { return "object" }
default { return "unknown" }
}
}
}
proc sinfo::list args {
array set argv [arga $args]
debug "sinfo.argv = { %s }" [array get argv]
set argc [llength $args]
set objName $argv(objName)
set key $argv(key)
set name $argv(name)
sinfo::debug "sinfo.numargs = %s" $argc
if {$argc < 1} {
sinWrite [sinfo::helpMsgStr] "value"
return
}
sinfo::debug "object = %s" $argv(objName)
if $argv(bKey) {
sinfo::debug "key = %s" $argv(key)
}
if $argv(bName) {
sinfo::debug "name = %s" $argv(name)
}
set parList {}
set numPars 0
set objType [checkType $objName]
sinfo::debug "sinfo.objectType = %s" $objType
switch $objType {
device
{
set nameList [sinfox list $objName $key $name]
writeList $objName $key $nameList
}
command
{
debug "sinfo.message = { %s is command objectType}" $objName
}
server
{
set cmd [format "sinfo::server %s %s %s %s" \
$objName $key $argv(name) $argv(val)]
return [eval $cmd]
}
sequencer
{
debug "sinfo.message = { %s is sequencer objectType}" $objName
if {$argv(bKey)} {
set key $argv(key)
switch $key {
"command"
{
if $bName {
set target [format "::sequencer::%s" $name]
sinfo::writeNamespaceList $objName $name $target
} else {
sinfo::writeNamespaceChildren $objName \
$key ::sequencer
}
}
default
{
}
}
} else {
sinfo::writeNamespaceList "sequencer" "list" "::sequencer"
}
}
object
{
# todo: test for interface name
switch $objName {
default {
writeError "sinfo" \
[format "'%s' is invalid object" $objName]
}
}
}
unknown -
default {
writeError "sinfo" [format "'%s' has invalid object type" $objName]
}
}
}
# -----------------------------------------------------------------------------
# wrapper procs for sinfo class
proc sinfo args {
set l [llength $args]
if {$l < 1} {
sinWrite [sinfo::helpMsgStr] "value"
return
}
set arglist [ split $args ]
set objName [lindex $arglist 0]
set cmd [format "sinfo::%s $args" $objName]
#sinWrite "DEBUG: $cmd" "value"
# set cmd $args
#set cmd "sinfo::list $args"
#FIXME the command should provide the output code for sinWrite
#sinWrite [eval $cmd] "value"
eval $cmd
}
proc sin args {
set argc [llength $args]
if {$argc < 1} {
set msg \
"sin.usage = \
{ sin \[server|sequencer|device|command\] \[parameter\] }"
sinWrite $msg "value"
} else {
sinWrite [sinfo::list $args] "value"
}
}

7
stest.tcl
View File

@ -1,7 +0,0 @@
scan clear
scan np 10
scan var A4 20. 2.
scan preset 10
for {set i 0 } { $i < 2000 } { incr i} {
scan run
}

219
sycamore.tcl
View File

@ -1,219 +0,0 @@
#source $sychome/stooop/mkpkgidx.tcl
#source stooop.tcl
#set tcl_pkgPath $sychome
# ClientPut $tcl_pkgPath "value"
# package require stooop 4 ;# load stooop package
# namespace forget stooop::* ;# remove if previously loaded
# namespace import stooop::*
# -----------------------------------------------------------------------------
# source $sychome/ns_site.tcl
# source $sychome/ns_sequencer.tcl
# source $sychome/ns_server.tcl
set STACKTRACE 0
proc stackTrace args {
set level [ info level ]
ClientPut "====================" "value"
for {set i 1} {$i < $level} {incr i} {
ClientPut [info level $i] "value"
ClientPut " " "value"
}
ClientPut "====================" "value"
}
# -----------------------------------------------------------------------------
# testing stubs when SICS modules not available
# proc sinfox args
# proc ClientPut {msg oCode}
# proc SICSType {objName}
# source stubs.tcl
# -----------------------------------------------------------------------------
# Sycamore Utilities: tcl procedures required by sycamore implementation
proc sinWrite {msg oCode} {
# simplest processing of format for now
global STACKTRACE
if {$STACKTRACE} {
stackTrace
}
ClientPut $msg $oCode
}
proc varexist {nsp var} {
return [expr [string compare $nsp$var [namespace which -variable $nsp$var]]==0]
}
#proc sycFormat {connID transID devID msgFlag args} {
# return "\[$connID:$transID:$devID:$msgFlag\] $args"
#}
#source $sychome/sycFormat.tcl
#publish sycFormat spy
proc arga argStr {
set args [ split $argStr ]
set argc [llength $args]
# syc::debug "arga.argc = %s" $argc
set objName ""
set key ""
set name ""
set val ""
set bObj [expr $argc > 0]
set bKey [expr $argc > 1]
set bName [expr $argc > 2]
set bVal [expr $argc > 3]
if $bObj {
set objName [string tolower [lindex $args 0]]
#syc::debug "arga.objName = %s" $objName
}
if $bKey {
set key [string tolower [lindex $args 1]]
#syc::debug "arga.key = %s" $key
}
if $bName {
set name [string tolower [lindex $args 2]]
}
if $bVal {
set val [string tolower [lindex $args 3]]
}
# ? cannot get 'array set' to work in the form:
# array set argv {
# argc $argc
# objName $objName
# ... etcetera
# }
set argv(argc) $argc
set argv(bObj) $bObj
set argv(bKey) $bKey
set argv(bName) $bName
set argv(bVal) $bVal
set argv(objName) $objName
set argv(key) $key
set argv(name) $name
set argv(val) $val
# would like to return associative array
# for now, settle for list
# syc::debug "arga.argv = { %s }" [array get argv]
return [array get argv]
}
# alternative solution for passing arguments around
#class argv {
# proc argv {this args} {
# set ($this,argc) [llength $args]
# set ($this,objName) ""
# set ($this,key) ""
# set ($this,name) ""
# set ($this,val) ""
# set ($this,bObj) [expr $l > 0]
# set ($this,bKey) [expr $l > 0]
# set ($this,bName) [expr $l > 1]
# set ($this,bVal) [expr $l > 2]
# if $($this,bObj) {
# set ($this,objName) [lindex $args 0]
# }
# if $($this,bKey) {
# set ($this,key) [lindex $args 0]
# }
# if $($this,bName) {
# set ($this,name) [lindex $args 1]
# }
# if $($this,bVal) {
# set ($this,val) [lindex $args 2]
# }
# }
# proc ~argv {this} {}
#}
#
## -----------------------------------------------------------------------------
# working idea for making diagnostic class global
class diagnostic {
proc diagnostic {this} {
set ($this,id) $this
set ($this,debug) 0
}
proc ~diagnostic {this} {}
proc diag {this flag} {
set msg [format "diag=%s" $flag]
switch $flag {
"on" {
set ($this,debug) 1
}
"off" {
set ($this,debug) 0
}
default {}
}
if {1 == ($this,debug)} {
set msg "diag=on"
} else {
set msg "diag=off"
}
return [format "%s.diag = \{ %s \}" $this $msg]
}
proc debug {this dMsg dVal} {
if {1 > ($this,debug)} {
return
}
sinWrite [format "%s::debug: %s" $this [format $dMsg $dVal]] "value"
}
}
## -----------------------------------------------------------------------------
# Class for module static variables and methods
class syc {
# class lifecycle methods
proc syc {this} {}
proc ~syc {this} {}
# static data members
set debug 0
# static methods
proc debug args {
if {$syc::debug < 1} {
return
}
set l [llength $args]
set dMsg "Script code event"
set dVal " "
if {$l > 0} {
set dMsg [lindex $args 0]
if {$l > 1} {
set dVal [lindex $args 1]
}
}
sinWrite [format "syc::debug: %s" [format $dMsg $dVal]] "value"
}
proc diag args {
set flag [lindex $args 0]
set msg [format "diag=%s" $flag]
switch $flag {
"on" {
set syc::debug 1
}
"off" {
set syc::debug 0
}
default {
if {1 == $syc::debug} {
set msg "diag=on"
} else {
set msg "diag=off"
}
}
}
return [format "syc.diag = \{ %s \}" $msg]
}
}
## -----------------------------------------------------------------------------
sinWrite "Loading sinfo" "value"
#source $sychome/sinfo.tcl
#publish sinfo spy
# source $sychome/sequencer.tcl

1177
tascom.tcl
View File

File diff suppressed because it is too large Load Diff

104
tasregress.tcl
View File

@ -1,104 +0,0 @@
#-------------------------------------------------------------------------
# Regression test for TAS
#
#-------------------------------------------------------------------------
config file simchal.log
#--------- zero points
A1 softzero .59
A2 softzero -.01
A3 softzero 11.54
A4 softzero -.71
A5 softzero 176.48
A6 softzero .04
MTU softzero 2.85
ATU softzero -.88
MGL softzero 1.3
SGL softzero 1.55
AGL softzero -.49
#------------- box parameters
DM 3.354
DA 3.354
SM 1
SS 1
SA -1
FX 2
NP 9
MRX1 .28
MRX2 10.42
ARX1 .15
ARX2 4.29
#----------- sample
AS 5.
BS 5.0
CS 5.0
AA 90.
BB 90.
CC 90.
AX 1.0
AY 0
AZ 0
BX 0
BY 1.
BZ 0
dr ef 8.0
output a1,a2,a3,a4
sc qh 2 0 0 3 dqh 0 0 0 0.05 np 9 ti 2
sc qh 2 0 0 3 dqh 0.01 0 0 .0
sc qh 2 0 0 3 dqh 0.01 0.01 0 .0
sc qh 2 0 0 3 dqh 0.01 0.01 0 .1
dr ei 8
fx 1
output a3,a4,a5,a6
sc qh 2 0 0 3 dqh 0 0 0 0.05 np 9 ti 2
sc qh 2 0 0 3 dqh 0.01 0 0 .0
sc qh 2 0 0 3 dqh 0.01 0.01 0 .0
sc qh 2 0 0 3 dqh 0.01 0.01 0 .1
fx 2
dr ef 8
cc 120
cs 10
output a1,a2,a3,a4
sc qh 2 0 0 3 dqh 0 0 0 0.05 np 9 ti 2
sc qh 2 0 0 3 dqh 0.01 0 0 .0
sc qh 2 0 0 3 dqh 0.01 0.01 0 .0
sc qh 2 0 0 3 dqh 0.01 0.01 0 .1
bz 1
by 0
sc qh 0 0 2 3 dqh 0 0 0 0.05 np 9 ti 2
sc qh 0 0 2 3 dqh 0.0 0.00 0.01 .0
sc qh 0 0 2 3 dqh 0.01 0.0 0.01 .0
sc qh 0 0 2 3 dqh 0.01 0.0 0.01 .1
dr ef 8 ei 8
output ach mcv
sc ei 8 dei .5 np 15
sc ef 8 dei .5 np 15
cs 7
bb 67.89
cc 90
dr ef 8
output a1,a2,a3,a4
sc qh 0 0 2 3 dqh 0 0 0 0.05 np 9 ti 2
sc qh 0 0 2 3 dqh 0.0 0.00 0.01 .0
sc qh 0 0 2 3 dqh 0.01 0.0 0.01 .0
sc qh 0 0 2 3 dqh 0.01 0.0 0.01 .1
config close 0

273
tassim.tcl
View File

@ -1,273 +0,0 @@
# --------------------------------------------------------------------------
# Initialization script for Triple Axis Instruments
#
# Dr. Mark Koennecke, November 2000
#---------------------------------------------------------------------------
# O P T I O N S
set root "/data/koenneck/src/sics"
# first all the server options are set
#ServerOption RedirectFile $root/log/stdtas
ServerOption ReadTimeOut 10
# timeout when checking for commands. In the main loop SICS checks for
# pending commands on each connection with the above timeout, has
# PERFORMANCE impact!
ServerOption AcceptTimeOut 10
# timeout when checking for connection req.
# Similar to above, but for connections
ServerOption ReadUserPasswdTimeout 500000
# time to wiat for a user/passwd to be sent from a client. Increase this
# if there is a problem connecting to a server due to network overload\
ServerOption LogFileBaseName $root/log/taslog
# the path and base name of the internal server logfile to which all
# activity will be logged.
ServerOption ServerPort 3015
# the port number the server is going to listen at. The client MUST know
# this number in order to connect. It is in client.ini
ServerOption InterruptPort 3017
# The UDP port where the server will wait for Interrupts from clients.
# Obviously, clients wishing to interrupt need to know this number.
ServerOption LogFileDir $root/simlog
#Where log files from commandlog are stored
ServerOption QuieckPort 2108
# port to send data update messages to
ServerOption statusfile tasstat.tcl
# Telnet Options
ServerOption TelnetPort 1305
ServerOption TelWord sicslogin
# The token system
TokenInit connan
#---------------------------------------------------------------------------
# U S E R S
# Here the SICS users are specified
# Syntax: SicsUser name password userRightsCode
SicsUser Spy 007 1
#---------------------------------------------------------------------------
# M O T O R S
Motor A1 SIM 0. 111. -.1 2. # Monochromator Theta
Motor A2 SIM 33.1 120. -.1 2. # Monochromator Two-Theta
Motor A3 SIM -177.3 177.3 -.1 2. # Sample theta or omega
Motor A4 SIM -135.1 123.4 -.1 2. # Sample Two-Theta
Motor A5 SIM -200 200 -.1 2. # Analyzer Theta
Motor A6 SIM -116. 166. -.1 2. # Analyzer Two-Theta
Motor MCV SIM -9 124. -.1 2. # Monochromator curvature vertical
Motor SRO SIM 0. 351. -.1 2. # Sample table second ring
Motor ACH SIM -.5 11.5 -.1 2. # Analyzer curvature horizontal
Motor MTL SIM -17 17 -.1 2. # Monochromator translation lower
Motor MTU SIM -17 17. -.1 2. # Monochromator Translation upper
Motor STL SIM -30 30. -.1 2. # Sample lower translation
Motor STU SIM -30. 30. -.1 2. # Sample upper translation
Motor ATL SIM -17 17 -.1 2. # Analyzer lower translation
Motor ATU SIM -17 16.88 -.1 2. # Analyzer upper translation
Motor MGL SIM -10 10 -.1 2. # Monochromator lower goniometer
#Motor MGU SIM -30. 30. -.1 2. # Monochromator upper goniometer
Motor SGL SIM -16 16 -.1 2. # Sample lower goniometer
Motor SGU SIM -16 16. -.1 2. # Sample upper goniometer
Motor AGL SIM -10 10 -.1 2. # Analyzer lower goniometer
#Motor AGU SIM -30. 30. -.1 2. # Analyzer upper goniometer
#Motor MSC SIM -30. 30. -.1 2. # Monochromator changer
#Motor ASC SIM -30. 30. -.1 2. # Analyzer changer
#Motor CSC SIM -30. 30. -.1 2. # Collimator changer
#--------------------------------------------------------------------------
# C O U N T E R
MakeCounter counter SIM -1.
#--------------------------------------------------------------------------
# SA M P L E V A R I A B L E S
# AS-CS cell length
# AA-CC cell angles
# AX-AZ scattering vector 1
# BX-BY scattering vector 2
VarMake AS Float User
VarMake BS Float User
VarMake CS Float User
VarMake AA Float User
VarMake BB Float User
VarMake CC Float User
VarMake AX Float User
VarMake AY Float User
VarMake AZ Float User
VarMake BX Float User
VarMake BY Float User
VarMake BZ Float User
#---------------------------------------------------------------------------
# E N E R G Y & R E L A T E D V A R I A B L E S
#
# EI incident energy
# KI incident neutron wavevector
# EF final neutron energy
# KF final neutron wavevector
# QH-QL Q in reciprocal space
# EN energy transfer
VarMake EI Float User
VarMake KI Float User
VarMake EF Float User
VarMake KF Float User
VarMake QH Float User
VarMake QK Float User
VarMake QL Float User
VarMake EN Float User
#---------------------------------------------------------------------------
# I N S T R U M E N T V A R I A B L E S
# DM, DA d-spacing monochromator, analyzer
# SM, SS, SA scattering senses monochromator, sample, analyzer
# FX 1 for constant KI, 2 for constant KF
# NP no of scan points
# TI preset time
# MN preset monitor
# IF* various magnet currents
# HELM Helmholtz angle of some sort.
# HX-HZ Helmholtz field components
# F1, F2 Flipper switches
VarMake instrument Text Mugger
instrument SIM-DRUECHAL
instrument lock
VarMake DM Float Mugger
VarMake DA Float Mugger
VarMake SM Int User
VarMake SS Int User
VarMake SA Int User
VarMake FX Int User
VarMake NP Int User
VarMake TI Float User
VarMake MN Int User
VarMake IF1V Float User
VarMake IF2V Float User
VarMake IF1H Float User
VarMake IF2H Float User
VarMake HELM Float User
VarMake HX Float User
VarMake HY Float User
VarMake HZ Float User
VarMake SWUNIT Int User
VarMake F1 Int User
VarMake F2 Int User
VarMake title Text User
VarMake user Text User
VarMake lastcommand Text User
VarMake output Text User
VarMake local Text User
VarMake alf1 Float User
VarMake alf2 Float User
VarMake alf3 Float User
VarMake alf4 Float User
VarMake bet1 Float User
VarMake bet2 Float User
VarMake bet3 Float User
VarMake bet4 Float User
#--------------------------------------------------------------------------
# I N C R E M E N T V A R I A B L E S
VarMake DA1 Float User
VarMake DA2 Float User
VarMake DA3 Float User
VarMake DA4 Float User
VarMake DA5 Float User
VarMake DA6 Float User
VarMake DMCV Float User
VarMake DSRO Float User
VarMake DACH Float User
VarMake DMTL Float User
VarMake DMTU Float User
VarMake DSTL Float User
VarMake DSTU Float User
VarMake DATL Float User
VarMake DATU Float User
VarMake DMGL Float User
#VarMake DMGU Float User
VarMake DSGL Float User
VarMake DSGU Float User
VarMake DAGL Float User
#VarMake DAGU Float User
#VarMake DMSC Float User
#VarMake DASC Float User
#VarMake DCSC Float User
VarMake DEI Float User
VarMake DKI Float User
VarMake DEF Float User
VarMake DKF Float User
VarMake DQH Float User
VarMake DQK Float User
VarMake DQL Float User
VarMake DEN Float User
VarMake WAV Float User
VarMake ETAM Float User
VarMake ETAS Float User
VarMake ETAA Float User
VarMake QM Float User
VarMake DQM Float User
VarMake DT Float User
VarMake LPA Int User
VarMake DI1 Float User
VarMake DI2 Float User
VarMake DI3 Float User
VarMake DI4 Float User
VarMake DI5 Float User
VarMake DI6 Float User
VarMake DI7 Float User
VarMake DI8 Float User
#--------------------------------------------------------------------------
# Curvature variables
VarMake MRX1 Float Mugger
VarMake MRX2 Float Mugger
VarMake ARX1 Float Mugger
VarMake ARX2 Float Mugger
#-------------------------------------------------------------------------
# Datafile generation variables
VarMake SicsDataPath Text Mugger
SicsDataPath "$root/tmp/"
VarMake SicsDataPrefix Text Mugger
SicsDataPrefix simchal
SicsDataPrefix lock
VarMake SicsDataPostFix Text Mugger
SicsDataPostFix ".scn"
SicsDataPostFix lock
MakeDataNumber SicsDataNumber "$root/danu.dat"
#------------------------------------------------------------------------
# A helper variable for the status display
VarMake scaninfo text Internal
scaninfo "0,Unknown,1.0,.1"
#--------------------------------------------------------------------------
# I N S T A L L S P E C I A L S I C S C O M M A N D S
MakeScanCommand iscan counter tas.hdd recover.bin
MakePeakCenter iscan
#---------------------------------------------------------------------------
# I N S T A L L T A S C O M P A T A B I L I T Y C O M M A N D S
MakeTAS iscan
#--------------------------------------------------------------------------
# I N S T A L L T A S S C R I P T E D C O M M A N D S
#--------------------------------------------------------------------------
# Install sync
MakeSync localhost 2915 Spy 007
source $root/tascom.tcl

322
tastest.tcl
View File

@ -1,322 +0,0 @@
# --------------------------------------------------------------------------
# Initialization script for Triple Axis Instruments
#
# Dr. Mark Koennecke, November 2000
#---------------------------------------------------------------------------
# O P T I O N S
set root "/data/koenneck/src/sics"
# first all the server options are set
#ServerOption RedirectFile $root/log/stdtas
ServerOption ReadTimeOut 10
# timeout when checking for commands. In the main loop SICS checks for
# pending commands on each connection with the above timeout, has
# PERFORMANCE impact!
ServerOption AcceptTimeOut 10
# timeout when checking for connection req.
# Similar to above, but for connections
ServerOption ReadUserPasswdTimeout 500000
# time to wiat for a user/passwd to be sent from a client. Increase this
# if there is a problem connecting to a server due to network overload\
ServerOption LogFileBaseName $root/log/taslog
# the path and base name of the internal server logfile to which all
# activity will be logged.
ServerOption ServerPort 2915
# the port number the server is going to listen at. The client MUST know
# this number in order to connect. It is in client.ini
ServerOption InterruptPort 2917
# The UDP port where the server will wait for Interrupts from clients.
# Obviously, clients wishing to interrupt need to know this number.
ServerOption LogFileDir $root/log
#Where log files from commandlog are stored
ServerOption QuieckPort 2108
# port to send data update messages to
ServerOption statusfile tasstat.tcl
# Telnet Options
ServerOption TelnetPort 1301
ServerOption TelWord sicslogin
# The token system
TokenInit connan
#---------------------------------------------------------------------------
# U S E R S
# Here the SICS users are specified
# Syntax: SicsUser name password userRightsCode
SicsUser Spy 007 1
#---------------------------------------------------------------------------
# M O T O R S
Motor A1 SIM -87. 6.1 -.1 2. # Monochromator Theta
Motor A2 SIM -129.1 -22. -.1 2. # Monochromator Two-Theta
Motor A3 SIM -177.3 177.3 -.1 2. # Sample theta or omega
Motor A4 SIM -135.1 123.4 -.1 2. # Sample Two-Theta
Motor A5 SIM -200 200 -.1 2. # Analyzer Theta
Motor A6 SIM -116. 166. -.1 2. # Analyzer Two-Theta
Motor MCV SIM -9 124. -.1 2. # Monochromator curvature vertical
Motor SRO SIM 0. 351. -.1 2. # Sample table second ring
Motor ACH SIM -.5 11.5 -.1 2. # Analyzer curvature horizontal
Motor MTL SIM -17 17 -.1 2. # Monochromator translation lower
Motor MTU SIM -17 17. -.1 2. # Monochromator Translation upper
Motor STL SIM -30 30. -.1 2. # Sample lower translation
Motor STU SIM -30. 30. -.1 2. # Sample upper translation
Motor ATL SIM -17 17 -.1 2. # Analyzer lower translation
Motor ATU SIM -17 16.88 -.1 2. # Analyzer upper translation
Motor MGL SIM -10 10 -.1 2. # Monochromator lower goniometer
#Motor MGU SIM -30. 30. -.1 2. # Monochromator upper goniometer
Motor SGL SIM -16 16 -.1 2. # Sample lower goniometer
Motor SGU SIM -16 16. -.1 2. # Sample upper goniometer
Motor AGL SIM -10 10 -.1 2. # Analyzer lower goniometer
#Motor AGU SIM -30. 30. -.1 2. # Analyzer upper goniometer
#Motor MSC SIM -30. 30. -.1 2. # Monochromator changer
#Motor ASC SIM -30. 30. -.1 2. # Analyzer changer
#Motor CSC SIM -30. 30. -.1 2. # Collimator changer
#--------------------------------------------------------------------------
# C O U N T E R
MakeCounter counter SIM -1.
#--------------------------------------------------------------------------
# SA M P L E V A R I A B L E S
# AS-CS cell length
# AA-CC cell angles
# AX-AZ scattering vector 1
# BX-BY scattering vector 2
VarMake AS Float User
VarMake BS Float User
VarMake CS Float User
VarMake AA Float User
VarMake BB Float User
VarMake CC Float User
VarMake AX Float User
VarMake AY Float User
VarMake AZ Float User
VarMake BX Float User
VarMake BY Float User
VarMake BZ Float User
#---------------------------------------------------------------------------
# E N E R G Y & R E L A T E D V A R I A B L E S
#
# EI incident energy
# KI incident neutron wavevector
# EF final neutron energy
# KF final neutron wavevector
# QH-QL Q in reciprocal space
# EN energy transfer
VarMake EI Float User
VarMake KI Float User
VarMake EF Float User
VarMake KF Float User
VarMake QH Float User
VarMake QK Float User
VarMake QL Float User
VarMake EN Float User
#-------- energy Q targets
VarMake TEI Float User
VarMake TKI Float User
VarMake TEF Float User
VarMake TKF Float User
VarMake TQH Float User
VarMake TQK Float User
VarMake TQL Float User
VarMake TEN Float User
VarMake TQM Float User
#---------------------------------------------------------------------------
# I N S T R U M E N T V A R I A B L E S
# DM, DA d-spacing monochromator, analyzer
# SM, SS, SA scattering senses monochromator, sample, analyzer
# FX 1 for constant KI, 2 for constant KF
# NP no of scan points
# TI preset time
# MN preset monitor
# IF* various magnet currents
# HELM Helmholtz angle of some sort.
# HX-HZ Helmholtz field components
# F1, F2 Flipper switches
VarMake instrument Text Mugger
instrument DRUECHAL
instrument lock
VarMake DM Float Mugger
VarMake DA Float Mugger
VarMake SM Int User
SM -1
SM lock
VarMake SS Int User
VarMake SA Int User
VarMake FX Int User
VarMake NP Int User
VarMake TI Float User
VarMake MN Int User
VarMake IF1V Float User
VarMake IF2V Float User
VarMake IF1H Float User
VarMake IF2H Float User
IF1V 1.0
IF1H 1.0
IF2V 1.0
IF2H 1.0
VarMake HELM Float User
VarMake HX Float User
VarMake HY Float User
VarMake HZ Float User
VarMake SWUNIT Int User
VarMake F1 Int User
VarMake F2 Int User
VarMake title Text User
VarMake user Text User
VarMake lastcommand Text User
VarMake output Text User
VarMake local Text User
VarMake alf1 Float User
VarMake alf2 Float User
VarMake alf3 Float User
VarMake alf4 Float User
VarMake bet1 Float User
VarMake bet2 Float User
VarMake bet3 Float User
VarMake bet4 Float User
#--------------------------------------------------------------------------
# I N C R E M E N T V A R I A B L E S
VarMake DA1 Float User
VarMake DA2 Float User
VarMake DA3 Float User
VarMake DA4 Float User
VarMake DA5 Float User
VarMake DA6 Float User
VarMake DMCV Float User
VarMake DSRO Float User
VarMake DACH Float User
VarMake DMTL Float User
VarMake DMTU Float User
VarMake DSTL Float User
VarMake DSTU Float User
VarMake DATL Float User
VarMake DATU Float User
VarMake DMGL Float User
#VarMake DMGU Float User
VarMake DSGL Float User
VarMake DSGU Float User
VarMake DAGL Float User
#VarMake DAGU Float User
#VarMake DMSC Float User
#VarMake DASC Float User
#VarMake DCSC Float User
VarMake DEI Float User
VarMake DKI Float User
VarMake DEF Float User
VarMake DKF Float User
VarMake DQH Float User
VarMake DQK Float User
VarMake DQL Float User
VarMake DEN Float User
VarMake WAV Float User
VarMake ETAM Float User
VarMake ETAS Float User
VarMake ETAA Float User
VarMake QM Float User
VarMake DQM Float User
VarMake DT Float User
VarMake LPA Int User
#----------- Current increments
VarMake DI1 Float User
VarMake DI2 Float User
VarMake DI3 Float User
VarMake DI4 Float User
VarMake DI5 Float User
VarMake DI6 Float User
VarMake DI7 Float User
VarMake DI8 Float User
VarMake DHX Float User
VarMake DHY Float User
VarMake DHZ Float User
#----------- Current Targets
VarMake TI1 Float User
VarMake TI2 Float User
VarMake TI3 Float User
VarMake TI4 Float User
VarMake TI5 Float User
VarMake TI6 Float User
VarMake TI7 Float User
VarMake TI8 Float User
VarMake THX Float User
VarMake THY Float User
VarMake THZ Float User
#--------------------------------------------------------------------------
# Curvature variables
VarMake MRX1 Float Mugger
VarMake MRX2 Float Mugger
VarMake ARX1 Float Mugger
VarMake ARX2 Float Mugger
#-------------------------------------------------------------------------
# Conversion factors from gauss to ampere for Helmholtz calculations
VarMake HCONV1 Float Mugger
VarMake HCONV2 Float Mugger
VarMake HCONV3 Float Mugger
VarMake HCONV4 Float Mugger
HCONV1 1.0
HCONV2 1.0
HCONV3 1.0
HCONV4 1.0
#------------------------------------------------------------------------
# Polarisation file
VarMake polfile Text User
#-------------------------------------------------------------------------
# Datafile generation variables
VarMake SicsDataPath Text Mugger
SicsDataPath "$root/tmp/"
VarMake SicsDataPrefix Text Mugger
SicsDataPrefix simchal
SicsDataPrefix lock
VarMake SicsDataPostFix Text Mugger
SicsDataPostFix ".scn"
SicsDataPostFix lock
MakeDataNumber SicsDataNumber "$root/danu.dat"
#------------------------------------------------------------------------
# A helper variable for the status display
VarMake scaninfo text Internal
scaninfo "0,Unknown,1.0,.1"
#--------------------------------------------------------------------------
# I N S T A L L S P E C I A L S I C S C O M M A N D S
MakeScanCommand iscan counter tas.hdd recover.bin
MakePeakCenter iscan
#---------------------------------------------------------------------------
# I N S T A L L T A S C O M P A T A B I L I T Y C O M M A N D S
MakeTAS iscan
#--------------------------------------------------------------------------
# I N S T A L L T A S S C R I P T E D C O M M A N D S
MakeDrive
source $root/tascom.tcl

527
tcl/astrium.tcl
View File

@ -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
}

8
tcl/bgerror.tcl
View File

@ -1,8 +0,0 @@
proc bgerror err {
global errorInfo
set info $errorInfo
puts stdout $err
puts stdout "------------------------- StackTrace ---------------------"
puts $info
}

151
tcl/client.tcl
View File

@ -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

54
tcl/count.tcl
View File

@ -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
View File

@ -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
View File

@ -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
}

97
tcl/el755.tcl
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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

29
tcl/parray.tcl
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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
}

79
tcl/reflist.tcl
View File

@ -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
View File

@ -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
View File

@ -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
}
}

66
tcl/secsim.tcl
View File

@ -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
}

74
tcl/sicstcldebug.tcl
View File

@ -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]
}
#------------------------------------------------------------------

91
tcl/simhm.tcl
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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
}

23
tcl/stdin.tcl
View File

@ -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};

62
tcl/susca.tcl
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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]]
}

43
tcl/wwwpulver.tcl
View File

@ -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

57
tclvarex.tcl
View File

@ -1,57 +0,0 @@
#---------------------------------------------------------------------------
# T C L D E F I N E D S I C S V A R I A B L E S
set OM2T(omega) A3
set OM2T(2Theta) A6
proc OM2TDriv { } {
return $Boerks
}
proc OM2TSet { f } {
global OM2T
set command "run "
append command $OM2T(omega) " " [expr $f/2.] " "
append command $OM2T(2Theta) " " $f " "
set ret [catch {eval $command} msg]
if { $ret == 1 } {
ClientPut $msg error
return 0
} else {
return 1
}
}
proc OM2TStat { } {
global OM2T
set ret [SICSStatus $OM2T(omega)]
if { ($ret == 1) || ($ret == 2) } {
set ret [SICSStatus $OM2T(2Theta)]
}
return $ret
}
proc OM2TGet { } {
global OM2T
set res [$OM2T(2Theta) position]
return $res
}
proc OM2TCheck { f } {
global OM2T
set ret [catch {SICSBounds $OM2T(omega) [expr $f/2.] } msg]
if { $ret != 0 } {
ClientPut $msg error
return -code error -text $msg
}
set ret [catch {SICSBounds $OM2T(2Theta) $f } msg]
if { $ret != 0 } {
ClientPut $msg error
return -code error -text $msg
}
return 1
}
MakeTSVar OM2TH
OM2TH isDrivable OM2TDriv
OM2TH SetValue OM2TSet
OM2TH CheckStatus OM2TStat
OM2TH GetValue OM2TGet
OM2TH CheckLimits OM2TCheck

5
tdir.tcl
View File

@ -1,5 +0,0 @@
for {set i 0} { $i < 3000} {incr i} {
ClientPut "Hello you"
}
ClientPut "I'am finished"
ClientPut [sicstime]

504
test.tcl
View File

@ -1,504 +0,0 @@
# --------------------------------------------------------------------------
# Initialization script for a simulated TOPSI instrument
#
#
# Dr. Mark Koennecke February, 1996
#---------------------------------------------------------------------------
# O P T I O N S
# --------------- Initialize Tcl internals --------------------------------
rename scan stscan
#-------- a home for this, everything else is in relation to this
set shome /afs/psi.ch/user/k/koennecke/Tru64/src
# first all the server options are set
#ServerOption RedirectFile $shome/sics/stdout
ServerOption ReadTimeOut 10
# timeout when checking for commands. In the main loop SICS checks for
# pending commands on each connection with the above timeout, has
# PERFORMANCE impact!
ServerOption AcceptTimeOut 10
# timeout when checking for connection req.
# Similar to above, but for connections
ServerOption ReadUserPasswdTimeout 10
# time to wiat for a user/passwd to be sent from a client. Increase this
# if there is a problem connecting to a server due to network overload\
ServerOption LogFileDir $shome/log
#LogFileDir is the directory where the command log is going
#ServerOption logstartfile $shome/sics/start.tcl
ServerOption LogFileBaseName $shome/sics/tmp/server
# the path and base name of the internal server logfile to which all
# activity will be logged.
ServerOption TecsStartCmd "tecs/bin/TecsServer -h lnsp26:4000/0"
# -h host:port/channel is for serial server
ServerOption TecsBinDir tecs/bin/
ServerOption TecsLogDir /data/koenneck/tmp/
ServerOption TecsPort 9753
ServerOption statusfile sicsstatus.tcl
ServerOption ServerPort 2911
# the port number the server is going to listen at. The client MUST know
# this number in order to connect. It is in client.ini
ServerOption InterruptPort 2914
# The UDP port where the server will wait for Interrupts from clients.
# Obviously, clients wishing to interrupt need to know this number.
# Telnet options
ServerOption TelnetPort 1301
ServerOption TelWord sicslogin
ServerOption DefaultTclDirectory $shome/sics/tcl
ServerOption DefaultCommandFile ""
#------ a port for broadcasting UDP messages
#ServerOption QuieckPort 2108
TokenInit connan
#---------------------------------------------------------------------------
# U S E R S
# than the SICS users are specified
# Syntax: SicsUser name password userRightsCode
SicsUser Mugger Diethelm 1
SicsUser User Rosy 2
SicsUser Spy 007 1
SicsUser me me 1
SicsUser testuser 01lns1 3
#--------------------------------------------------------------------------
# S I M P L E V A R I A B L E S
# now a few general variables are created
# Syntax: VarMake name type access
# type can be one of: Text, Int, Float
#access can be one of: Internal, Mugger, user, Spy
VarMake Instrument Text Internal
Instrument "TOPSI"
Instrument lock
VarMake starttime Text User
VarMake Title Text User
VarMake sample Text User
sample "DanielOxid"
Title "TopsiTupsiTapsi"
VarMake User Text User
User "Daniel_the_Clementine"
VarMake detectordist Float Mugger
detectordist 2500
detectordist lock
VarMake sampledist Float Mugger
sampledist 496.
sampledist lock
VarMake batchroot Text User
#--------------------------------------------------------------------------
# D E V I C E S : M O T O R S
# Motor a4 EL734 LNSP22 4000 5 6
# EL734 motor with parameters: hostname PortNumber Channel MotorID
#Motor D1V EL734 lnsp22.psi.ch 4000 3 3
Motor A1 SIM 15.0 120. .1 2. # Monochromator Theta
Motor A2 SIM -73. 137. .1 1. # Monochromator 2Theta
Motor A3 SIM -360. 360. .1 3. # Sample Omega
#Motor A3 el734 localhost 4000 2 3
Motor A4 SIM -130. 130. .1 1. # Sample 2Theta
Motor A5 SIM -30. 30. .1 3. # ? horiz. Translation
Motor A6 SIM -30. 30. .1 3. # ? vert Translation
Motor MTL SIM -30. 30. .1 3. # mono lower translation
Motor MTU SIM -30. 30. .1 3. # mono upper translation
Motor STL SIM -30. 30. .1 3. # sample lower translation
Motor STU SIM -30. 30. .1 3. # sample upper translation
Motor MGU SIM -50. 50. .1 3. # mono upper goniometer
Motor SGL SIM -20. 20. .1 3. # sample lower goniometer
Motor SGU SIM -20. 20. .1 3. # sample upper goniometer
Motor SDM SIM -5 50. .1 3. # weird Motor
SicsAlias A4 Tasse
SicsAlias A5 MonoX
SicsAlias A5 MonoY
SicsAlias A5 MonoPhi
SicsAlias A5 MonoChi
Motor D1R SIM -20. 20. .1 3. # Diaphragm 1 right
Motor D1L SIM -20. 20. .1 3. # Diaphragm 1 left
Motor D1T SIM -20. 20. .1 3. # Diaphragm 1 top & Bottom
Motor D2R SIM -20. 20. .1 3. # Diaphragm 2 right
Motor D2L SIM -20. 20. .1 3. # Diaphragm 2 left
Motor D2T SIM -20. 20. .1 3. # Diaphragm 2 top & Bottom
Motor BeamStopX SIM -20. 20. .1 3. # Diaphragm 2 right
Motor BeamStopY SIM -20. 20. .1 3. # Diaphragm 2 left
Motor DetectorX SIM -20. 20. .1 3. # Diaphragm 2 right
Motor DetectorY SIM -20. 20. .1 3. # Diaphragm 2 left
Motor DetectorRotation SIM -20. 20. .1 3. # Diaphragm 2 top & Bottom
ClientPut "Motors done"
MakeMulti sampletable
sampletable alias D1r x
sampletable alias D1L y
sampletable alias D1T z
sampletable pos henry D1r 5. D1L -5. D1T 0.
sampletable endconfig
SicsAlias sampletable st
#------------------------------------------------------------------------
# Velocity selector
#Motor tilt EL734 lnsp25.psi.ch 4000 2 2
Motor tilt SIM -15 15 .1 3.
set dornen(Host) lnsp25.psi.ch
set dornen(Port) 4000
set dornen(Channel) 6
set dornen(Timeout) 5000
#VelocitySelector nvs tilt DORNIER dornen
set d2003(Host) psts233
set d2003(Port) 3004
set d2003(Timeout) 20000
#VelocitySelector nvs tilt dornier2003 d2003
VelocitySelector nvs tilt SIM
nvs add -20 28800
nvs add 3800 4500
nvs add 5900 6700
nvs add 8100 9600
unset dornen
emon unregister nvswatch
MakeSANSWave lumbda nvs
ClientPut "Velocity Selector done"
SicsAlias MTL sax
SicsAlias A3 som
#--------------------------------------------------------------------------
# C O U N T E R S
MakeCounter counter SIM .05
#MakeCounter counter EL737 lnsp19.psi.ch 4000 4
#--------------------------------------------------------------------------
# M U L T I D E V I C E V A R I A B L E S
MakeMono Mono "Ge-111" A1 A2 SDM
Mono dd 3.3537
Mono vk1 -0.025942
Mono vk2 5.35166
MakeWaveLength lambda Mono
MakeO2T O2T A3 A4
#--------------------------------------------------------------------------
# P R O C E D U R E S
source tcl/log.tcl
MakeDrive
SicsAlias drive dr
Publish LogBook Spy
MakeRuenBuffer
#---------------- TestVariables for Storage
VarMake SicsDataPath Text Mugger
SicsDataPath "$shome/sics/"
SicsDataPath lock
VarMake SicsDataPrefix Text Mugger
SicsDataPrefix test
SicsDataPrefix lock
VarMake SicsDataPostFix Text Mugger
SicsDataPostFix ".hdf"
SicsDataPostFix lock
VarMake Adress Text User
VarMake phone Text User
VarMake fax Text User
VarMake email Text User
VarMake sample_mur Float User
MakeDataNumber SicsDataNumber "$shome/sics/danu.dat"
#InitSANS $shome/sics/sansdict.dic
InitDMC
MakeScanCommand xxxscan counter topsi.hdd recover.bin
MakePeakCenter xxxscan
MakeHM banana SIM
#MakeHM banana SINQHM
#banana configure HistMode HRPT
banana configure HistMode Normal
#banana configure OverFlowMode reflect
banana configure OverFlowMode Ceil
banana configure Rank 1
#banana configure Length 400
banana configure Length 16384
banana configure dim0 128
banana configure dim1 128
banana configure BinWidth 4
banana preset 100.
banana CountMode Timer
banana configure HMComputer lnse02.psi.ch
banana configure HMPort 2400
banana configure Counter counter
banana init
ClientPut "HM initialized"
source $shome/sics/tcl/scancom.tcl
#source $shome/sics/countf.tcl
#source $shome/sics/tcl/count.tcl
#Publish count User
#Publish repeat user
source $shome/sics/tcl/fit.tcl
Publish fit Spy
SerialInit
Publish serialport User
Publish p1 User
Publish HakleGet User
#-------------------- Testing Haake thermostat
source hakle.tcl
Publish IniHaakeArray Mugger
ClientPut "Installed ev test stuff"
#------------------ 4 circle stuff
Motor twotheta SIM -120.0 120. .1 2. # 2 theta arm
Motor omega SIM -73. 134. .1 2. # omega
Motor chi SIM 0. 360. .1 2. # chi circle
Motor phi SIM -360. 360. .1 2. # phi circle
Motor muca SIM 30. 36. .1 2. # phi circle
Motor dg1 SIM -10. 40. .1 2. # phi circle
Motor dg2 SIM -10. 40. .1 2. # phi circle
Motor dg3 SIM -10. 40. .1 2. # phi circle
SicsAlias phi ph
SicsAlias chi ch
SicsAlias twotheta stt
SicsAlias omega om
VarMake monodescription Text Mugger
monodescription "unknownit crystal"
VarMake mono2theta Text Mugger
mono2theta 36.77
VarMake det1zerox Float Mugger
det1zerox 128.
VarMake det1zeroy Float Mugger
det1zeroy 128.
VarMake det1dist Float Mugger
det1dist 300.
VarMake det2zerox Float Mugger
det2zerox 128.
VarMake det2zeroy Float Mugger
det2zeroy 128.
VarMake det2dist Float Mugger
det2dist 300.
VarMake det3zerox Float Mugger
det3zerox 128.
VarMake det3zeroy Float Mugger
det3zeroy 128.
VarMake det3dist Float Mugger
det3dist 300.
VarMake detstepwidth Float Mugger
detstepwidth 0.1
detstepwidth lock
MakeHKL twotheta omega chi phi chi
HKL lambda 0.70379
HKL setub -0.1247023 0.0016176 -0.0413566 \
-0.1044479 -0.0013264 0.0493878 \
0.0007513 0.0840941 0.0015745
MakeOptimise opti counter
MakeMesure mess HKL xxxscan omega o2t $shome/sics/tmp \
SicsDataNumber
MakeHklscan xxxscan HKL
#------test rliste
SicsAlias twotheta th
SicsAlias omega om
SicsAlias chi ch
SicsAlias phi ph
source tcl/reflist.tcl
Publish rliste User
source fcircle.tcl
fcircleinit
MakeDifrac twotheta omega chi phi counter
#----------- histogram memory
#MakeHM hm1 SinqHM
MakeHM hm1 SIM
hm1 configure HistMode PSD
hm1 configure Rank 1
hm1 configure Length 65536
hm1 configure dim0 256
hm1 configure dim1 256
hm1 configure BinWidth 4
hm1 preset 100.
hm1 CountMode Timer
hm1 configure xoff 100
hm1 configure xfac 10
hm1 configure yoff 100
hm1 configure yfac 10
#hm1 configure HMComputer psds03.psi.ch
#hm1 configure HMPort 2400
hm1 configure Counter counter
hm1 genbin 0 10000 2
hm1 configure init 0
hm1 init
MakeHM hm2 SIM
hm2 configure HistMode PSD
hm2 configure Rank 1
hm2 configure Length 65536
hm2 configure dim0 256
hm2 configure dim1 256
hm2 configure BinWidth 4
#hm2 configure HMComputer lnse02.psi.ch
#hm2 configure HMPort 2400
hm2 init
#MakeHM hm3 SIM
#hm3 configure HistMode PSD
#hm3 configure Rank 1
#hm3 configure Length 65536
#hm3 configure dim0 256
#hm3 configure dim1 256
#hm3 configure BinWidth 4
#hm3 configure HMComputer lnse02.psi.ch
#hm3 configure HMPort 2400
#hm3 configure Counter counter
#hm3 init
ClientPut "Installed 4-circle stuff"
#source transact.tcl
#Publish transact Spy
#MakeSPS sps lnsa12.psi.ch 4000 4
#source beamdt.tcl
#------------- C804-DC motors
set nob(Computer) lnsp22.psi.ch
set nob(port) 4000
set nob(channel) 7
set nob(motor) 1
set nob(upperlimit) 250000
set nob(lowerlimit) -250000
#MakePIMotor nobi c804 nob
#set nob(channel) 6
#Motor pilz pipiezo nob
VarMake datafile Text Spy
datafile focus-1001848.hdf
#--------- create a time array for histogramming
#MakeHM chiquita SINQHM
MakeHM hm SIM
#chiquita configure HMComputer lnse03.psi.ch
#chiquita configure HMport 2400
hm configure HistMode TOF
hm configure OverFlowMode Ceil
hm configure Rank 1
hm configure dim0 383
hm configure Length 383
hm configure BinWidth 4
hm preset 100.
hm CountMode Timer
hm configure Counter counter
hm configure init 0
hm genbin 120. 35. 512
hm init
VarMake delay Float Mugger
delay 158.8
VarMake flightpath Float Mugger
delay 2000
VarMake flightpathlength Float Mugger
delay 2500
MakeFocusAverager average hm
FocusInstall hm focus.dic $shome/sics/focusmerge.dat
storefocus upper 1
storefocus lower 1
#MakeChopper choco docho lnsp20 4000 8
MakeChopper choco sim
#ChopperAdapter fermispeed choco chopper1.nspee 0 20000
#ChopperAdapter diskspeed choco chopper2.nspee 0 20000
#ChopperAdapter phase choco chopper2.nphas 0 90.
#ChopperAdapter ratio choco chopper2.ratio 0 6.
ChopperAdapter diskspeed choco speed 0 20000
ChopperAdapter phase choco phase 0 90.
ChopperAdapter ratio choco ratio 0 6.
#-------- SANS Cooker
#MakeChopper cooker sanscook lnsa10 4000 11
#ChopperAdapter cookp cooker mp 0 400
#ChopperAdapter cookz cooker mz 0 400
source chosta.tcl
Publish chosta Spy
#MakeSPS sps1 lnsp25.psi.ch 4000 10
Publish testscan User
proc testscan {} {
return " 1 2 3 4 5"
}
MakeXYTable ixi
source cotop.tcl
Publish co User
#source helium.tcl
MakeTRICSNEXUS sicsdatanumber $shome/sics/tmp trics.dic
source $shome/sics/tcl/tricscount.tcl
source autofile.tcl
autofilepath $shome/tmp/auto
MakeXYTable omth
Publish info user
MakeLin2Ang a5l a5
#source tmp/beam.tcl
source tcl/wwwpar.tcl
source bef.tcl
source batch.tcl
Publish batchrun User
#------- test of RS232Controller
#MakeRS232Controller hugo psts233 3004
#-------------------------- batch run issue
VarMake BatchRoot Text User
BatchRoot /data/koenneck/src/sics
Publish batchrun User
proc SplitReply { text } {
set l [split $text =]
return [lindex $l 1]
}
proc batchrun file {
fileeval [string trim [SplitReply [BatchRoot]]/$file]
}

7
testj.tcl
View File

@ -1,7 +0,0 @@
drive mom 3.
scan clear
scan np 10
scan var a2t 0. .1
scan mode timer
scan preset 1
scan run

3013
tmp/all.hkl
View File

File diff suppressed because it is too large Load Diff

27
tmp/amorset.tcl
View File

@ -1,27 +0,0 @@
#----------- settings for AMOR which help test the new AMOR settings module
soz softzero 145.5
com softzero 0
cox softzero 0
dbs softzero 23.7
d2b softzero -5.25
d2t softzero 0
d3b softzero -86.18
d3t softzero -1.8
d4b softzero 0
d4t softzero .5
d5b softzero 0
d5t softzero 0
aoz softzero 0
aom softzero -.026
com sign -1
d4b sign -1
amorset mono read 500
amorset mono active 1
amorset slit1 read 1000
amorset slit1 active 1
amorset sample read 2000
amorset sample active 1
amorset slit4 read 3000
amorset slit4 active 1
amorset detector read 4000
amorset detector active 1

51
tmp/batchedtest.tcl
View File

@ -1,51 +0,0 @@
#
title alignement test
user stahn
sample shit
#
dr s2t .0 som .0
dr stz 15
count timer 3
dr stz 17.9
#
dr s2t .4 som .2
#
count timer 3
#
dr s2t 1.2 som .6
#
count timer 3
#
dr s2t 1.6 som .8
#
count timer 3
#
dr s2t 2.0 som 1
#
count timer 3
#
dr s2t 0 som 0
dr stz 15
count timer 3
dr stz 17.9
#
dr s2t .4 som .2
#
count timer 3
#
dr s2t 1.2 som .6
#
count timer 3
#
dr s2t 1.6 som .8
#
count timer 3
#
dr s2t 2.0 som 1
#
count timer 3
#
count timer 3
count timer 3
count timer 3
#

51
tmp/bbtest.tst
View File

@ -1,51 +0,0 @@
#
title alignement test
user stahn
sample shit
#
dr s2t .0 som .0
dr stz 15
count timer 3
dr stz 17.9
#
dr s2t .4 som .2
#
count timer 3
#
dr s2t 1.2 som .6
#
count timer 3
#
dr s2t 1.6 som .8
#
count timer 3
#
dr s2t 2.0 som 1
#
count timer 3
#
dr s2t 0 som 0
dr stz 15
count timer 3
dr stz 17.9
#
dr s2t .4 som .2
#
count timer 3
#
dr s2t 1.2 som .6
#
count timer 3
#
dr s2t 1.6 som .8
#
count timer 3
#
dr s2t 2.0 som 1
#
count timer 3
#
count timer 3
count timer 3
count timer 3
#

51
tmp/btest.tst
View File

@ -1,51 +0,0 @@
#
title alignement test
user stahn
sample shit
#
dr s2t .0 som .0
dr stz 15
count timer 3
dr stz 17.9
#
dr s2t .4 som .2
#
count timer 3
#
dr s2t 1.2 som .6
#
count timer 3
#
dr s2t 1.6 som .8
#
count timer 3
#
dr s2t 2.0 som 1
#
count timer 3
#
dr s2t 0 som 0
dr stz 15
count timer 3
dr stz 17.9
#
dr s2t .4 som .2
#
count timer 3
#
dr s2t 1.2 som .6
#
count timer 3
#
dr s2t 1.6 som .8
#
count timer 3
#
dr s2t 2.0 som 1
#
count timer 3
#
count timer 3
count timer 3
count timer 3
#

74
tmp/bug.lis
View File

@ -1,74 +0,0 @@
Script started on Tue 13 Sep 2005 12:11:49 PM CEST
Display type: XWINDOW
[tasp@pc4478 ~/tasp_sics]$ gdb debsics core.6603
GNU gdb Red Hat Linux (6.1post-1.20040607.52rh)
Copyright 2004 Free Software Foundation, Inc.
GDB is free software, covered by the GNU General Public License, and you are
welcome to change it and/or distribute copies of it under certain conditions.
Type "show copying" to see the conditions.
There is absolutely no warranty for GDB. Type "show warranty" for details.
This GDB was configured as "i386-redhat-linux-gnu"...Using host libthread_db library "/lib/tls/libthread_db.so.1".
Core was generated by `/home/tasp/tasp_sics/SICServer /home/tasp/tasp_sics/tasp.tcl'.
Program terminated with signal 11, Segmentation fault.
Reading symbols from /usr/lib/libtcl8.3.so...done.
Loaded symbols for /usr/lib/libtcl8.3.so
Reading symbols from /lib/libdl.so.2...done.
Loaded symbols for /lib/libdl.so.2
Reading symbols from /lib/tls/libm.so.6...done.
Loaded symbols for /lib/tls/libm.so.6
Reading symbols from /lib/tls/libc.so.6...done.
Loaded symbols for /lib/tls/libc.so.6
Reading symbols from /lib/ld-linux.so.2...done.
Loaded symbols for /lib/ld-linux.so.2
Reading symbols from /lib/libnss_files.so.2...done.
Loaded symbols for /lib/libnss_files.so.2
Reading symbols from /lib/libnss_dns.so.2...done.
Loaded symbols for /lib/libnss_dns.so.2
Reading symbols from /lib/libresolv.so.2...done.
Loaded symbols for /lib/libresolv.so.2
#0 0x00182009 in free () from /lib/tls/libc.so.6
(gdb) btr 
#0 0x00182009 in free () from /lib/tls/libc.so.6
#1 0x0017dc0b in _IO_free_backup_area_internal () from /lib/tls/libc.so.6
#2 0x0017c170 in _IO_new_file_overflow () from /lib/tls/libc.so.6
#3 0x0017cc00 in _IO_new_file_xsputn () from /lib/tls/libc.so.6
#4 0x00155357 in vfprintf () from /lib/tls/libc.so.6
#5 0x0015ddef in fprintf () from /lib/tls/libc.so.6
#6 0x08050aa0 in WriteSicsStatus (self=0x8667030,
file=0x86b17b0 "/home/tasp/log/syncstatus.tcl", iMot=1) at SCinter.c:424
#7 0x0805a75c in BackupStatus (pCon=0x867d280, pSics=0x8667030,
pData=0x866dbf8, argc=2, argv=0xbfff91e4) at status.c:344
#8 0x0805600f in SicsUnknownProc (pData=0x866cf50, pInter=0x8667610, argc=3,
argv=0xbfff91e0) at macro.c:182
#9 0x00d317ec in TclInvokeStringCommand () from /usr/lib/libtcl8.3.so
#10 0x00d4e603 in TclExecuteByteCode () from /usr/lib/libtcl8.3.so
#11 0x00d32292 in Tcl_EvalObjEx () from /usr/lib/libtcl8.3.so
#12 0x00d746b8 in TclObjInterpProc () from /usr/lib/libtcl8.3.so
#13 0x00d6d513 in TclExpandTokenArray () from /usr/lib/libtcl8.3.so
#14 0x00d6dbfe in Tcl_EvalEx () from /usr/lib/libtcl8.3.so
#15 0x00d6df62 in Tcl_Eval () from /usr/lib/libtcl8.3.so
#16 0x080571d5 in TclAction (pCon=0x867d280, pSics=0x8667030, pData=0x8688d90,
argc=2, argv=0x86ad290) at macro.c:861
#17 0x080506bc in InterpExecute (self=0x8667030, pCon=0x867d280,
pText=0xbfffa6b0 "syncbackup /home/tasp/log/syncstatus.tcl")
---Type <return> to continue, or q <return> to quit---
at SCinter.c:301
#18 0x080576ab in TransactAction (pCon=0x867d280, pSics=0x8667030,
pData=0x866d828, argc=3, argv=0x8685df8) at macro.c:984
#19 0x080506bc in InterpExecute (self=0x8667030, pCon=0x867d280,
pText=0x86b08f8 "transact syncbackup /home/tasp/log/syncstatus.tcl")
at SCinter.c:301
#20 0x0804ec0f in SCInvoke (self=0x867d280, pInter=0x8667030,
pCommand=0x86b08f8 "transact syncbackup /home/tasp/log/syncstatus.tcl")
at conman.c:1346
#21 0x0804fc85 in SCTaskFunction (pData=0x867d280) at conman.c:1824
#22 0x08055885 in TaskSchedule (self=0x866d198) at task.c:211
#23 0x08054b36 in RunServer (self=0x8667008) at nserver.c:409
#24 0x08054f1e in main (argc=2, argv=0xbfffb394) at SICSmain.c:59
(gdb) quit
[tasp@pc4478 ~/tasp_sics]$ exit

9
tmp/hdbscan.tcl
View File

@ -1,9 +0,0 @@
hset /commands/scan/scan_variables som
hset /commands/scan/scan_start 5
hset /commands/scan/scan_increments .5
hset /commands/scan/NP 10
hset /commands/scan/mode Timer
hset /commands/scan/preset 2

25
tmp/li-reduced.ub
View File

@ -1,25 +0,0 @@
om softzero 0
ch softzero 0
ph softzero 0
stt softzero 0
sample LiNbO3, reduced
user schaniel woike schefer
# June 30, 2005 Schefer Schaniel
hkl setub -0.0853209 -0.0408253 0.0667085 -0.2071918 -0.0948574 -0.0274408 -0.0101375 -0.1991136 -0.0006048
hkl setub -0.0835069 -0.0359178 0.0669138 -0.2078507 -0.0954050 -0.0269301 -0.0116421 -0.1997965 0.0008301
hkl setub -0.0835069 -0.0359178 0.0669138 -0.2078507 -0.0954050 -0.0269301 -0.0116421 -0.1997965 0.0008301
hkl setub -0.0812246 -0.0357234 0.0672142 -0.2088588 -0.0974462 -0.0261738 -0.0095618 -0.1988440 0.0007514
hkl setub -0.0810901 -0.0376026 0.0691056 -0.2045003 -0.0947790 -0.0274020 -0.0092719 -0.1951536 -0.0000073
hkl setub -0.0816891 -0.0373536 0.0676441 -0.2036469 -0.0945316 -0.0271433 -0.0093154 -0.1946803 0.0002011
hkl setub -0.0868862 -0.0387014 0.0661984 -0.2068806 -0.0912656 -0.0277929 -0.0150816 -0.2018639 -0.0001260
hkl setub 0.0865922 0.0382913 0.0665164 0.2067114 0.0968973 -0.0278987 0.0091118 0.1986342 0.0007869
hkl setub 0.0865922 0.0483009 -0.0665164 0.2067114 0.1098141 0.0278987 0.0091118 -0.1895224 -0.0007869
hkl setub 0.0827032 0.0453160 -0.0670359 0.2084762 0.1054149 0.0266105 0.0029515 -0.1927304 -0.0012072
hkl setub 0.0825852 0.0448308 -0.0665571 0.2067716 0.1091085 0.0265991 0.0076522 -0.1889944 -0.0004319
hkl setub 0.0812764 0.0440605 -0.0667313 0.2073279 0.1090023 0.0261758 0.0071815 -0.1892602 -0.0004596
#
July 4, 2005
hkl setub 0.0821425 0.0444320 -0.0666986 0.2072366 0.1088816 0.0264524 0.0070800 -0.1895129 -0.0004399
#end ub
exe tmp/table.res
#end

85
tmp/m2t_generator
View File

@ -1,85 +0,0 @@
#!/usr/bin/perl -w
#
# preliminary way to set the monochromator 2 theta angle 'mth' and
# based thereon the sample 2 theta angle 's2t'.
#
use Math::Trig ;
#
##################################################################
#
if ($ARGV[0]) {
$m2t = $ARGV[0] ;
} else {
die " *** usage: m2t_generator <m2t>\n" ;
} ;
#----------------------------------------------
# list of off-sets:
$M = 100.0 ; # monitor / polariser
$DS = -50.0 ; # shielding slit
$D2 = -52.5 ; # 2nd diaphragm
$D3 = -53.5 ; # 3rd diaphragm
$S = 280.8 ; # sample table
#$D4 = 0.0 ; 4th diaphragm
#$D5 = 0.0 ; # 5th diaphragm
$D = -162.0 ; # single detector
#$D = 0.0 ; # area detector
#----------------------------------------------
# list of fix or default values:
$DST = 15.0 ; # opening shielding slit
$D2T = 1.0 ; # opening 2nd diaphragm
$D3T = 1.0 ; # opening 2rd diaphragm
if ( $ARGV[1] ) {
$s2t = $ARGV[1] ;
} else {
$s2t = 0.0 ; # sample 2 theta
} ;
#----------------------------------------------
# list of positions due to the ruler:
$M += 7440.0 ; # monitor / polariser
$DS += 6980.0 ; # shielding slit
$D2 += 6653.0 ; # 2nd diaphragm
$D3 += 5956.0 ; # 3rd diaphragm
$S += 5047.8 ; # sample table
#$D4 += 0.0 ; # 4th diaphragm
#$D5 += 0.0 ; # 5th diaphragm
$D += 2600.0 ; # detector stage
#----------------------------------------------
#----------------------------------------------
# calculus
# from polariser / monochromator to sample
$DSB = abs($M-$DS) * tan(deg2rad($m2t)) - 0.5 * $DST ;
$D2B = abs($M-$D2) * tan(deg2rad($m2t)) - 0.5 * $D2T ;
$D3B = abs($M-$D3) * tan(deg2rad($m2t)) - 0.5 * $D3T ;
$SOZ = abs($M-$S) * tan(deg2rad($m2t)) ;
# from sample to detector
$com = $s2t + $m2t ;
$COX = abs($S-$D) * ( cos(deg2rad(-$com)) - 1 ) ;
$COZ = abs($S-$D) * sin(deg2rad($com)) + $SOZ ;
#
printf "clientput MS = %5.1f mm\n", abs($M-$S) ;
printf "clientput SD = %5.1f mm\n", abs($S-$D) ;
printf "clientput MD = %5.1f mm\n", abs($M-$D) ;
printf "clientput D2M = %5.1f mm\n", abs($M-$D2) ;
printf "clientput D3M = %5.1f mm\n", abs($M-$D3) ;
printf "clientput DBM = %5.1f mm\n", abs($M-$DS) ;
#
printf "clientput run dbs %5.1f \n", $DSB ;
printf "clientput [run dbs %5.1f]\n", $DSB ;
printf "clientput run d2b %5.1f \n", $D2B ;
printf "clientput [run d2b %5.1f]\n", $D2B ;
printf "clientput run d2t %5.1f \n", $D2T ;
printf "clientput [run d2t %5.1f]\n", $D2T ;
printf "clientput run d3b %5.1f \n", $D3B ;
printf "clientput [run d3b %5.1f]\n", $D3B ;
printf "clientput run d3t %5.1f \n", $D3T ;
printf "clientput [run d3t %5.1f]\n", $D3T ;
printf "clientput run soz %5.1f \n", $SOZ ;
printf "clientput [run soz %5.1f]\n", $SOZ ;
printf "clientput run com %5.1f \n", $com ;
printf "clientput [run com %5.1f]\n", $com ;
printf "clientput run cox %5.1f \n", $COX ;
printf "clientput [run cox %5.1f]\n", $COX ;
printf "clientput run coz %5.1f \n", $COZ ;
printf "clientput [run coz %5.1f]\n", $COZ ;
#
# The End *

9
tmp/rafin.bck
View File

@ -1,9 +0,0 @@
HoNi2B2C
1 1 1 0 5. 10.0
0 1.1781
0 0.0 0 0.0 0 0.0 0 0.0
0 3.51 0 3.51 0 10.53 0 90. 0 90. 0 90.
0 0 3 19.34 147.218 180. 0.
2 0 0 39.57 67.165 180. 0.
0 2 0 39.57 18. 90. 0.
0

21
tmp/rafin.dat
View File

@ -1,21 +0,0 @@
1/3 1/3 2 map 5K, CuCrO2
2 1 0 0 45 3 4 1 .5 0
0 1.178
0 .0 0 .0 0 .0
0 2.9667 0 2.9667 0 17.3977 0 90 0 90 0 120
1.0000 1.0000 0.0000 46.742 23.322 182.960 178.382
-1.0000 2.0000 0.0000 46.740 23.244 182.601 238.437
0.0000 0.0000 6.0000 23.867 11.737 92.919 77.023
0.0000 -2.0000 1.0000 54.687 27.298 173.003 28.437
0.0000 1.0000 1.0000 26.807 13.375 175.101 208.398
1.0000 0.0000 2.0000 27.727 13.848 165.785 149.054
0.0000 -1.0000 5.0000 33.282 16.614 140.921 28.625
1.0000 0.0000 5.0000 33.270 16.627 145.492 150.046
-1.0000 1.0000 8.0000 41.915 20.725 131.535 265.171
1.0000 0.0000 8.0000 41.915 20.978 132.105 151.023
0.0000 2.0000 2.0000 55.172 27.515 174.425 208.367
-2.0000 0.0000 2.0000 55.177 27.515 170.078 328.031
3.0000 0.0000 0.0000 86.800 43.319 181.531 148.375
0.0000 3.0000 0.0000 86.802 43.319 182.796 208.429
-1

BIN
tmp/rafin.out
View File

Binary file not shown.

BIN
tmp/rafin.out.bck
View File

Binary file not shown.

3
tmp/sev.go
View File

@ -1,3 +0,0 @@
#
dr a4 20

8
tmp/shell80.go
View File

@ -1,8 +0,0 @@
title omega/2theta comparision with previous omega mode
sample omega/2theta
dataset close
dataset psimode 0
exe tmp/standard-reduced.go
stt softlowerlim 5
stt softupperlim 120
mess measure tmp/all.hkl

7
tmp/standard-reduced.go
View File

@ -1,7 +0,0 @@
mess countmode timer
mess preset 1
mess step .04
mess np 31
four
exe tmp/li.ub
#end

2
tmp/t.go
View File

@ -1,2 +0,0 @@
exec /usr/bin/nassnase

18
tmp/table.res
View File

@ -1,18 +0,0 @@
mess countmode monitor
#read hkl only
mess psimode 0
#
mess table clear
#
mess table add 35 om 0.035 40 10000
mess table add 50 om 0.040 40 10000
mess table add 70 om 0.050 40 10000
mess table add 80 om 0.050 40 15000
# makes om/2theta-scans for stt>90 deg
mess table add 90 o2t 0.070 40 20000
mess table add 100 o2t 0.080 40 20000
mess table add 110 o2t 0.090 40 25000
mess table add 120 o2t 0.012 40 30000
#end table
mess table list
#end

Some files were not shown because too many files have changed in this diff Show More