- Added a user specific range test to the astrium driver for the POLDI

- Added speed parameter to phytron
- Added new drivers for EL755 magnets and the PI DC-406 motor controller

tcl/astrium.tcl

@@ -457,7 +457,21 @@ if {$poldi == 1} {
 	}
 	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]
@@ -471,7 +485,20 @@ if {$poldi == 1} {
     set maxspeed 15000
     set minphase 80
     astriumMakeChopperParameters
-    astMakeChopperSpeed1 chopperspeed
+#    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

tcl/el755.tcl

@@ -0,0 +1,97 @@
+#-------------------------------------------------------------
+# 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
+}

tcl/hdbutil.tcl

@@ -700,6 +700,7 @@ proc makemumo {rootpath mumoname} {
 #-----------------------------------------------------------------
 proc hdbbatchpath {pathstring} {
     exe batchpath $pathstring
+    catch {batchroot $pathstring}
     catch {hupdate /instrument/commands/batch/execute/file/values}
     catch {hupdate /instrument/commands/batch/batchpath}
     catch {hupdate /instrument/experiment/batchpath}

tcl/phytron.tcl

@@ -34,14 +34,25 @@
 # - writing postion:
 #    setpos - setrcv
 #
-#  reading status:
+# - 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 {}
@@ -145,6 +156,32 @@ proc phytron::statend {axis} {
     sct update idle
     return idle
 }
+#------------------------------------------------------------------------
+proc phytron::readspeed {axis} {
+    sct send "0${axis}P14R"
+    return rcvspeed
+}
+#------------------------------------------------------------------------
+proc phytron::rcvspeed {} {
+    set data [phyton::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 [phyton::check]
+    if {[string first NACK $data] >= 0} {
+	error "Invalid command"
+    }
+    return [phytron::readspeed $axis]
+}
 #-------------------------------------------------------------------------
 proc phytron::halt {controller axis} {
     $controller send "0${axis}SN"
@@ -201,6 +238,13 @@ proc phytron::make {name axis controller lowlim upperlim} {
     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
+
     $name makescriptfunc halt "phytron::halt $controller $axis" user
 
     $name makescriptfunc refrun "phytron::refrun $name $controller $axis $lowlim" user
@@ -210,6 +254,7 @@ proc phytron::make {name axis controller lowlim upperlim} {
 
     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 

tcl/pimotor.tcl

@@ -0,0 +1,156 @@
+#----------------------------------------------------
+# 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 
+}

tcl/stddrive.tcl

@@ -0,0 +1,100 @@
+#------------------------------------------------------
+# 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 OK
+}
+#-------------------------------------------------------
+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 internal 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
+}