#!/usr/bin/perl
#$Id: serial-socket-server-9.0.pl,v 1.74 2025/06/30 07:17:07 sqko Exp $
use POSIX qw(strftime);
use Device::SerialPort;
use Fcntl qw(:DEFAULT :flock);
use IO::Socket;
use IO::Interface::Simple;
use strict;
use warnings;
use Sys::Hostname;

my $VERSION = '$Revision: 1.74 $';
my $debug = 0;
if (!@ARGV)
{
    die "Not enough parameters for serial-socket-server\nUsage: serial-socket-server DEVICE BAUDRATE [OPT DEVICE TO EMULATE] [opt --host IP-ADDR]\n";
}
my $temp_flag = 0;
my $this_host = undef;
if (scalar(@ARGV) > 0)
{
    for(my $x = 0; $x < scalar(@ARGV);$x++)
    {
        if ($ARGV[$x] =~ /--version/)
        {
            print "$0 is: $VERSION\n";
            exit 0;
        }
        if ($ARGV[$x] =~ /--debug/)
        {
            $debug = 1;
        }
        if ($ARGV[$x] =~ /--host/)
        {
            $this_host = $ARGV[$x+1];
        }
        if ($ARGV[$x] =~ /--temp$|-t$/)
        {
            $temp_flag = 1;
        }
    } 
}


########  Determine if sleep between commands are nescesarry ####
########  (all got a 'select undef,undef,undef,$minipause;' though  ####
my $ICPsleep = 0;
my $brookssleep = 0;
my $pause = 1.0;
my $rawpause = 0.1;
my $modbussleep = 0;
my $bisynchsleep = 0;
my $deltasleep = 0.1;
my $hmpsleep = 0.1;
my $julaboPause = 0.3;
my $minipause = 0.1;    #### Used for non ICP comms ####
### Do not set below 0.2 for multiread of AD converter ####
### Do not set below 0.1 for relayread ####
my $ICPminipause = 0.1;
my $ICPminipause_ad_multi = 0.2;
### Keithley delays
my $Keithleyminipause = 0.2;
my $Keithleysleep = 0;
my $keithley_conf = '';
my $keithley_cards = '';


my %name = ();  ### Brooks tagnames ###
my %type = ();  ### Brooks typesnames ###
my $brooks_baudrate = 19200;
my $linkam_baudrate = 19200;  ## The linkam controler barfs on anything but 19200
my $brooks_parity   = "odd";
my $str;
my $crc = '';
#### Determine if crc program is present, abort if not ####
#my $crc = '/usr/local/bin/crc';
#die "$crc not found!\n" unless (-e $crc);
### NB removed as CRC checks for brooks are now handled internally by the crc() function! ###
my $tescomcrc = '/usr/local/bin/tescom_crc';
die "$tescomcrc not found!\n" unless (-e $tescomcrc);
my $omroncrc = '/usr/local/bin/omron_crc16';
die "$omroncrc not found!\n" unless (-e $omroncrc);

##### Setup hash of functions ####
my %cmdlst = ();
$cmdlst{'quit'} = \&quit;
$cmdlst{'ping'} = \&ping;
$cmdlst{'brooks'} = \&brooks;
$cmdlst{'temp'} = \&bisynch;
$cmdlst{'modbus'} = \&modbus;
$cmdlst{'omron'} = \&omron;
$cmdlst{'bronkhorst'} = \&bronkhorst;
$cmdlst{'init'} = \&PSU_init_31;
$cmdlst{'current'} = \&PSU_set_31;
$cmdlst{'volt'} = \&PSU_set_volt_31;
$cmdlst{'debug'} = \&set_debug;
$cmdlst{'pause'} = \&set_pause;
$cmdlst{'version'} = \&version;
$cmdlst{'delta'} = \&delta;
$cmdlst{'hmp'} = \&hmp;
$cmdlst{'elektro'} = \&elektro;
$cmdlst{'tescom'} = \&tescom;
$cmdlst{'mks'} = \&mks;
$cmdlst{'linkam'} = \&linkam;
$cmdlst{'keithley'} = \&Keithley;
$cmdlst{'relay'} = \&ICP_relay;
$cmdlst{'volt_set'} = \&ICP_volt_set;
$cmdlst{'flow'} = \&ICP_volt_set;
$cmdlst{'strgr'} = \&ICP_straing_get;
$cmdlst{'strgs'} = \&ICP_straing_set;
$cmdlst{'strgch'} = \&ICP_straing_channel;
$cmdlst{'da'} = \&da;
$cmdlst{'icptest'} = \&ICP_test;
$cmdlst{'icp_raw'} = \&ICP_raw;
$cmdlst{'bk_raw'} = \&BK_raw;
$cmdlst{'ad'} = \&ad;
$cmdlst{'multiplex'} = \&ICP_multiplex;
$cmdlst{'raw'} = \&raw;
$cmdlst{'icpmultiread'} = \&ICP_multi_ad;
$cmdlst{'icp7017read'} = \&ICP_7017_multi;
$cmdlst{'relay_crc'} = \&ICP_relay_crc;
$cmdlst{'volt_set_crc'} = \&ICP_volt_set_crc;
$cmdlst{'flow_crc'} = \&ICP_volt_set_crc;
$cmdlst{'strgr_crc'} = \&ICP_straing_get_crc;
$cmdlst{'strgs_crc'} = \&ICP_straing_set_crc;
$cmdlst{'strgch_crc'} = \&ICP_straing_channel_crc;
$cmdlst{'da_crc'} = \&da_crc;
$cmdlst{'icptest_crc'} = \&ICP_test_crc;
$cmdlst{'icp_raw_crc'} = \&ICP_raw_crc;
$cmdlst{'ad_crc'} = \&ad_crc;
$cmdlst{'multiplex_crc'} = \&ICP_multiplex_crc;
$cmdlst{'raw_crc'} = \&raw_crc;
$cmdlst{'icpmultiread_crc'} = \&ICP_multi_ad_crc;
$cmdlst{'icp7017read_crc'} = \&ICP_7017_multi_crc;
$cmdlst{'julabo_default'} = \&julabo_default;
$cmdlst{'julabo_raw'} = \&julabo_raw;
$cmdlst{'cal_temp'} = \&cal_temp;



my %allow_remote = (
    'quit' => 0,
    'ping' => 1,
    'brooks' => 1,
    'temp' => 1,
    'modbus' => 1,
    'omron' => 1,
    'bronkhorst' => 1,
    'init' => 0,
    'current' => 1,
    'volt' => 1,
    'debug' => 0,
    'pause' => 0,
    'version' => 1,
    'delta' => 1,
    'hmp' => 1,
    'elektro' => 1,
    'tescom' => 1,
    'mks' => 1,
    'linkam' => 1,
    'relay' => 1,
    'volt_set' => 1,
    'flow' => 1,
    'strgr' => 1,
    'strgs' => 1,
    'strgch' => 1,
    'da' => 1,
    'icptest' => 1,
    'icp_raw' => 1,
    'bk_raw' => 1,
    'ad' => 1,
    'multiplex' => 1,
    'raw' => 1,
    'icpmultiread' => 1,
    'icp7017read' => 1,
    'relay_crc' => 1,
    'volt_set_crc' => 1,
    'flow_crc' => 1,
    'strgr_crc' => 1,
    'strgs_crc' => 1,
    'strgch_crc' => 1,
    'da_crc' => 1,
    'icptest_crc' => 1,
    'icp_raw_crc' => 1,
    'ad_crc' => 1,
    'multiplex_crc' => 1,
    'raw_crc' => 1,
    'icpmultiread_crc' => 1,
    'icp7017read_crc' => 1,
    'keithley' => 1,
    'cal_temp' => 1,
    );

#### Base port number is 202020, added to this is the ttys nr ###
#### EG ttyS0 => 202020, ttyS4 => 202024 etc.                 ###
my $portbase = 202020;
#### Try to get ip address of netwrok interface ###
my @ilst = ('eth','em','en','lo');
my $local = '';
my @ifl = IO::Interface::Simple->interfaces();
OUTER:
foreach my $try (@ilst)
{
    foreach my $interface (@ifl)
    {
	if ($interface =~ /$try/)
	{
	    my $if = IO::Interface::Simple->new($interface);
	    $local = $if->address();
	    last OUTER if ($local);
	}
    }
}
### Use localhost if everything else fails ###
$local = 'localhost' unless ($local);
$local = $this_host if ($this_host);
$| = 1;
my $pre = sprintf "%c%c%c%c%c", 255, 255, 255, 255, 255;
my $cmdpre = sprintf "%c%c", 130, 138;
my $serialport = shift;
$serialport =~ /(\d+)/;
my $port = $portbase + $1;

my $file = "/dev/" . $serialport;
my $lockfile = "/var/lock/" . $serialport . "..lock";
### Initalise serial port ####

my $ob = Device::SerialPort->new($file) or die "Can't start $file\n";
my $baudrate        = 9600;
$baudrate = shift if (@ARGV);
$deltasleep = 0.5 if ($baudrate < 9600);
my $parity          = "none";
my $pwdctr = 1;
$pwdctr = 0 unless ($baudrate == 9600);

if (@ARGV)
{
    my $p = shift;
    if ($p =~ /(\d+)/)
    {
	$port = $portbase + $1;
    }
}

$ob->baudrate($baudrate) || die "fail setting baudrate";
$ob->parity($parity)     || die "fail setting parity";
$ob->databits(8)         || die "fail setting databits";
$ob->stopbits(1)         || die "fail setting stopbits";
$ob->handshake("none")   || die "fail setting handshake";
$ob->datatype("raw")     || die "fail setting handshake";


my $ip = inet_ntoa(inet_aton($local));
$port = $port & 0xffff;
print "Using host $local and port $port\n" if ($debug);
### Bind to socket ###
my $sock = new IO::Socket::INET(
    LocalHost => $local,
    LocalPort => $port,
    Proto  => 'tcp',
    Listen => 10,
    Reuse  => 1
);
die "Could not create socket: $!\n" unless $sock;
$| = 1;
my $new_sock;
while ( $new_sock = $sock->accept() ) 
{
    if ($debug)
    {
	print strftime "%Y:%m:%d:%H:%M:%S", localtime;
    }
    my $other_end = getpeername($new_sock);
    my ( $port, $iaddr ) = unpack_sockaddr_in($other_end);
    my $ip_address = inet_ntoa($iaddr);
    print "  ",$ip_address, "\n" if ($debug);
    if (my $str = <$new_sock>) {
        my ($cmd,@args) = split (/[\s\t]+/,$str);
	$cmd = lc($cmd);
	print $str if ($debug);
	if ($cmd && $cmdlst{$cmd})
	{
	    my $res = '';
            ### Blok requests from remote systems unless it is public ###
            if (&allow_request($ip_address,$cmd))
            {
		$res = $cmdlst{$cmd}->(@args);
	    }
	    print "Result: $res\n\n" if ($debug);
	    print $new_sock $res if (defined($res));
	}
	close $new_sock;
    }
    else
    {
	close $new_sock;
    }
}
close($sock);
exit;

sub ping()
{
    return "$0 listening on $port";
}

sub allow_request()
{
    my $client = shift;
    my $cmd = shift;
    return 1 if ($allow_remote{$cmd});
    return 1 if ($client eq $ip);
    return 0;
}


sub linkam
{
    my $ok = '';
    my $cmd = shift;
    &setlinkam();
    if ($cmd eq 'get')
    {
        my $s = 'T'."\r";
        print "send >>", $s if ($debug);
        $ob->write($s);
        select undef, undef, undef, 0.1;
        my $r = $ob->input;
        my @l = split(//,$r);
        my @d = ();
        for (my $x = 6; $x < 10; $x++)
        {
            push @d,hex($l[$x]);
        }
        $ok = ($d[0]*16**3+$d[1]*16**2+$d[2]*16+$d[3])/10;
    }
    if ($cmd eq 'T')
    {
        my $s = 'T'."\r";
        print "send >>", $s if ($debug);
        $ob->write($s);
        select undef, undef, undef, 0.1;
        my $r = $ob->input;
        my @l = split(//,$r);
        foreach (@l)
        {
            $ok .= ord($_).':'.$_."\n";
        }
    }
    if ($cmd eq 'temp')
    {
        my $t = shift;
        $t *= 10;
        my $s = 'L1'.int($t)."\r";
        print "send >>", $s if ($debug);
        $ob->write($s);
        select undef, undef, undef, 0.2;
        my $r = $ob->input;
	$ok = $r;
        print $r,"\n" if ($debug);
    }
    if ($cmd eq 'ramp')
    {
        my $t = shift;
        $t *= 100;
        my $s = 'R1'.int($t)."\r";
        print "send >>", $s if ($debug);
        $ob->write($s);
        select undef, undef, undef, 0.2;
        my $r = $ob->input;
	$ok = $r;
        print $r,"\n" if ($debug);
    }    
    if ($cmd eq 'raw')
    {
        my $s = shift()."\r";
        print "send >>", $s if ($debug);
        $ob->write($s);
        select undef, undef, undef, 0.2;
        my $r = $ob->input;
	$ok = $r;
        print $r,"\n" if ($debug);
    }
    &resetlinkam();
    return $ok;
}

sub quit
{
    print $new_sock "quit command received, exiting", "\n\n";
    close $new_sock;
    close $sock;
    exit;
}

sub version
{
    return "$VERSION";
}

sub set_pause
{
    my $cmd = shift;
    if ($cmd && $cmd =~ /[\d\.]+/)
    {
	$rawpause = $cmd+0;
    }
    return $rawpause;
}

sub set_debug
{
    my $cmd = shift;
    if ($cmd)
    { 
	if ($cmd =~ /enable/i)
	{
	    $debug = 1;
	    return "Debug on";
	}
	if ($cmd =~ /disable/i)
	{
	    $debug = 0;
	    return "Debug off";
	}
    }
    else
    {
	if ($debug)
	{
	    $debug = 0;
	    return "Debug off";
	}
	$debug = 1;
	return "Debug on";
    }
}


sub julabo_default
{
    my $inp = join(' ',@_);
    print "julabo_default $inp\n" if ($debug);
    return "Error: Not enough parameters for raw communication: $inp" unless (@_ > 0);
    $ob->baudrate( 4800 ) || die "fail setting baudrate";
    $ob->parity( "even" )   || die "fail setting parity";
    $ob->databits( 7 ) || die "fail setting databits";
    $ob->stopbits( 1 ) || die "fail setting stopbits";
    $ob->handshake("rts") || die "fail setting handshake";
    $ob->datatype("raw")   || die "fail setting datatype";
    my $s = $_[0] ;
    $s = $s . " " . $_[1] if(defined $_[1]);
    $s = $s . "\r\n";
    print "send >>", $s if ($debug);
    $ob->write($s);
    select undef, undef, undef, $julaboPause;
    
    my $r = $ob->input;
    if($r eq ""){   # returns no message read status
	select undef, undef, undef, 0.1;
	$ob->write("status\r\n");
	select undef, undef, undef, $julaboPause;
                
	$r = $ob->input;
    }
    &set_comm();                # set back default $ob settings  
    $r =~ s/[\r\n]//g if (defined($r));      # remove CR
    return $r ;
}


sub julabo_raw
{
    my $inp = join(' ',@_);
    print "julabo_default $inp\n" if ($debug);
    return "Error: Not enough parameters for raw communication: $inp" unless (@_ > 3);
    $ob->baudrate( $_[0] ) || die "fail setting baudrate";
    $ob->parity( $_[1] )   || die "fail setting parity";
    $ob->databits( 7 ) || die "fail setting databits";
    $ob->stopbits( 1 ) || die "fail setting stopbits";
    $ob->handshake($_[2]) || die "fail setting handshake";
    $ob->datatype("raw")   || die "fail setting datatype";
    my $s = $_[3];
    $s = $s . " " . $_[4] if(defined($_[4]));
    $s = $s . "\r\n";
    print "send >>", $s if ($debug);
    $ob->write($s);
    select undef, undef, undef, $julaboPause;   
    my $r = $ob->input;
    if($r eq ""){   # returns no message read status
	select undef, undef, undef, 0.1;
	$ob->write("status\r\n");
	select undef, undef, undef, $julaboPause;
                
	$r = $ob->input;
    }
    &set_comm();            # set back default $ob settings 
    $r =~ s/[\r\n]//g if (defined($r));      # remove CR
    return $r;
}

sub tescom
{
    my $adr = shift;
    my $mode = shift;
    if ($mode =~ /^r$/i)
    {
        my $tag = shift;
        my @list = ($adr,2,2,$tag);
        my $cstr = $tescomcrc.' '.join(' ',@list);
        my $res = `$cstr`;
        my @crc = split(/[\s\t]+/,$res);
        push @list,@crc;
        my @chs = ();
        foreach my $s (@list)
        {
            printf("%0x\n",$s) if ($debug);
            push @chs,chr($s);
        }
        $ob->write(join('',@chs));
        select(undef,undef,undef,0.1);
        my $r = $ob->input;
        my @res = split(//,$r);
        foreach my $c (@res)
        {
            printf("%0x\n",ord($c)) if ($debug);
        }
        if (@res > 4)
        {
            my $high = ord($res[2]);
            my $low = ord($res[3]);
            my $val = $high*256+$low;
            print "Result: $val\n" if ($debug);
            return $val;
        }
    }
    if ($mode =~ /^sr$/i)
    {
        my $tag = shift;
        my @list = ($adr,2,10,$tag);
        my $cstr = $tescomcrc.' '.join(' ',@list);
        my $res = `$cstr`;
        my @crc = split(/[\s\t]+/,$res);
        push @list,@crc;
        my @chs = ();
        foreach my $s (@list)
        {
            printf("%0x\n",$s) if ($debug);
            push @chs,chr($s);
        }
        $ob->write(join('',@chs));
        select(undef,undef,undef,0.1);
        my $r = $ob->input;
	my @res = split(//,$r);
        foreach my $c (@res)
        {
            printf("%0x\n",ord($c)) if ($debug);
        }
        if (@res > 7)
        {
            my $type = ord($res[2]);
            my $high1 = ord($res[3]);
            my $low1 = ord($res[4]);
            my $val1 = $high1*256+$low1;
            my $high2 = ord($res[5]);
            my $low2 = ord($res[6]);
            my $val2 = $high2*256+$low2;
            print "Result: Type: $type, values: $val1,$val2\n" if ($debug);
            return "$type $val1 $val2";
        }
    }
    if ($mode =~ /^w$/)
    {
        my $tag = shift;
        my $value = shift;
        my $low = $value%256;
        my $high = POSIX::floor($value/256);
        my @list = ($adr,4,1,$tag,$high,$low);
        my $cstr = $tescomcrc.' '.join(' ',@list);
        my $res = `$cstr`;
        my @crc = split(/[\s\t]+/,$res);
        push @list,@crc;
        my @chs = ();
        foreach my $s (@list)
        {
            printf("%0x\n",$s) if ($debug);
            push @chs,chr($s);
        }
        $ob->write(join('',@chs));
        select(undef,undef,undef,0.1);
        my $r = $ob->input;
        my @res = split(//,$r);
        foreach my $c (@res)
        {
            printf("%0x\n",ord($c)) if ($debug);
        }
        if (ord($res[0]) == 0 && ord($res[1]) == 1 && ord($res[2]) == 0)
        {
            return "OK";
        }
        else
        {
            return "ERROR!";
        }
    }
    if ($mode =~ /^sw$/)
    {
        my $tag = shift;
        my $type = shift;
        my $value1 = shift;
        my $value2 = shift;
        my $low1 = $value1%256;
        my $high1 = POSIX::floor($value1/256);
        my $low2 = $value2%256;
        my $high2 = POSIX::floor($value2/256);
        my @list = ($adr,7,9,$tag,$type,$high1,$low1,$high2,$low2);
        my $cstr = $tescomcrc.' '.join(' ',@list);
        my $res = `$cstr`;
        my @crc = split(/[\s\t]+/,$res);
	push @list,@crc;
	my @chs = ();
	foreach my $s (@list)
	{
            printf("%0x\n",$s) if ($debug);
            push @chs,chr($s);
	}
        $ob->write(join('',@chs));
        select(undef,undef,undef,0.1);
        my $r = $ob->input;
        my @res = split(//,$r);
        foreach my $c (@res)
        {
            printf("%0x\n",ord($c)) if ($debug);
        }
        if (ord($res[0]) == 0 && ord($res[1]) == 1 && ord($res[2]) == 0)
        {
            return "OK";
        }
        else
        {
            return "ERROR!";
        }
    }
}


sub ICP_relay_crc
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "RELAY $inp\n";
    return "Error: Not enough parameters for setting relay: $inp\n" unless (@_ > 2);
    if ( ( $_[0] =~ /^\d+$/ ) && ( $_[1] =~ /^\d+$/ ) && ($_[2] =~ /^\d+$/) ) {
	
	my $s1 = sprintf "%02d", $_[0];
	my $s2 = sprintf "1%1d", $_[1];
	my $s3 = sprintf "0%1d", $_[2];
	my $s = "#" . $s1 . $s2 . $s3 . "\r\n";
	my $r = icp_comm_crc($s);
	$res = "RELAY  $inp ". $s;
	if ( $r =~ /\>/ )
	{
	    $res .= " ok\n"; 
	}
	else
	{
	    $res .= "Error: Module not responding!\n";
	}
    }
    return $res;
}

sub ICP_relay
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "RELAY $inp\n";
    return "Error: Not enough parameters for setting relay: $inp\n" unless (@_ > 2);
    if ( ( $_[0] =~ /^\d+$/ ) && ( $_[1] =~ /^\d+$/ ) && ($_[2] =~ /^\d+$/) ) {
	
	my $s1 = sprintf "%02d", $_[0];
	my $s2 = sprintf "1%1d", $_[1];
	my $s3 = sprintf "0%1d", $_[2];
	my $s = "#" . $s1 . $s2 . $s3 . "\r\n";
	print "send >>", $s if ($debug);
	$ob->write($s);
	select undef, undef, undef, $ICPminipause;
	sleep($ICPsleep);
	my $r = $ob->input;
	$res = "RELAY  $inp ". $s;
	if ( $r =~ /\>/ )
	{
	    $res .= " ok\n"; 
	}
	else
	{
	    $res .= "Error: Module not responding!\n";
	}
    }
    return $res;
}

sub brooks
{
    my $inp = join(' ',@_);
    print "BROOKS $inp\n" if ($debug);
    my $res = undef;
    return "Error: Not enough prameters for brooks communication: $inp\n" unless (@_ > 1);
    my $brooksname   = shift;
    my $brooksaction = shift;
    if ( $brooksaction =~ /INIT/i )  {
	return &brooksinit($brooksname);
    }
    if ( !( $name{$brooksname} ) ) 
    { 
	&brooksinit($brooksname);
	if ( !( $name{$brooksname} ) ) 
	{
	    return "Error: Could not initialise brooks tagnr $brooksname!\n";
	}
    }
    if ( $brooksaction =~ /SETFLOW/i ) 
    {
	$res = &setflow( $brooksname, @_ );
    }
    if ( $brooksaction =~ /READFLOW/i ) 
    {
	$res = &readflow($brooksname);
    }
    if ( $brooksaction =~ /OVERRIDE/i ) 
    {
	$res = &setoverride( $brooksname,  @_ );
    }
    if ( $brooksaction =~ /QUERY/i ) 
    {
        return &brooks_query($brooksname, @_ );
    }
    return $res;
}

sub ICP_volt_set_crc
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "VOLT_SET $inp\n" if ($debug);
    return "Error: Not enough parameters for Volt set: $inp\n" unless (@_ > 1);
    if ( ( $_[0] =~ /^\d+$/ ) && ( $_[1] =~ /^\d+$/ ) ) {
	
	my $s1 = sprintf "%02d",    $_[0];
	my $s2 = sprintf "%1d",     $_[1];
	my $s3 = sprintf "%+07.3f", $_[2];
	my $s = "#" . $s1 . $s2 . $s3 . "\r\n";
	my $r = icp_comm_crc($s);
	$res .= "Volt_set $inp ". $s;
	if ( $r =~ /\>/ )
	{
	    $res .= " ok\n"; 
	}
	else
	{
	    $res .= "Error: Module not responding!\n";
	}
    }
    return $res;
}

sub ICP_volt_set
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "VOLT_SET $inp\n" if ($debug);
    return "Error: Not enough parameters for Volt set: $inp\n" unless (@_ > 1);
    if ( ( $_[0] =~ /^\d+$/ ) && ( $_[1] =~ /^\d+$/ ) ) {
	
	my $s1 = sprintf "%02d",    $_[0];
	my $s2 = sprintf "%1d",     $_[1];
	my $s3 = sprintf "%+07.3f", $_[2];
	my $s = "#" . $s1 . $s2 . $s3 . "\r\n";
	print "send >>", $s if ($debug);
	$ob->write($s);
	select undef, undef, undef, $ICPminipause;
	sleep($ICPsleep);
	my $r = $ob->input;
	$res .= "Volt_set $inp ". $s;
	if ( $r =~ /\>/ )
	{
	    $res .= " ok\n"; 
	}
	else
	{
	    $res .= "Error: Module not responding!\n";
	}
    }
    return $res;
}


sub ICP_straing_get_crc
{
    my $inp = join(' ',@_);
    print "STRGR $inp\n" if ($debug);
    return "Error: Not enough paramterss for straingauge read: $inp\n" unless (defined($_[0]));
    my $s = sprintf "\#%02d\r\n", $_[0];
    my $res = icp_comm_crc($s);
    if ($res =~ /\w/)
    {
	return $res;
    }
    else
    {
	return "Module at address $_[0] not responding!\n";
    }
}

sub ICP_straing_get
{
    my $inp = join(' ',@_);
    print "STRGR $inp\n" if ($debug);
    return "Error: Not enough paramterss for straingauge read: $inp\n" unless (defined($_[0]));
    my $s = sprintf "\#%02d\r\n", $_[0];
    $ob->write($s);
    select undef, undef, undef, $ICPminipause;
    sleep($ICPsleep);
    my $res = $ob->input;
    if ($res =~ /\w/)
    {
	return $res;
    }
    else
    {
	return "Module at address $_[0] not responding!\n";
    }
}

sub ICP_straing_channel_crc
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "STRGS $inp\n" if ($debug);
    return "Error: Not enough paramters for straingauge set: $inp\n" unless (@_ > 1);
    if ( $_[0] =~ /^(\d+)$/ ) 
    {
	my $ch = $1;
	if ($_[1] =~ /r/i)
	{
	    my $s1 = sprintf "%02d", $ch;
	    my $s2 = "3";
	    my $s  = '$' . $s1 . $s2 . "\r\n";
	    my $r = icp_comm_crc($s);
	    print $r if ($debug);
	    if ($r =~ /\!(\d{2})(\d)/)
	    {
		my $rch = $1;
		my $status = $2;
		return $res."Error in module configuration: module '$rch' responded instead of '$ch'!\n" unless ($rch == $ch);
		return $status."\n";
	    }
	    $res .= "Error: Module not responding!\n";
	}
	if (($_[1] =~ /w/i) && ($_[2] =~ /^(\d)$/))
	{
	    my $select = $1;
	    my $s1 = sprintf "%02d", $ch;
	    my $s2 = "3";
	    my $s  = '$' . $s1 . $s2 .$select. "\r\n";
	    my $r = icp_comm_crc($s);
	    if ($r =~ /\!(\d{2})/)
	    {
		return $res."Error in module configuration: module '$1' responded instead of '$ch'!\n" unless ($1 == $ch);
		$res .= " ok\n";
	    }
	    else
	    {
		$res .= "Error: Module not responding!\n";
	    }
	}
    }
    return $res;
}

sub ICP_straing_channel
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "STRGS $inp\n" if ($debug);
    return "Error: Not enough paramters for straingauge set: $inp\n" unless (@_ > 1);
    if ( $_[0] =~ /^(\d+)$/ ) 
    {
	my $ch = $1;
	if ($_[1] =~ /r/i)
	{
	    my $s1 = sprintf "%02d", $ch;
	    my $s2 = "3";
	    my $s  = '$' . $s1 . $s2 . "\r\n";
	    print "send >>", $s if ($debug);
	    $ob->write($s);
	    select undef, undef, undef, $ICPminipause;
	    sleep($ICPsleep);
	    my $r = $ob->input;
	    print $r if ($debug);
	    if ($r =~ /\!(\d{2})(\d)/)
	    {
		my $rch = $1;
		my $status = $2;
		return $res."Error in module configuration: module '$rch' responded instead of '$ch'!\n" unless ($rch == $ch);
		return $status."\n";
	    }
	    $res .= "Error: Module not responding!\n";
	}
	if (($_[1] =~ /w/i) && ($_[2] =~ /^(\d)$/))
	{
	    my $select = $1;
	    my $s1 = sprintf "%02d", $ch;
	    my $s2 = "3";
	    my $s  = '$' . $s1 . $s2 .$select. "\r\n";
	    print "send >>", $s if ($debug);
	    $ob->write($s);
	    select undef, undef, undef, $ICPminipause;
	    sleep($ICPsleep);
	    my $r = $ob->input;
	    if ($r =~ /\!(\d{2})/)
	    {
		return $res."Error in module configuration: module '$1' responded instead of '$ch'!\n" unless ($1 == $ch);
		$res .= " ok\n";
	    }
	    else
	    {
		$res .= "Error: Module not responding!\n";
	    }
	}
    }
    return $res;
}


sub ICP_straing_set_crc
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "STRGS $inp\n" if ($debug);
    return "Error: Not enough paramters for straingauge set: $inp\n" unless (@_ > 1);
    if ( ( $_[0] =~ /^\d+$/ ) && ( $_[1] =~ /^[\d\.\+\-eE]+$/ ) )
    {
	my $s1 = sprintf "%02d", $_[0];
	my $s2 = "7+";
	my $s3 = sprintf "%06.3f", $_[1];
	my $s  = '$' . $s1 . $s2 . $s3 . "\r\n";
	my $r = icp_comm_crc($s);
	$res .= 'Straingauge_set '. join(' ',@_). " ". $s;
	if ( $r =~ /\!/ )
	{
	    $res .= " ok\n"; 
	}
	else
	{
	    $res .= "Error: Module not responding!\n";
	}
    }
    return $res;
}

sub ICP_straing_set
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "STRGS $inp\n" if ($debug);
    return "Error: Not enough paramters for straingauge set: $inp\n" unless (@_ > 1);
    if ( ( $_[0] =~ /^\d+$/ ) && ( $_[1] =~ /^[\d\.\+\-eE]+$/ ) )
    {
	my $s1 = sprintf "%02d", $_[0];
	my $s2 = "7+";
	my $s3 = sprintf "%06.3f", $_[1];
	my $s  = '$' . $s1 . $s2 . $s3 . "\r\n";
	print "send >>", $s if ($debug);
	$ob->write($s);
	select undef, undef, undef, $ICPminipause;
	sleep($ICPsleep);
	my $r = $ob->input;
	$res .= 'Straingauge_set '. join(' ',@_). " ". $s;
	if ( $r =~ /\!/ )
	{
	    $res .= " ok\n"; 
	}
	else
	{
	    $res .= "Error: Module not responding!\n";
	}
    }
    return $res;
}

sub da_crc
{
    #### Under construction, may be inclomplete ###
    my $res = undef;
    my $inp = join(' ',@_);
    print "DA $inp\n" if ($debug);
    return "Error: Not enough parameters for DA communication: $inp\n" unless (@_ > 1);
    if ( ( $_[0] =~ /^\d+$/ ) && ( $_[1] =~ /^[\d\.+\-]+$/ ) ) {
	
	my $s1 = sprintf "%02d", $_[0];
	my $s2 = "";
	my $s3 = sprintf "%06.3f", $_[1];
	my $s  = "#" . $s1 . $s2 . $s3 . "\r\n";
	print "send >>", $s if ($debug);
	my $r = icp_comm_crc($s);
	$res .= "DA $inp". $s;
	if ( $r =~ /\>/ )
	{
	    $res .= " ok\n"; 
	}
	else
	{
	    $res .= "Error: Module not responding!\n";
	}
    }
    return $res;
}

sub da
{
    #### Under construction, may be inclomplete ###
    my $res = undef;
    my $inp = join(' ',@_);
    print "DA $inp\n" if ($debug);
    return "Error: Not enough parameters for DA communication: $inp\n" unless (@_ > 1);
    if ( ( $_[0] =~ /^\d+$/ ) && ( $_[1] =~ /^[\d\.+\-]+$/ ) ) {
	
	my $s1 = sprintf "%02d", $_[0];
	my $s2 = "";
	my $s3 = sprintf "%06.3f", $_[1];
	my $s  = "#" . $s1 . $s2 . $s3 . "\r\n";
	print "send >>", $s if ($debug);
	$ob->write($s);
	select undef, undef, undef, $ICPminipause;
	sleep($ICPsleep);
	my $r = $ob->input;
	$res .= "DA $inp". $s;
	if ( $r =~ /\>/ )
	{
	    $res .= " ok\n"; 
	}
	else
	{
	    $res .= "Error: Module not responding!\n";
	}
    }
    return $res;
}

sub bisynch
{
    my $inp = join(' ',@_);
    print "TEMP $inp\n" if ($debug);
    return "Error: Not enough parameters for bisynch communication: $inp\n" unless (@_ > 2);
    &set_euro_comm();
    my $ss = &read_packet( $_[1], $_[2] ); ## Default read ###
    if ( $_[0] =~ /R/i ) {
	$ss = &read_packet( $_[1], $_[2] );
    }
    if ( $_[0] =~ /W/i ) {
	$ss = &construct_packet( $_[1], $_[2], $_[3] );
    }	
    $ob->write($ss);
    select undef, undef, undef, $minipause;
    sleep($bisynchsleep);
    my $res .= &rbuf(). "\n";
    &set_comm();
    return $res;
}

sub unpackhex($)
{
    my $str = shift;
    my @l = split(//,$str);
    foreach (@l)
    {
        $_ = sprintf("%02x",ord($_));
    }
    print join(" ",@l),"\n" if ($debug);
}

sub cal_temp
{
    my $cmd = shift;
    my $adr = shift;
    my $tag = shift;
    my $hi = $tag / 256;
    my $lo = $tag % 256;
    my @list = ();
    push @list,sprintf("%02x",$adr);
    my $res = '';
    if ( $cmd =~ /R/i ) 
    {
        my $code = 0x03;
        my $read_high = 0x00;
        my $read_low = 0x01;
        foreach ($code,$hi,$lo,$read_high,$read_low)
        {
            push @list,sprintf("%02x",$_);
        }
        my $cmd = join(' ',$omroncrc,@list);
        my $crc = `$cmd`;
        push @list,split(/\s+/,$crc);
        print join(" ",@list),"\n" if ($debug);
        my $ss = '';
        foreach my $s (@list)
        {
            my $nr = hex('0x'.$s);
            $ss .= chr($nr);
        }
        $ob->write($ss);
       for ( 0 .. length($ss) - 1 ) {
            print ord( substr( $ss, $_, 1 ) ), "\n" if ($debug);
        }
        select undef, undef, undef, $minipause;
        my $rep  = &rbuf();
        my $srep = "";
        print "Recieved:\n" if ($debug);
        my @l = ();
        for ( 0 .. length($rep) - 1 ) {
            print ord( substr( $rep, $_, 1 ) ), "\n" if ($debug);
            $srep .= ord( substr( $rep, $_, 1 ) );
            push @l,ord( substr( $rep, $_, 1 ) );
            $srep .= " ";
        }
        print $srep,"\n" if ($debug);
        my @list = ();
        my @repl = @l;
        for my $c (splice(@repl,0,@repl-2))
        {
            push @list,sprintf("%02x",$c);
        }
        $cmd = join(' ',$omroncrc,@list);
        $crc = `$cmd`;
        push @list,split(/\s+/,$crc);
        unless ((@l > 2) && ($list[-2] eq sprintf("%02x",$l[-2]) && $list[-1] eq sprintf("%02x",$l[-1])))
        {
            my $str = "Warning CRC mismatch or no reply from cal controler $adr!";
            $srep .= ' '.$str;
            warn $str,"\n";
        }
       if (@l > 5 && $l[1] == 3)
        {
            my $val = $l[3] * 256 + $l[4];
            $srep .= ' '.sprintf("%6i",$val);
        }
        elsif (@l > 1)
        {
            $srep = 'Error: code '.$l[2];
        }
        $res = $srep. "\n";
    }
    if ( $cmd =~ /w/i ) 
    {
        print "Write to controler\n" if ($debug);
        ## enable write
        my @list = ();
        foreach ($adr,0x06,0x03,0x00,0x00,0x05)
        {
            push @list,sprintf("%02x",$_);
        }       
        my $cmd = join(' ',$omroncrc,@list);
        my $crc = `$cmd`;
        push @list,split(/\s+/,$crc);
        print join(" ",@list),"\n" if ($debug);
        my $ss = '';
        foreach my $s (@list)
        {
            my $nr = hex('0x'.$s);
            $ss .= chr($nr);
        }
        $ob->write($ss);
        for ( 0 .. length($ss) - 1 ) {
            print ord( substr( $ss, $_, 1 ) ), "\n" if ($debug);
        }
        select undef, undef, undef, $minipause;
        my $rep  = &rbuf();
        my $srep = "";
        print "Recieved:\n" if ($debug);
        my @l = ();
        for ( 0 .. length($rep) - 1 ) {
            print ord( substr( $rep, $_, 1 ) ), "\n" if ($debug);
            $srep .= ord( substr( $rep, $_, 1 ) );
            push @l,ord( substr( $rep, $_, 1 ) );
            $srep .= " ";
        }
        print $srep,"\n" if ($debug);
        if ( $cmd =~ /s/i )
        {
            print "Sending security message\n" if ($debug);
            ## Security message
            @list = ();
            foreach ($adr,0x06,0x15,0x00,0x00,0x00)
            {
                push @list,sprintf("%02x",$_);
            }   
            $cmd = join(' ',$omroncrc,@list);
            $crc = `$cmd`;
            push @list,split(/\s+/,$crc);
            print join(" ",@list),"\n" if ($debug);
            $ss = '';
            foreach my $s (@list)
            {
                my $nr = hex('0x'.$s);
                $ss .= chr($nr);
            }
            $ob->write($ss);
            for ( 0 .. length($ss) - 1 ) {
                print ord( substr( $ss, $_, 1 ) ), "\n" if ($debug);
            }
            select undef, undef, undef, $minipause;
            $rep  = &rbuf();
            $srep = "";
            print "Recieved:\n" if ($debug);
            @l = ();
            for ( 0 .. length($rep) - 1 ) {
                print ord( substr( $rep, $_, 1 ) ), "\n" if ($debug);
                $srep .= ord( substr( $rep, $_, 1 ) );
                push @l,ord( substr( $rep, $_, 1 ) );
                $srep .= " ";
            }
            print $srep,"\n" if ($debug);
        }
        print "Setting actual value\n" if ($debug);
        ## Write value
        my $code = 0x06;
        my $value = shift;
        my $vhi = $value / 256;
        my $vlo = $value % 256;
        @list = ();
        foreach ($adr,$code,$hi,$lo,$vhi,$vlo)
        {
            push @list,sprintf("%02x",$_);
        }
        $cmd = join(' ',$omroncrc,@list);
        $crc = `$cmd`;
        push @list,split(/\s+/,$crc);
        print join(" ",@list),"\n" if ($debug);
        $ss = '';
        foreach my $s (@list)
        {
            my $nr = hex('0x'.$s);
            $ss .= chr($nr);
        }
        $ob->write($ss);
        for ( 0 .. length($ss) - 1 ) {
            print ord( substr( $ss, $_, 1 ) ), "\n" if ($debug);
        }
        select undef, undef, undef, $minipause;
        $rep  = &rbuf();
        $srep = "";
       print "Recieved:\n" if ($debug);
        @l = ();
        for ( 0 .. length($rep) - 1 ) {
            print ord( substr( $rep, $_, 1 ) ), "\n" if ($debug);
            $srep .= ord( substr( $rep, $_, 1 ) );
            push @l,ord( substr( $rep, $_, 1 ) );
            $srep .= " ";
        }
        print $srep,"\n" if ($debug);
        @list = ();
        my @repl = @l;
        for my $c (splice(@repl,0,@repl-2))
        {
            push @list,sprintf("%02x",$c);
        }
        $cmd = join(' ',$omroncrc,@list);
        $crc = `$cmd`;
        push @list,split(/\s+/,$crc);
        unless ((@l > 2) && ($list[-2] eq sprintf("%02x",$l[-2]) && $list[-1] eq sprintf("%02x",$l[-1])))
        {
            my $str = "Warning CRC mismatch or no reply from cal controler $adr!";
            $srep .= ' '.$str;
            warn $str,"\n";
        }
        if (@l > 5 && $l[1] == 6)
        {
            my $val = $l[3] * 256 + $l[4];
            $srep .= ' '.sprintf("%6i",$val);
        }
        elsif (@l > 1)
        {
            $srep = 'Error: code '.$l[2];
        }
        $res = $srep. "\n";
        print "Exitting write\n" if ($debug);
        ## Exit write
        @list = ();
        foreach ($adr,0x06,0x03,0x00,0x00,0x06)
        {
            push @list,sprintf("%02x",$_);
        }       
        $cmd = join(' ',$omroncrc,@list);
        $crc = `$cmd`;
        push @list,split(/\s+/,$crc);
        print join(" ",@list),"\n" if ($debug);
        $ss = '';
        foreach my $s (@list)
        {
            my $nr = hex('0x'.$s);
            $ss .= chr($nr);
        }
        $ob->write($ss);
        for ( 0 .. length($ss) - 1 ) {
            print ord( substr( $ss, $_, 1 ) ), "\n" if ($debug);
        }
        select undef, undef, undef, $minipause;
        $rep  = &rbuf();
        $srep = "";
        print "Recieved:\n" if ($debug);
       @l = ();
        for ( 0 .. length($rep) - 1 ) {
            print ord( substr( $rep, $_, 1 ) ), "\n" if ($debug);
            $srep .= ord( substr( $rep, $_, 1 ) );
            push @l,ord( substr( $rep, $_, 1 ) );
            $srep .= " ";
        }
        print $srep,"\n" if ($debug);
        if ( $cmd =~ /s/i )
        {
            print "Sending security message\n" if ($debug);
            ## Security message
            @list = ();
            foreach ($adr,0x06,0x16,0x00,0x00,0x00)
            {
                push @list,sprintf("%02x",$_);
            }   
            $cmd = join(' ',$omroncrc,@list);
            $crc = `$cmd`;
            push @list,split(/\s+/,$crc);
            print join(" ",@list),"\n" if ($debug);
            $ss = '';
            foreach my $s (@list)
            {
                my $nr = hex('0x'.$s);
                $ss .= chr($nr);
            }
            $ob->write($ss);
            for ( 0 .. length($ss) - 1 ) {
                print ord( substr( $ss, $_, 1 ) ), "\n" if ($debug);
            }
            select undef, undef, undef, $minipause;
            $rep  = &rbuf();
            $srep = "";
            print "Recieved:\n" if ($debug);
            @l = ();
            for ( 0 .. length($rep) - 1 ) {
                print ord( substr( $rep, $_, 1 ) ), "\n" if ($debug);
                $srep .= ord( substr( $rep, $_, 1 ) );
                push @l,ord( substr( $rep, $_, 1 ) );
                $srep .= " ";
            }
            print $srep,"\n" if ($debug);
        }
        print "End write to controler\n" if ($debug);
    }
    return $res;
}



sub omron
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "OMRON $inp\n" if ($debug);
    return "Error: Not enough parameters for omron communication: $inp\n" unless (@_ > 2);
    &set_omron_comm();
    my $cmd = shift;
    my $adr = shift;
    my $tag = shift;
    my $hi = $tag / 256;
    my $lo = $tag % 256;
    my @list = ();
    push @list,sprintf("%02x",$adr);
    if ( $cmd =~ /R/i ) 
    {
        push @list,'03';    
        push @list,sprintf("%02x",$hi);
        push @list,sprintf("%02x",$lo);
        push @list,'00','01';
        my $cmd = join(' ',$omroncrc,@list);
        my $crc = `$cmd`;
        push @list,split(/\s+/,$crc);
        print join(" ",@list),"\n" if ($debug);
        my $ss = '';
        foreach my $s (@list)
        {
            my $nr = hex('0x'.$s);
            $ss .= chr($nr);
        }
        $ob->write($ss);
        for ( 0 .. length($ss) - 1 ) {
            print ord( substr( $ss, $_, 1 ) ), "\n" if ($debug);
        }
        select undef, undef, undef, $minipause;
        sleep($modbussleep);
        my $rep  = &rbuf();
        my $srep = "";
        print "Recieved:\n" if ($debug);
        my @l = ();
        for ( 0 .. length($rep) - 1 ) {
            print ord( substr( $rep, $_, 1 ) ), "\n" if ($debug);
            $srep .= ord( substr( $rep, $_, 1 ) );
            push @l,ord( substr( $rep, $_, 1 ) );
            $srep .= " ";
        }
        my @list = ();
        my @repl = @l;
        for my $c (splice(@repl,0,@repl-2))
        {
            push @list,sprintf("%02x",$c);
        }
        $cmd = join(' ',$omroncrc,@list);
        $crc = `$cmd`;
        push @list,split(/\s+/,$crc);
        unless ((@l > 2) && ($list[-2] eq sprintf("%02x",$l[-2]) && $list[-1] eq sprintf("%02x",$l[-1])))
        {
            my $str = "Warning CRC mismatch or no reply from omron controler $adr!";
	    $srep .= ' '.$str;
	    warn $str,"\n";
        }
        if (@l > 5 && $l[1] == 3)
        {
            my $val = $l[3] * 256 + $l[4];
            $srep .= ' '.sprintf("%6i",$val);
        }
        elsif (@l > 1)
        {
            $srep = 'Error: code '.$l[2];
        }
        $res = $srep. "\n";
    }
    if ( $cmd  =~ /W/i ) 
    {
        my $value = shift;
        my $vhi = $value / 256;
        my $vlo = $value % 256;
        push @list,'06';    
        push @list,sprintf("%02x",$hi);
        push @list,sprintf("%02x",$lo);
        push @list,sprintf("%02x",$vhi);
        push @list,sprintf("%02x",$vlo);
        my $cmd = join(' ',$omroncrc,@list);
        my $crc = `$cmd`;
        push @list,split(/\s+/,$crc);
        print join(" ",@list),"\n" if ($debug);
        my $ss = '';
        foreach my $s (@list)
        {
            my $nr = hex('0x'.$s);
            $ss .= chr($nr);
        }
        $ob->write($ss);
        for ( 0 .. length($ss) - 1 ) {
            print ord( substr( $ss, $_, 1 ) ), "\n" if ($debug);
        }
        select undef, undef, undef, $minipause;
        sleep($modbussleep);
        my $rep  = &rbuf();
        my $srep = "";
        print "Recieved:\n" if ($debug);
        my @l = ();
        for ( 0 .. length($rep) - 1 ) {
            print ord( substr( $rep, $_, 1 ) ), "\n" if ($debug);
            $srep .= ord( substr( $rep, $_, 1 ) );
            push @l,ord( substr( $rep, $_, 1 ) );
            $srep .= " ";
        }
        my @list = ();
        my @repl = @l;
        for my $c (splice(@repl,0,@repl-2))
        {
            push @list,sprintf("%02x",$c);
        }
        $cmd = join(' ',$omroncrc,@list);
        $crc = `$cmd`;
        push @list,split(/\s+/,$crc);
        unless ((@l > 2) && ($list[-2] eq sprintf("%02x",$l[-2]) && $list[-1] eq sprintf("%02x",$l[-1])))
        {
            my $str = "Warning CRC mismatch or no reply from omron controler $adr!";
	    $srep .= ' '.$str;
	    warn $str,"\n";
        }
        if (@l > 7 && $l[1] == 6)
        {
            my $val = $l[4] * 256 + $l[5];
            $srep .= ' '.sprintf("%6i",$val);
        }
        elsif (@l > 1)
        {
            $srep = 'Error: code '.$l[2];
        }
        $res = $srep. "\n";
    }
    &set_comm();
    return $res;
}

### Keithley communication start                ###
### r,w or c can also be used for other devices ###

sub Keithley
{
    my $mode = shift;
    return 'Unknown communication mode, only one of (r,w,c,k,b) is valid' unless ($mode && $mode =~ /^[rwckb]$/);
    return &keithley_write(@_) if ($mode eq 'w');
    return &keithley_read() if ($mode eq 'r');
    return &keithley_query(@_) if ($mode eq 'c'); 
    return &keithley_k(@_) if ($mode eq 'k');
    return &keithley_b(@_) if ($mode eq 'b');
}

sub keithley_write
{
    my $cmd = shift;
    my $s = $cmd. "\r\n";
    $ob->write($s);
}

sub keithley_read
{
    return $ob->input;
}

sub keithley_query
{
    &keithley_write(@_);
    select undef, undef, undef, $Keithleyminipause;
    sleep($Keithleysleep);
    return &keithley_read();
}

sub keithley_get_cards()
{
    my $res = &keithley_query('*opt?');
    if ($res && $res =~ /([\w\,]+)/)
    {
        my $data = $1;
        $keithley_cards = $data;
    }
}

sub keithley_check_channel
{
    my $b = shift;
    my $ch = shift;
    &keithley_get_cards() unless ($keithley_cards);
    if ($b && $keithley_cards)
    {
	my @c = split(/\,/,$keithley_cards);
	my $board = $c[$b-1];
	my $max = 0;
	$max = 21 if ($board && $board eq '7700');
	$max = 41 if ($board && $board eq '7702');
	$max = 31 if ($board && $board eq '7703');
	$max = 41 if ($board && $board eq '7708');
	return 1 if ($ch > 0 && $ch < $max);
    }
    return 0;
}


sub keithley_open()
{
    my $ch = shift;
    &keithley_get_cards() unless ($keithley_cards);
    my @c = split(/\,/,$keithley_cards);
    my $b = int($ch/100);
    my $opncmd = '';
    my $cconf = shift;
    $cconf = 'volt:dc' unless ($cconf);
    if ($c[$b-1] eq '7700')
    {
	$opncmd = sprintf(":route:mult:open (@%3d,%1d25)",$ch,$b);
	if ($cconf eq 'fres')
	{
	    $opncmd = sprintf(":route:mult:open (@%3d,%3d,%1d23,%1d24,%1d25)",$ch,($ch+10),$b,$b,$b);
	}
    }
    if ($c[$b-1] eq '7702')
    {
	$opncmd = sprintf(":route:mult:open (@%3d,%1d45)",$ch,$b);
	if ($cconf eq 'fres')
	{
	    $opncmd = sprintf(":route:mult:clos (@%3d,%3d,%1d43,%1d44,%1d45)",$ch,($ch+20),$b,$b,$b);
	}
    }
    if ($c[$b-1] eq '7703')
    {
	$opncmd = sprintf(":route:mult:open (@%3d,%1d33)",$ch,$b);
	if ($cconf eq 'fres')
	{
	    $opncmd = sprintf(":route:mult:clos (@%3d,%3d,%1d33,%1d34,%1d35)",$ch,($ch+16),$b,$b,$b);
	}
    }
    if ($c[$b-1] eq '7708')
    {
	$opncmd = sprintf(":route:mult:open (@%3d,%1d43)",$ch,$b);
	if ($cconf eq 'fres')
	{
	    $opncmd = sprintf(":route:mult:clos (@%3d,%3d,%1d41,%1d42,%1d43)",$ch,($ch+20),$b,$b,$b);
	}
    }
    if ($temp_flag)
    {
	$opncmd = ':route:open:all';
    }
    &keithley_write($opncmd);
}

sub keithley_close()
{
    my $ch = shift;
    my $conf = shift;
    unless ($keithley_conf eq $conf)
    {
	$keithley_conf = $conf;
	&keithley_write('conf:'.$conf);
	sleep(1);
    }
    &keithley_get_cards() unless ($keithley_cards);
    my @c = split(/\,/,$keithley_cards);
    my $b = int($ch/100);
    my $clscmd = '';
    if ($c[$b-1] eq '7700')
    {
	$clscmd = sprintf(":route:mult:clos (@%3d,%1d25)",$ch,$b);
	if ($conf eq 'fres')
	{
	    $clscmd = sprintf(":route:mult:clos (@%3d,%3d,%1d23,%1d24,%1d25)",$ch,($ch+10),$b,$b,$b);
	}
    }
    if ($c[$b-1] eq '7702')
    {
	$clscmd = sprintf(":route:mult:clos (@%3d,%1d45)",$ch,$b);
	if ($conf eq 'fres')
	{
	    $clscmd = sprintf(":route:mult:clos (@%3d,%3d,%1d43,%1d44,%1d45)",$ch,($ch+20),$b,$b,$b);
	}
    }
    if ($c[$b-1] eq '7703')
    {
	$clscmd = sprintf(":route:mult:clos (@%3d,%1d33)",$ch,$b);
	if ($conf eq 'fres')
	{
	    $clscmd = sprintf(":route:mult:clos (@%3d,%3d,%1d33,%1d34,%1d35)",$ch,($ch+16),$b,$b,$b);
	}
    }
    if ($c[$b-1] eq '7708')
    {
	$clscmd = sprintf(":route:mult:clos (@%3d,%1d43)",$ch,$b);
	if ($conf eq 'fres')
	{
	    $clscmd = sprintf(":route:mult:clos (@%3d,%3d,%1d41,%1d42,%1d43)",$ch,($ch+20),$b,$b,$b);
	}
    }
    if ($temp_flag)
    {
	$clscmd = sprintf(":route:clos (@%3d)",$ch);
    }
    &keithley_write($clscmd);
    select undef, undef, undef, ($Keithleyminipause);
}

sub keithley_k
{
    my $ch = shift;
    my $conf = shift;
    $conf = 'volt:dc' unless ($conf);
    if ($ch && $ch =~ /(\d{3})/)
    {
	$ch = $1;
	&keithley_close($ch,$conf);
        if ($temp_flag)
        {
	    select undef, undef, undef, ($Keithleyminipause + 0.2);
        }
	my $res = &keithley_query(':read?');
        unless ($res =~ /RDNG#/)
	{
	    print "Retrying read as no result was returned!\n" if ($debug);
	    $res = &keithley_query(':read?');
	}
	$res =~ /^([\-\+\d\.Ee]+)/;
	my $val = $1;
	if ($val > 1e36)
	{
	    print "Retrying read due to overflow!\n" if ($debug);
	    $res = &keithley_query(':read?');	    
	}
	&keithley_open($ch,$conf);
	return &parse_k_response($res,$conf,$ch);
    }
    return "Undefnied keithley channel (must be 3 digits)";
}

sub keithley_b
{
    my $ch = shift;
    my $np = shift;
    my $conf = shift;
    $conf = 'volt:dc' unless ($conf);
    if ($ch && $ch =~ /(\d{3})/)
    {
	$ch = $1;
        my $t = time;
        my @l = localtime($t);
        my $tstr = sprintf("%04i:%02i:%02i:%02i:%02i:%02i",($l[5]+1900),($l[4]+1),$l[3],$l[2],$l[1],$l[0]);
        my $result = "$tstr $t 0:$ch Starting burst of $np points\n";
	&keithley_close($ch,$conf);
        if ($temp_flag)
        {
	    select undef, undef, undef, ($Keithleyminipause + 0.2);
        }
        my $nplc = &keithley_query('SENS:VOLT:DC:NPLC?');
        &keithley_write('SENS:VOLT:DC:NPLC 0.01');
        &keithley_write('INIT:CONT ON');
        &keithley_write('TRIG:DEL 0');
        &keithley_write('TRAC:CLE');
        &keithley_write('TRAC:TST:FORM ABS');
        &keithley_write('TRAC:POIN '.$np);
        &keithley_write('TRAC:FEED SENS');
        &keithley_write('TRAC:FEED:CONT NEXT');
        my $sl = int($np * 20 / 2000) + 1;
        sleep($sl);
	&keithley_write('TRAC:DATA?');
	sleep(1);
	my $res = '';
	my $r = &keithley_read();
	while ($r)
	{
	    $res .= $r;
	    select undef, undef, undef, 0.1;
	    $r = &keithley_read();
	}
        &keithley_write('INIT:CONT OFF');
        &keithley_write('SENS:VOLT:DC:NPLC '.$nplc);
        &keithley_open($ch,$conf);
        print "Respnse length: ",length($res),"\n" if ($debug);
        my @lines = split(/\#\,?/,$res);
        my $count = 0;
        my $confstr = '0:'.$ch.' '.$conf;
        foreach my $st (@lines)
        {
            my @l = split(/\,/,$st);
            foreach (@l)
            {
                /([\d\.\-\+eE]+)/;
                $_ = $1+0;
            }
            my $sp = $l[0];
            $result .= "$l[1] $confstr $l[0] $sp\n" if (defined($l[1]));
            $count++;
        }
        $result .= "Sent $count data";
	return $result;
    }
    return "Undefnied keithley channel (must be 3 digits)";
}



sub parse_k_response($$)
{
    my $resp = shift;
    my $conf = shift;
    my $ch = shift;
    $resp =~ /^([\-\+\d\.Ee]+)/;
    my $val = $1;
    my $t = time;
    my @l = localtime($t);
    my $tstr = sprintf("%04i:%02i:%02i:%02i:%02i:%02i",($l[5]+1900),($l[4]+1),$l[3],$l[2],$l[1],$l[0]);
    my $str = $tstr.' '.$t.'  0:'.$ch.' '.$conf.' '.$val.' '.$val;
    return $str;
}

### Keithley comm end  ###


sub modbus
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "MODBUS $inp\n" if ($debug);
    return "Error: Not enough parameters for modbus communication: $inp\n" unless (@_ > 2);
    &set_modbus_comm();
    if ( $_[0] =~ /^h$/i ) # honeywell
    {
        my $ss = &modbusbytepack(@_);
        print "Send: " if ($debug);
        &unpackhex($ss);
        $ob->write($ss);
        select undef, undef, undef, $minipause;
        sleep($modbussleep);
        my $rep  = rbuf();
        print "Recieved: " if ($debug);
        &unpackhex($rep);
        my $srep = "";
        for ( 0 .. length($rep) - 1 ) {
            print ord( substr( $rep, $_, 1 ) ), "\n" if ($debug);
	    $srep .= " ".ord( substr( $rep, $_, 1 ) );};
        my $f = '';
        $res = $srep;
        if (length($rep)>5){
            $f = sprintf "%6.3f", unpack( "f", ( reverse (substr( $rep, 5, 4 ) ) ) );
	    $res .= " ".$f;
	}
        if (length($rep)>11){
            $f = sprintf "%6.3f", unpack( "f", ( reverse (substr( $rep, 9, 4 ) ) ) );
	    $res .= " ".$f."\n";
	}
        if (length($rep)>15){
            $f = sprintf "%6.3f", unpack( "f", ( reverse (substr( $rep, 13, 4 ) ) ) );
	    $res .= " ".$f."\n";
	}
        return $res."\n";
    }
    if ( $_[0] =~ /hc/i ) # honeywell
    {
        my $ss = &modbusbytepack(@_);
        print "Send: " if ($debug);
        &unpackhex($ss);
        my $function = $_[2];
        my $count = $_[@_-1];
        $ob->write($ss);
        select undef, undef, undef, $minipause;
        sleep($modbussleep);
        my $rep  = rbuf();
        print "Recieved: " if ($debug);
        &unpackhex($rep);
        my $srep = "";
        for ( 0 .. length($rep) - 1 ) {
            $srep .= " ".ord( substr( $rep, $_, 1 ) );};
        my $f = '';
        $res = $srep;
        if (ord(substr($rep,1,1)) != $function)
        {
            return "ERROR: return code does not match: $res\n";
        }
        return $res."\n" if ($function == 6 || $function == 16);
        if ($count == 1)
        {
            if (length($rep)>4){
                my @l = split(//,substr($rep,3,2));
                $res .= '  '. (ord($l[0])*256 + ord($l[1]) )."\n";
            }
        }
        else
        {
            my $c;
            if (length($rep) > 4)
            {
                $c = ord(substr($rep,2,1))/4;
            }
            print "responsecount $c\n" if ($debug);
            foreach (1..$c)
            {
                $f = sprintf "%6.3f", unpack( "f", ( reverse (substr( $rep, ($c-1) * 4 + 3, 4 ) ) ) );
                $res .= " ".$f;
            }
            return $res."\n";
        }
    }
    if ( $_[0] =~ /F/i )  
    {
        my $ss = &modbuspack( $_[1], 4, $_[2], 1 );
	$ob->write($ss);
        select undef, undef, undef, $minipause;
        sleep($modbussleep);
	my                $rep  = rbuf();
	my                $srep = "";
        my $f = '';
	if (length($rep)>5){
	    $f = sprintf "%6.3f", unpack( "f", gnirts( substr( $rep, 3, 4 ) ) );
	}
	$res = $srep." ".$f."\n";
    }
    if ( $_[0] =~ /R/i ) 
    {
	my $ss = &modbuspack( $_[1], 3, $_[2], 1 );
	$ob->write($ss);
	for ( 0 .. length($ss) - 1 ) {
	    print ord( substr( $ss, $_, 1 ) ), "\n" if ($debug);
	}
	select undef, undef, undef, $minipause;
	sleep($modbussleep);
	my $rep  = &rbuf();
	my $srep = "";
	my @l = ();
	for ( 0 .. length($rep) - 1 ) {
	    print ord( substr( $rep, $_, 1 ) ), "\n" if ($debug);
	    $srep .= ord( substr( $rep, $_, 1 ) );
	    push @l,ord( substr( $rep, $_, 1 ) );
	    $srep .= " ";
	}
	if ($_[0] =~ /I/i && @l > 2)
	{
	    my $val = $l[3] * 256 + $l[4];
	    $srep .= ' '.sprintf("%6i",$val);
	}
	$res = $srep. "\n";
    }
    if ( $_[0] =~ /G/i ) 
    {
	my $ss = &modbuspack( $_[1], 3, (32768+2*$_[2]), 2 );
	$ob->write($ss);
	for ( 0 .. length($ss) - 1 ) {
	    print ord( substr( $ss, $_, 1 ) ), "\n" if ($debug);
	}
	select undef, undef, undef, $minipause;
	sleep($modbussleep);
	my $rep  = &rbuf();
	my $srep = "";
	for ( 0 .. length($rep) - 1 ) {
	    print ord( substr( $rep, $_, 1 ) ), "\n" if ($debug);
	    $srep .= ord( substr( $rep, $_, 1 ) );
	    $srep .= " ";
	}
	my $f = '';
	if (length($rep)>8){
	    $f = sprintf "%6.3f", unpack( "f", &gnirts( substr( $rep, 3, 4 ) ) );
	}
	$res = $srep.' '.$f."\n";
    }
    if ( $_[0]  =~ /P/i ) 
    {
	my $ss = &modbusfloatpack( $_[1], $_[2], $_[3] );
	$ob->write($ss);
	for ( 0 .. length($ss) - 1 ) {
	    print ord( substr( $ss, $_, 1 ) ), "\n" if ($debug);
	}
	select undef, undef, undef, $minipause;
	sleep($modbussleep);
	my $rep  = &rbuf();
	my $srep = "";
	if (length($rep)>7){
	    for ( 0 .. length($rep) - 1 ) {
		print ord( substr( $rep, $_, 1 ) ), "\n" if ($debug);
		$srep .= ord( substr( $rep, $_, 1 ) );
		$srep .= " ";
	    }
	}
	$res = $srep."\n";
    }
    if ( $_[0]  =~ /W/i ) 
    {
	my $ss = &modbuspack( $_[1], 6, $_[2], $_[3] );
	$ob->write($ss);
	for ( 0 .. length($ss) - 1 ) {
	    print ord( substr( $ss, $_, 1 ) ), "\n" if ($debug);
	}
	select undef, undef, undef, $minipause;
	sleep($modbussleep);
	my $rep  = &rbuf();
	my $srep = "";
	for ( 0 .. length($rep) - 1 ) {
	    print ord( substr( $rep, $_, 1 ) ), "\n" if ($debug);
	    $srep .= ord( substr( $rep, $_, 1 ) );
	    $srep .= " ";
	}
	$res = $srep."\n";
	
    }
    &set_comm();
    return $res;
}


sub icp_crc(@)
{
    my $sum = 0;
    while (@_)
    {
	my $str = shift;
	foreach (split(//,$str))
	{
	    $sum += ord($_);
	}
    }
    my $res = $sum & 0x0ff;
    return sprintf("%02X",$res);
}

sub icp_comm_crc
{
    my $s = shift;
    return undef unless ($s);
    $s =~ s/[\r\n]+$//;
    $s .= icp_crc($s);
    $s .= "\r\n";
    print "Sending: $s" if ($debug);
    $ob->write($s);
    if (@_)
    {
	my $sleep = shift;
	select undef, undef, undef, $sleep;
    }
    else
    {
	select undef, undef, undef, $ICPminipause;
    }
    sleep($ICPsleep);
    my $r = $ob->input;
    print "Recieved: $r" if ($debug);
    return undef unless ($r);
    $r =~ s/[\r\n]+$//;
    my $crc = substr($r,-2);
    my $res = substr($r,0,(length($r)-2));
    return $res if ($crc eq icp_crc($res));
    return undef;
}


sub ICP_test_crc
{
    my $id = shift;
    my $s1 = sprintf "%02d", $id;
    my $s = "\$" . $s1 . "2" . "\r\n";
    return icp_comm_crc($s);
}

sub ICP_test
{
    my $id = shift;
    my $s1 = sprintf "%02d", $id;
    my $s = "\$" . $s1 . "2" . "\r\n";
    $ob->write($s);
    select undef, undef, undef, $ICPminipause;
    sleep($ICPsleep);
    return $ob->input;
}

sub ICP_raw_crc
{
    my $cmd = shift;
    my $s = $cmd. "\r\n";
    return icp_comm_crc($s);
}


sub ICP_raw
{
    my $cmd = shift;
    my $s = $cmd. "\r\n";
    $ob->write($s);
    select undef, undef, undef, $ICPminipause;
    sleep($ICPsleep);
    return $ob->input;
}


sub BK_raw
{
    my @cmds = @_;
    my $s = join(' ',@cmds). "\r\n";
    $ob->baudrate(57600) || die "fail setting baudrate";
    $ob->write($s);
    select undef, undef, undef, $ICPminipause;
    sleep($ICPsleep);
    my $res = $ob->input;
    &set_comm();
    return $res;
}


sub ad_crc
{
    ### Under construction.. May be incomplete ###
    my $s = sprintf "\#%02d\r\n", $_[0];
    return icp_comm_crc($s);
}

sub ad
{
    ### Under construction.. May be incomplete ###
    my $s = sprintf "\#%02d\r\n", $_[0];
    $ob->write($s);
    select undef, undef, undef, $ICPminipause;
    sleep($ICPsleep);
    my $r = $ob->input;
    return $r;
}

sub ICP_multi_ad_crc
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "MULT_AD $inp\n" if ($debug);
    return "Error: Not enough paramters for ICP multi_read AD: $inp\n" unless (@_ > 0);
    my $s = sprintf "\#%02d**\r\n", $_[0];
    my $r = icp_comm_crc($s);
    $s = sprintf "\#%02d\r\n", $_[0];
    $r = icp_comm_crc($s,$ICPminipause_ad_multi);
    if ($r)
    {
	$res = join("\n",($r =~ /(\d{2}\.\d{3})/g));
    }
    return $res;
}

sub ICP_multi_ad
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "MULT_AD $inp\n" if ($debug);
    return "Error: Not enough paramters for ICP multi_read AD: $inp\n" unless (@_ > 0);
    my $s = sprintf "\#%02d**\r\n", $_[0];
    $ob->write($s);
    select undef, undef, undef, $ICPminipause;
    $s = sprintf "\#%02d\r\n", $_[0];
    $ob->write($s);
    select undef, undef, undef, $ICPminipause_ad_multi;
    sleep($ICPsleep);
    my $r = $ob->input;
    if ($r)
    {
	$res = join("\n",($r =~ /(\d{2}\.\d{3})/g));
    }
    return $res;
}

sub ICP_7017_multi_crc
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "MULT_AD $inp\n" if ($debug);
    return "Error: Not enough paramters for ICP multi_read AD: $inp\n" unless (@_ > 0);
    my $s = sprintf "\#%02d**\r\n", $_[0];
    my $r = icp_comm_crc($s);
    $s = sprintf "\#%02d\r\n", $_[0];
    $r = icp_comm_crc($s,$ICPminipause_ad_multi);
    if ($r)
    {
	$res = join("\n",($r =~ /([\+\-]*\d+\.\d+)/g));
    }
    return $res;
}

sub ICP_7017_multi
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "MULT_AD $inp\n" if ($debug);
    return "Error: Not enough paramters for ICP multi_read AD: $inp\n" unless (@_ > 0);
    my $s = sprintf "\#%02d**\r\n", $_[0];
    $ob->write($s);
    select undef, undef, undef, $ICPminipause;
    $s = sprintf "\#%02d\r\n", $_[0];
    $ob->write($s);
    select undef, undef, undef, $ICPminipause_ad_multi;
    sleep($ICPsleep);
    my $r = $ob->input;
    if ($r)
    {
	$res = join("\n",($r =~ /([\+\-]*\d+\.\d+)/g));
    }
    return $res;
}

sub ICP_multiplex_crc
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "MULTIPLEX $inp\n" if ($debug);
    return "Error: Not enough paramters for ICP multiplex: $inp\n" unless (@_ > 1);
    if ( ($_[0] =~ /SET_SINGLE/i ) && ( $_[1] =~ /^\d+$/ ) && ( $_[2] =~ /^(\-*\d+)$/ ) ) 
    {
	#### Sets a single relay to ON, the rest to OFF! #####
	my $ch = $1;
	my $s1 = sprintf "%02d", $_[1];
	my $s3;
	if ($ch < 0)
	{
	    #### Default all off if negative number ###
	    $s3 = '00';
	}
	else
	{
	    $s3 = sprintf("%02X", 2**$ch);
	}
	my $s = '@' . $s1 . $s3 . "\r\n";
	print "SET: send >>", $s if ($debug);
	my $r = icp_comm_crc($s);
	$res .=  $inp. " ". $s;
	if ( $r =~ /\>/ ) {
	    $res .= " ok\n";
	}
	else
	{
	    $res .= "Module $s1 not responding!\n";
	}
	print $res,"\n" if ($debug);
	select undef, undef, undef, $ICPminipause;
	$s = "@" . $s1  . "\r\n";
	print "READ: send >>", $s if ($debug);
	$r = icp_comm_crc($s);
	if ( $r =~ /\>/ ) {
	    $res .= $r;
	}
	else
	{
	    $res .= "Module $s1 not responding!\n";
	}
	print $res,"\n" if ($debug);
    }
    if ( ($_[0] =~ /SET_MULTI/i ) && ( $_[1] =~ /^\d+$/ ) && ( $_[2] =~ /^(\-*\d+)$/ ) ) 
    {
	#### Function setting all relay outputs at the same time ###
	#### Input style in 'binary' like the output from 'READ' ###
	my $ch = $1;
	my $s1 = sprintf "%02d", $_[1];
	my $s3;
	if ($ch < 0)
	{
	    #### Default all off if negative number ###
	    $s3 = '00';
	}
	else
	{
	    while ($ch =~ /(\d{8})/g)
	    {
		my $b = $1;
		my @l = split(//,$b);
		my $i = 0;
		for (my $x = 0; $x < 8; $x++)
		{
		    $i += 2**$x if($l[$x]);
		}
		$s3 .= sprintf("%02X", $i);
	    }
	}
	my $s = '@' . $s1 . $s3 . "\r\n";
	print "SET: send >>", $s if ($debug);
	my $r = icp_comm_crc($s);
	$res .=  $inp. " ". $s;
	if ( $r =~ /\>/ ) {
	    $res .= " ok\n";
	}
	else
	{
	    $res .= "Module $s1 not responding!\n";
	}
	select undef, undef, undef, $ICPminipause;
	$s = "@" . $s1  . "\r\n";
	print "READ: send >>", $s if ($debug);
	$r = icp_comm_crc($s);
	if ( $r =~ /\>/ ) {
	    $res .= $r;
	}
	else
	{
	    $res .= "Module $s1 not responding!\n";
	}
    }
    if ( ($_[0] =~ /^READ$/i) && ( $_[1] =~ /^(\d+)$/ )) 
    {
	##### Retruns a string of 1's and 0's representing the status of the relays ###
	my $s1 = sprintf "%02d", $1;
	my $s = "@" . $s1  . "\r\n";
	print "READ: send >>", $s if ($debug);
	my $r = icp_comm_crc($s);
	if ($r =~ /\>(\w+)/)
	{
	    while ($r =~ /(\w{2})/g)
	    {
		my $i = hex($1);
		for (0..7)
		{
		    if ($i & (2**$_))
		    {
			$res .= '1';
		    }
		    else
		    {
			$res .= '0';
		    }
		}
	    }
	}
    }
    if ( ($_[0] =~ /^READ_RAW$/i) && ( $_[1] =~ /^(\d+)$/ )) 
    {
	my $s1 = sprintf "%02d", $1;
	my $s = "@" . $s1  . "\r\n";
	print "READ: send >>", $s if ($debug);
	$res .= icp_comm_crc($s);
    }
    return $res;
}

sub ICP_multiplex
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "MULTIPLEX $inp\n" if ($debug);
    return "Error: Not enough paramters for ICP multiplex: $inp\n" unless (@_ > 1);
    if ( ($_[0] =~ /SET_SINGLE/i ) && ( $_[1] =~ /^\d+$/ ) && ( $_[2] =~ /^(\-*\d+)$/ ) ) 
    {
	#### Sets a single relay to ON, the rest to OFF! #####
	my $ch = $1;
	my $s1 = sprintf "%02d", $_[1];
	my $s3;
	if ($ch < 0)
	{
	    #### Default all off if negative number ###
	    $s3 = '00';
	}
	else
	{
	    $s3 = sprintf("%02X", 2**$ch);
	}
	my $s = '@' . $s1 . $s3 . "\r\n";
	print "SET: send >>", $s if ($debug);
	$ob->write($s);
	select undef, undef, undef, $ICPminipause;
	sleep($ICPsleep);
	my $r = $ob->input;
	$res .=  $inp. " ". $s;
	if ( $r =~ /\>/ ) {
	    $res .= " ok\n";
	}
	else
	{
	    $res .= "Module $s1 not responding!\n";
	}
	print $res,"\n" if ($debug);
	select undef, undef, undef, $ICPminipause;
	$s = "@" . $s1  . "\r\n";
	print "READ: send >>", $s if ($debug);
	$ob->write($s);
	select undef, undef, undef, $ICPminipause;
	sleep($ICPsleep);
	$r .= $ob->input;
	if ( $r =~ /\>/ ) {
	    $res .= $r;
	}
	else
	{
	    $res .= "Module $s1 not responding!\n";
	}
	print $res,"\n" if ($debug);
    }
    if ( ($_[0] =~ /SET_MULTI/i ) && ( $_[1] =~ /^\d+$/ ) && ( $_[2] =~ /^(\-*\d+)$/ ) ) 
    {
	#### Function setting all relay outputs at the same time ###
	#### Input style in 'binary' like the output from 'READ' ###
	my $ch = $1;
	my $s1 = sprintf "%02d", $_[1];
	my $s3;
	if ($ch < 0)
	{
	    #### Default all off if negative number ###
	    $s3 = '00';
	}
	else
	{
	    while ($ch =~ /(\d{8})/g)
	    {
		my $b = $1;
		my @l = split(//,$b);
		my $i = 0;
		for (my $x = 0; $x < 8; $x++)
		{
		    $i += 2**$x if($l[$x]);
		}
		$s3 .= sprintf("%02X", $i);
	    }
	}
	my $s = '@' . $s1 . $s3 . "\r\n";
	print "SET: send >>", $s if ($debug);
	$ob->write($s);
	select undef, undef, undef, $ICPminipause;
	sleep($ICPsleep);
	my $r = $ob->input;
	$res .=  $inp. " ". $s;
	if ( $r =~ /\>/ ) {
	    $res .= " ok\n";
	}
	else
	{
	    $res .= "Module $s1 not responding!\n";
	}
	select undef, undef, undef, $ICPminipause;
	$s = "@" . $s1  . "\r\n";
	print "READ: send >>", $s if ($debug);
	$ob->write($s);
	select undef, undef, undef, $ICPminipause;
	sleep($ICPsleep);
	$r .= $ob->input;
	if ( $r =~ /\>/ ) {
	    $res .= $r;
	}
	else
	{
	    $res .= "Module $s1 not responding!\n";
	}
    }
    if ( ($_[0] =~ /^READ$/i) && ( $_[1] =~ /^(\d+)$/ )) 
    {
	##### Retruns a string of 1's and 0's representing the status of the relays ###
	my $s1 = sprintf "%02d", $1;
	my $s = "@" . $s1  . "\r\n";
	print "READ: send >>", $s if ($debug);
	$ob->write($s);
	select undef, undef, undef, $ICPminipause;
	sleep($ICPsleep);
	my $r = $ob->input;
	if ($r =~ /\>(\w+)/)
	{
	    while ($r =~ /(\w{2})/g)
	    {
		my $i = hex($1);
		for (0..7)
		{
		    if ($i & (2**$_))
		    {
			$res .= '1';
		    }
		    else
		    {
			$res .= '0';
		    }
		}
	    }
	}
    }
    if ( ($_[0] =~ /^READ_RAW$/i) && ( $_[1] =~ /^(\d+)$/ )) 
    {
	my $s1 = sprintf "%02d", $1;
	my $s = "@" . $s1  . "\r\n";
	print "READ: send >>", $s if ($debug);
	$ob->write($s);
	select undef, undef, undef, $ICPminipause;
	sleep($ICPsleep);
	$res .= $ob->input;
    }
    return $res;
}

sub mks
{
    my $inp = join(' ',@_);
    print "RAW $inp\n" if ($debug);
    return "Error: Not enough parameters for raw communication: $inp" unless (@_ > 1);
    my $adr = shift;
    my $cmd = shift;
    $ob->baudrate(9600) || die "fail setting baudrate";
    $ob->parity('none')   || die "fail setting parity";
    $ob->databits(8) || die "fail setting databits";
    $ob->stopbits(1) || die "fail setting stopbits";
    $ob->handshake('none') || die "fail setting handshake";
    $ob->datatype('raw')   || die "fail setting handshake";
    my $str = '@'.sprintf("%03g",$adr).$cmd.';';
    my $sum = 0;
    foreach (split(//,$str))
    {
	$sum += ord($_);
    }
    my $chk = substr(sprintf("%X",$sum),-2);
    my $s = '@@'.$str.$chk;
    print "send >>", $s if ($debug);
    $ob->write($s);
    select undef, undef, undef, 0.1;
    my $r = $ob->input;
    &set_comm();
    return $r;
}

sub raw
{
    my $inp = join(' ',@_);
    print "RAW $inp\n" if ($debug);
    return "Error: Not enough parameters for raw communication: $inp" unless (@_ > 4);
    $ob->baudrate( shift ) || die "fail setting baudrate";
    $ob->parity( shift )   || die "fail setting parity";
    $ob->databits( shift ) || die "fail setting databits";
    $ob->stopbits( shift ) || die "fail setting stopbits";
    $ob->handshake("none") || die "fail setting handshake";
    $ob->datatype("raw")   || die "fail setting handshake";
    my $s = join(" ",@_) . "\r\n";
    print "send >>", $s if ($debug);
    $ob->write($s);
    select undef, undef, undef, 0.1;
    sleep($rawpause);
    my $r = $ob->input;
    &set_comm();
    $r =~ s/[\r\n]//g if (defined($r)); # Remove CR
    return $r;
}

sub bronkhorst
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "Bronkhorst $inp\n" if ($debug);
# fix of 7523 problem
    my $r="\$012\r\n";
    $ob->write($r);
    sleep 1;
    $r = $ob->input;
    print $r,"\n" if ($debug);
    my $flowread = "no reply";
    if ( ( $_[0] =~ /string/i ) ) 
    {
	my $bpre = "!32";
	my $s = $bpre . $_[1]. "\r\n";
	print "send >>", $s if ($debug);
	$ob->write($s);
	sleep(1);
	my $r = $ob->input;
	print $r,"\n" if ($debug);
	$res .= $r;
    }
    if ($_[0] =~ /setflow/i ) 
    {
	my $bpre = "!32:0680010121";
	# : start character
	#!32 ICP box address 31 com 3
	# 06 length 
	# 80 address 
	# 01 write
	# 01 not chained process 1
	# 21 not chained integer
	my $flowval = int( ( $_[1] + 0 ) * 320.0 );
	# flow in % ; full range 32000
	my $flowstring = sprintf "%.4X", $flowval;
	my $s = $bpre . $flowstring . "\r\n";
	print "send >>", $s if ($debug);
	$ob->write($s);
	sleep(1);
	my $r = $ob->input;
	print $r,"\n" if ($debug);
	$res .= $r;
    }
    if ( $_[0] =~ /readflow/i ) 
    {
	my $bpre = "!32:06800401200120";
	my $s    = $bpre . "\r\n";
	print "send >>", $s if ($debug);
	$ob->write($s);
	sleep(1);
	my $r = $ob->input;
	my $flowread = '';
	if ( length($r) > 15 ) {
	    print $r,"\n" if ($debug);
	    $flowread = hex( substr( $r, 11, 4 ) ) / 320.0;
	}
	$res .= $flowread. "\r\n";
    }
    if ( $_[0] =~ /readset/i ) 
    {
	my $bpre = "!32:06800401210121";
	my $s    = $bpre . "\r\n";
	print "send >>", $s if ($debug);
	$ob->write($s);
	sleep(1);
	my $r = $ob->input;
	my $flowread = '';
	if ( length($r) > 15 ) {
	    $flowread = hex( substr( $r, 11, 4 ) ) / 320.0;
	}
	$res .= $flowread. "\r\n";
    }
# fix of 7523 problem
    $r="\$012\r\n";
    $ob->write($r);
    sleep 1;
    $r = $ob->input;
    print $r,"\n" if ($debug);
    return $res;
}

sub delta
{
    my $res = undef;
    my $inp = join(' ',@_);
    return "Error: Not enough parameters for DELTA communication: $inp" unless (@_ > 1);
    print "DELTA $inp\n" if ($debug);
    my $cmd = lc(shift);
    my $addr = shift;
    my $a = sprintf("%d",$addr);
    my $s = 'CH '.$a."\r";
    print "send >> $s\n" if ($debug);
    $ob->write($s);
    select(undef,undef,undef,0.1);
    my $r = $ob->input;
    ### Do addres select twice as sometimes it misses... ###
    $ob->write($s);
    select(undef,undef,undef,0.1);
    $r = $ob->input;
    if ($cmd eq 'idn')
    {
        $s = "*idn?\r";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        select(undef,undef,undef,$deltasleep);
        return $ob->input;
    }
    if ($cmd eq 'raw')
    {
        $s = join(" ",@_)."\r";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        select(undef,undef,undef,$deltasleep);
        return $ob->input;
    }
    if ($cmd eq 'ocv')
    {
        $s = "SO:FU:RSD ON" . "\r";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        select(undef,undef,undef,$deltasleep);
        $ob->input;
        return 'RSD ON';
    }
    if ($cmd eq 'on')
    {
        $s = "SO:FU:RSD OFF" . "\r";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        select(undef,undef,undef,$deltasleep);
        $ob->input;
        return 'RSD OFF';
    }
    if ($cmd eq 'volt')
    {
        my $volt = sprintf("%.2f",shift);
        $s = "SOURCE:VOLT " . $volt . "\r";
        $ob->write($s);
        select(undef,undef,undef,$deltasleep);
        $ob->input;
        return $volt;
    }
    if ($cmd eq 'current')
    {
        my $volt = sprintf("%.2f",shift);
        $s = "SOURCE:CURR " . $volt . "\r";
        $ob->write($s);
        select(undef,undef,undef,$deltasleep);
        $ob->input;
        return $volt;
    }
    if ($cmd eq 'measure_volt')
    {
        $s = "MEASURE:VOLT?\r";
        $ob->write($s);
        select(undef,undef,undef,$deltasleep);
        return $ob->input;
    }
    if ($cmd eq 'measure_current')
    {
        $s = "MEASURE:CURR?\r";
        $ob->write($s);
        select(undef,undef,undef,$deltasleep);
        return $ob->input;
    }
    if ($cmd eq 'init')
    {
        $s = "SOURCE:VOLT:MAXI 100\r";
        $ob->write($s);
        select(undef,undef,undef,$deltasleep);
        $ob->input;
        $s = "SOURCE:CURR:MAXI 100\r";
        $ob->write($s);
        select(undef,undef,undef,$deltasleep);
        $ob->input;
        $s = "SOURCE:CURR 0\r";
        $ob->write($s);
        select(undef,undef,undef,$deltasleep);
        $ob->input;
        $s = "SOURCE:VOLT 0\r";
        $ob->write($s);
        select(undef,undef,undef,$deltasleep);
        $ob->input;
        $s = "SO:FU:RSD ON" . "\r";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        select(undef,undef,undef,$deltasleep);
        $ob->input;
        return 'INIT completed, RSD ON';
    }
    return 'Unknown command for DELTA, accepted commands: raw, idn, init, current, volt, measure_volt, measure_current, ocv, on';
}

sub hmp
{
    my $res = undef;
    my $inp = join(' ',@_);
    return "Error: Not enough parameters for HMP communication: $inp" unless (@_ > 0);
    my $cmd = lc(shift);
    my $s = undef;
    
    
    if ($cmd eq 'init')
    {   
        $s = "*RST?\n";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        select(undef,undef,undef,$hmpsleep);
        my $read = $ob->input;
        print "Recieved: $read\n" if ($debug);
        return $read;
    }

    if ($cmd eq 'idn')
    {   
        $s = "*IDN?\n";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        select(undef,undef,undef,$hmpsleep);
        my $read = $ob->input;
        print "Recieved: $read\n" if ($debug);
        return $read;
    }

    if ($cmd eq 'volt')
    {   my $channel = $_[0];
        my $volt = $_[1];

        print $inp if ($debug);
        $s = "INST OUT$channel\n";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        select(undef,undef,undef,$hmpsleep);
        $s = "VOLT $volt\n";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        my $read = $ob->input;
        print "Recieved: $read\n" if ($debug);
        return $read;
    }
    
    if ($cmd eq 'current')
    {   my $channel = $_[0];
        my $current = $_[1];
        
        print $inp if ($debug);
        $s = "INST OUT$channel\n";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        select(undef,undef,undef,$hmpsleep);
        $s = "CURR $current\n"; 
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        my $read = $ob->input;
        print "Recieved: $read\n" if ($debug);
        return $read;
    }
    
    if ($cmd eq 'enable')
    {   
        foreach my $channel(@_) {
            #sanity check of channel number
            if ($channel !~ /^\d+$/ || $channel < 1 || $channel > 4) {
                return "Error: Invalid channel number: $channel (should be 1-4)";
            }
            $s = "INST OUT$channel\n";
            print "send >> $s\n" if ($debug);
            $ob->write($s);
            select(undef,undef,undef,$hmpsleep);
            $s = "OUTP 1\n";
            print "send >> $s\n" if ($debug);
            $ob->write($s);
            select(undef,undef,undef,$hmpsleep);
        }
        return "Channels @_ enabled";  
    }

    if ($cmd eq 'disable')
    {   
        foreach my $channel(@_) {
            #sanity check of channel number
            if ($channel !~ /^\d+$/ || $channel < 1 || $channel > 4) {
                return "Error: Invalid channel number: $channel (should be 1-4)";
            }
            $s = "INST OUT$channel\n";
            print "send >> $s\n" if ($debug);
            $ob->write($s);
            select(undef,undef,undef,$hmpsleep);
            $s = "OUTP 0\n";
            print "send >> $s\n" if ($debug);
            $ob->write($s);
            select(undef,undef,undef,$hmpsleep);
        }   
        return "Channels @_ disabled";
    }

    if ($cmd eq 'measure_volt')
    {   
        my $channel = shift;
        #sanity check of channel number
        if ($channel !~ /^\d+$/ || $channel < 1 || $channel > 4) {
                return "Error: Invalid channel number: $channel (should be 1-4)";}
        $s = "INST OUT$channel\n";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        select(undef,undef,undef,$hmpsleep);
        $s = "MEAS:VOLT?\n";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        select(undef,undef,undef,$hmpsleep);
        my $read = $ob->input;
        print "Recieved: $read\n" if ($debug);

        return $read;
    }

    if ($cmd eq 'measure_current')
    {   
        my $channel = shift;
        if ($channel !~ /^\d+$/ || $channel < 1 || $channel > 4) {
                return "Error: Invalid channel number: $channel (should be 1-4)";}
        $s = "INST OUT$channel\n";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        select(undef,undef,undef,$hmpsleep);
        $s = "MEAS:CURR?\n";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        select(undef,undef,undef,$hmpsleep);
        my $read = $ob->input;
        print "Recieved: $read\n" if ($debug);

        return $read;
    }

    if ($cmd eq 'volt_setpoint')
    {   
        my $channel = shift;
        if ($channel !~ /^\d+$/ || $channel < 1 || $channel > 4) {
                return "Error: Invalid channel number: $channel (should be 1-4)";}
        $s = "INST OUT$channel\n";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        select(undef,undef,undef,$hmpsleep);
        $s = "VOLT?\n";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        select(undef,undef,undef,$hmpsleep);
        my $read = $ob->input;
        print "Recieved: $read\n" if ($debug);

        return $read;
    }
    if ($cmd eq 'current_setpoint')
    {   
        my $channel = shift;
        if ($channel !~ /^\d+$/ || $channel < 1 || $channel > 4) {
                return "Error: Invalid channel number: $channel (should be 1-4)";}
        $s = "INST OUT$channel\n";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        select(undef,undef,undef,$hmpsleep);
        $s = "CURR?\n";
        print "send >> $s\n" if ($debug);
        $ob->write($s);
        select(undef,undef,undef,$hmpsleep);
        my $read = $ob->input;
        print "Recieved: $read\n" if ($debug);

        return $read;
    }

    return 'Unknown command for HMP, accepted commands: init, enable, disable, idn, volt, current, measure_volt, measure_current, current_setpoint, volt_setpoint';
}

sub elektro
{
    my $res = undef;
    my $inp = join(' ',@_);
    return "Error: Not enough parameters for DELTA communication: $inp" unless (@_ > 1);
    print "Elektro $inp\n" if ($debug);
    my @cmdlst = ();
    my $cmd = lc(shift);
    my $node = shift;
    push @cmdlst,sprintf("%02X",$node);
    my @args = @_;
    if ($cmd eq 'remote')
    {
        my $mode = lc(shift);
        if ($mode eq 'on')
        {
            push @cmdlst, sprintf("%02X",54);
            push @cmdlst,'10';
            push @cmdlst,'10';
            my $res = send_elektro('w',2,@cmdlst);
            return $res if ($res && $res =~ /error/i);
            return 'Remote ON';
        }
        if ($mode eq 'off')
        {
            push @cmdlst, sprintf("%02X",54);
            push @cmdlst,'10';
            push @cmdlst,'00';
            my $res = send_elektro('w',2,@cmdlst);
            return $res if ($res && $res =~ /error/i);
            return 'Remote OFF';
        }
        return "Note enough aruments for 'electro remote dn mode': mising mode, valid values : 'on', 'off'";
    }
    if ($cmd eq 'ocv')
    {
        push @cmdlst, sprintf("%02X",54);
        push @cmdlst,'01';
        push @cmdlst,'00';
        my $res = send_elektro('w',2,@cmdlst);
        return $res if ($res && $res =~ /error/i);
        return 'OCV';
    }
    if ($cmd eq 'on')
    {
        push @cmdlst, sprintf("%02X",54);
        push @cmdlst,'01';
        push @cmdlst,'01';
        my $res = send_elektro('w',2,@cmdlst);
        return $res if ($res && $res =~ /error/i);
        return 'Input ON';
    }
    if ($cmd eq 'idn')
    {
        push @cmdlst,0;
        return send_elektro('r',6,@cmdlst);
    }
    if ($cmd eq 'read_values')
    {
        push @cmdlst,sprintf("%02X",71);
        my $res = send_elektro('r',6,@cmdlst);
        return $res if ($res =~ /error/i);
        my ($vh,$vl,$ch,$cl,$ph,$pl) = split(//,$res);
        my $volt = hex(sprintf("%02X%02X",ord($vh),ord($vl))) * 100 / 25600;
        my $curr = hex(sprintf("%02X%02X",ord($ch),ord($cl))) * 100 / 25600;
        my $pow = hex(sprintf("%02X%02X",ord($ph),ord($pl))) * 100 / 25600;
        return sprintf("Voltage: %.3f%%\nCurrent: %.3f%%\nPower:   %.3f%%",$volt,$curr,$pow);
    }
    if ($cmd eq 'read')
    {
        my $length = shift;
        my $tag = shift;
        push @cmdlst,sprintf("%02X",$tag);
        my $res = send_elektro('r',$length,@cmdlst);
        return $res if ($res =~ /error/i);
	my ($hb,$lb) = split(//,$res);
	my $str = sprintf("%02X%02X",ord($hb),ord($lb));
	my $result = hex($str) * 100 /25600;
        return $result;
    }
    if ($cmd eq 'write')
    {
        my $length = shift;
        my $tag = shift;
        my $value = shift;
        my $hex = sprintf("%04X",int(25600 * $value/100));
        my $hb = substr($hex,0,2);
        my $lb = substr($hex,2,2);
        push @cmdlst,sprintf("%02X",$tag);
        push @cmdlst,$hb;
        push @cmdlst,$lb;
        my $res =  send_elektro('w',$length,@cmdlst);
        return 'OK' unless ($res);
        return $res;
    }
    if ($cmd eq 'raw_byte_read')
    {
        my $length = shift;
        my $tag = shift;
        push @cmdlst, sprintf("%02X",$tag);
        my $res = send_elektro('r',$length,@cmdlst);
        return $res if ($res =~ /error/i);
        my @l = split(//,$res);
        my @rep = ();
        foreach (@l)
        {
            push @rep,ord($_);
        }
        return join("\n",@rep);
    }
    if ($cmd eq 'raw_byte_write')
    {
        my $length = shift;
        my $tag = shift;
        push @cmdlst, sprintf("%02X",$tag);
        while (@_)
        {
            push @cmdlst,sprintf("%02X",shift);
        }
        my $res = send_elektro('w',$length,@cmdlst);
        return $res if ($res =~ /error/i);
        my @l = split(//,$res);
        my @rep = ();
        foreach (@l)
        {
            push @rep,ord($_);
        }
        return join("\n",@rep);
    }
    if ($cmd eq 'raw')
    {
        my $mode = shift @args;
        my $length = shift @args;
        foreach (@args)
        {
            push @cmdlst, sprintf("%02X",$_);
        }
        return send_elektro($mode,$length,@cmdlst);
    }
    if ($cmd eq 'hex')
    {
        my $i = 0;
        my $s = '';
        foreach (@args)
        {
            $s .= chr(hex($_));
            next unless ($debug);
            print "$i ".$_." ".chr(hex($_))."\n";
            $i++;
        }
        print "Send: '$s'\n" if ($debug);
        $ob->parity('odd')     || die "fail setting parity";
        $ob->write($s);
        select(undef,undef,undef,0.1);
        my $r = $ob->input;
        $ob->parity($parity)     || die "fail setting parity";
        my @l = split(//,$r);
        my @res = ();
        foreach (my $x = 0; $x < @l; $x++)
        {
            $res[$x] = ord($l[$x]);
        }
        return join(" ",@res);
    }
    return "Unknown command '$cmd' for elektro! Known commands: idn, ocv, on, remote, read, write, read_values, raw, hex, raw_byte_read, raw_byte_write read_dec";
}

sub send_elektro($$@)
{
    my $mode = shift;
    my $data_length = shift;
    my $length = $data_length - 1;;
    my @cmdlst = @_;
    my @b = (0,0,0,0,1,0,1,0);
    @b = (0,0,0,0,1,0,1,1) if ($mode =~ /w/);
    my $i = hex($length);
    for (0..3)
    {
        if ($i & (2**$_))
        {
            $b[$_] = 1;
        }
        else
        {
            $b[$_]= '0';
        }
    }
    my $sd = 0;
    foreach (0..7)
    {
        $sd += 2**$_ if ($b[$_]);
    }
    unshift @cmdlst,sprintf("%02X",$sd);
    my @crc = elektrocrc(@cmdlst);
    my $s = '';
    $i = 0;
    foreach ((@cmdlst,@crc))
    {
        $s .= chr(hex($_));
        next unless ($debug);
        print "$i ".$_." ".chr(hex($_))."\n";
        $i++;
    }
    print "Send: '$s'\n" if ($debug);
    $ob->parity('odd')     || die "fail setting parity";
    $ob->write($s);
    select(undef,undef,undef,0.1);
    my $r = $ob->input;
    ### Some commands returns no values, return in that case..... ###
    return unless ($r);
    my @l = split(//,$r);
    if ($debug)
    {
        for(my $i = 0; $i < @l; $i++)
        {
            print $i,' ',ord($l[$i])," ",sprintf("%02X",ord($l[$i])),"\n";
        }
    }
    ### Check checksum ###
    my @check = ();
    my @res = ();
    for (my $x = 0; $x < @l-2; $x++)
    {
        my $val = sprintf("%02X",ord($l[$x]));
        push @check,$val;
        push @res,$l[$x];
    }
    @crc = elektrocrc(@check);
    unless (hex($crc[0]) == ord($l[@l-2]) && hex($crc[1]) == ord($l[@l-1]))
    {
        $ob->parity($parity)     || die "fail setting parity";
        return "Communication error: Wrong CRC!";
    }
    if (ord($l[2]) == 255)
    {
        $ob->parity($parity)     || die "fail setting parity";
        return "Communication error: Command not understood, errorcode: ".ord($l[3]);
    }
    $ob->parity($parity)     || die "fail setting parity";
    print "Result string from device: $r\n" if ($debug);
    ### Remove 3 bytes from head of array (start delimiter, device node and object id)
    shift @res;
    shift @res;
    shift @res;
    my $res = join('',@res);
    return $res;
}


sub elektrocrc(@)
{
    my $sum = 0;
    while (@_)
    {
        my $x = hex(shift);
        $sum += $x;
    }
    my $hb = ($sum/256)%256;
    my $lb = $sum%256;
    return (sprintf("%02X",$hb),sprintf("%02X",$lb));
}

sub PSU_init_31
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "INIT $inp\n" if ($debug);
    return "Error: Not enough paramters for PSU init: $inp\n" unless (@_ > 1);
    if ( ( $_[0] =~ /^\d+$/ ) && ( $_[1] =~ /^\d+$/ ) ) 
    {
	my $s1 = sprintf "%02d", $_[0];
	my $s2 = sprintf "%d",   $_[1];
	my $s3 = sprintf "%.2f", $_[2];
	if ( $s3 < 0.001 ) { $s3 = "15" }
	my $s;
	if ($pwdctr)
	{
	    $s = "!" . $s1 . "CH " . $s2 . "\r";
	}
	else
	{
	    $s = "CH " . $s2 . "\r";
	}
	print "send >>", $s if ($debug);
	$ob->write($s);
	sleep($pause);
	my $r = $ob->input;
	print $r, "\n" if ($debug);
	print "send >>", $s if ($debug);
	$ob->write($s);
	sleep($pause);
	$r = $ob->input;
	print $r, "\n" if ($debug);
	if ($pwdctr)
	{
	    $s = "!" . $s1 . "*idn?\r";
	}
	else
	{
	    $s = "*idn?\r";
	}
	sleep($pause);
	print "send >>", $s if ($debug);
	$ob->write($s);
	
	sleep($pause);
	$r = $ob->input;
	print $r, "\n" if ($debug);
	if ($pwdctr)
	{
	    $s = "!" . $s1 . "SOURCE:VOLT:MAXI 100\r";
	}
	else
	{
	    $s = "SOURCE:VOLT:MAXI 100\r";
	}
	print "send >>", $s if ($debug);
	$ob->write($s);
	sleep($pause);
	$r = $ob->input;
	print $r, "\n" if ($debug);
	if ($pwdctr)
	{
	    $s = "!" . $s1 . "SOURCE:CURR:MAXI 100\r";
	}
	else
	{
	    $s = "SOURCE:CURR:MAXI 100\r";
	}
	print "send >>", $s if ($debug);
	$ob->write($s);
	sleep($pause);
	$r = $ob->input;
	print $r, "\n" if ($debug);
	if ($pwdctr)
	{
	    $s = "!" . $s1 . "SOURCE:CURR 0\r";
	}
	else
	{
	    $s = "SOURCE:CURR 0\r";
	}
	print "send >>", $s if ($debug);
	$ob->write($s);
	sleep($pause);
	$r = $ob->input;
	print $r, "\n" if ($debug);
	if ($pwdctr)
	{
	    $s = "!" . $s1 . "SOURCE:VOLT " . $s3 . "\r";
	}
	else
	{
	    $s = "SOURCE:VOLT " . $s3 . "\r";
	}
	print "send >>", $s if ($debug);
	$ob->write($s);
	sleep($pause);
	$r = $ob->input;
	print $r, "\n" if ($debug);
	$res = $inp. " ". $s."\n";
	if ( $r =~ /\>/ ) {
	    $res .= " ok\n";
	}
    }
    return $res;
}



sub PSU_set_volt_31
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "VOLT $inp\n" if ($debug);
    return "Error: Not enough paramters for PSU set volt: $inp\n" unless (@_ > 1);
    if ( $_[1] =~ /OCV/i )
    {
        if ( ( $_[0] =~ /^\d+$/ ) && ( $_[1] =~ /^\d+$/ ) )
        {
            my $s1 = sprintf "%02d", $_[0];
            my $s2 = sprintf "%d",   $_[1];
            my $s;
            if ($pwdctr)
            {
                $s = "!" . $s1 . "CH " . $s2 . "\r";
            }
            else
            {
                $s = "CH " . $s2 . "\r";
            }
            print "send >>", $s if ($debug);
            $ob->write($s);
            sleep($pause);
            my $r = $ob->input;
            $ob->write($s);
            sleep($pause);
            $r = $ob->input;
            print $r, "\n" if ($debug);
            if ($pwdctr)
            {
                $s = "!" . $s1 . "SO:FU:RSD ON" . "\r";
            }
            else
            {
                $s = "SO:FU:RSD ON" . "\r";
            }

            print "send >>", $s if ($debug);
            $ob->write($s);
            sleep($pause);
            $r = $ob->input;
            if ($pwdctr)
            {
                $s = "!" . $s1 . "SOURCE:VOLT 0.00\r";
            }
            else
            {
                $s = "SOURCE:VOLT 0.00\r";
            }
            print "send >>", $s if ($debug);
            $ob->write($s);
            sleep($pause);
            $r .= $ob->input;
            print $r, "\n" if ($debug);
            $res = $inp. " ". $s."\n";
        }
    }
    else 
    {
        if ( ( $_[0] =~ /^\d+$/ ) && ($_[1] =~ /^[\d\.]+$/) )
        {
            my $s1 = sprintf "%02d", $_[0];
            my $s2 = sprintf "%d",   $_[1];
            my $s3 = sprintf "%.2f", $_[2];
            my $s;
            if ($pwdctr)
            {
                $s = "!" . $s1 . "CH " . $s2 . "\r";
            }
            else
            {
                $s = "CH " . $s2 . "\r";
            }
            print "send >>", $s, "\n" if ($debug);
            $ob->write($s);
            sleep($pause);
            my $r = $ob->input;
            $ob->write($s);
            sleep($pause);
            $r = $ob->input;
            if ($pwdctr)
            {
                $s = "!" . $s1 . "SO:FU:RSD OFF" . "\r";
            }
            else
            {
                $s = "SO:FU:RSD OFF" . "\r";
            }
            print "send >>", $s if ($debug);
            $ob->write($s);
            sleep($pause);
            $r = $ob->input;

            print $r, "\n" if ($debug);
            if ($pwdctr)
            {
                $s = "!" . $s1 . "SOURCE:VOLT " . $s3 . "\r";
            }
            else
            {
                $s = "SOURCE:VOLT " . $s3 . "\r";
            }
            print "send >>", $s if ($debug);
            $ob->write($s);
            sleep($pause);
            $r = $ob->input;
            print $r, "\n" if ($debug);
            $res = $inp. " ". $s."\n";
        }
    }
    return $res;
}




sub PSU_set_31
{
    my $res = undef;
    my $inp = join(' ',@_);
    print "CURRENT $inp\n" if ($debug);
    return "Error: Not enough paramters for PSU set: $inp\n" unless (@_ > 1);
    if ( $_[2] =~ /OCV/i ) 
    {
	if ( ( $_[0] =~ /^\d+$/ ) && ( $_[1] =~ /^\d+$/ ) ) 
	{
	    my $s1 = sprintf "%02d", $_[0];
	    my $s2 = sprintf "%d",   $_[1];
	    my $s;
	    if ($pwdctr)
	    {
		$s = "!" . $s1 . "CH " . $s2 . "\r";
	    }
	    else
	    {
		$s = "CH " . $s2 . "\r";
	    } 
	    print "send >>", $s if ($debug);
	    $ob->write($s);
	    sleep($pause);
	    my $r = $ob->input;
	    $ob->write($s);
	    sleep($pause);
	    $r = $ob->input;
	    print $r, "\n" if ($debug);
	    if ($pwdctr)
	    {
		$s = "!" . $s1 . "SO:FU:RSD ON" . "\r";
	    }
	    else
	    {
		$s = "SO:FU:RSD ON" . "\r";
	    }
	    print "send >>", $s if ($debug);
	    $ob->write($s);
	    sleep($pause);
	    $r = $ob->input;
	    if ($pwdctr)
	    {
		$s = "!" . $s1 . "SOURCE:CURR 0.00\r";
	    }
	    else
	    {
		$s = "SOURCE:CURR 0.00\r";
	    }
	    print "send >>", $s if ($debug);
	    $ob->write($s);
	    sleep($pause);
	    $r .= $ob->input;
	    print $r, "\n" if ($debug);
	    $res = $inp. " ". $s."\n";
	}
    }
    else {
	if ( ( $_[0] =~ /^\d+$/ ) && ( $_[1] =~ /^\d+$/ ) && ($_[2] =~ /^[\d\.]+$/) ) 
	{
	    my $s1 = sprintf "%02d", $_[0];
	    my $s2 = sprintf "%d",   $_[1];
	    my $s3 = sprintf "%.2f", $_[2];
	    my $s;
	    if ($pwdctr)
	    {
		$s = "!" . $s1 . "CH " . $s2 . "\r";
	    }
	    else
	    {
		$s = "CH " . $s2 . "\r";
	    }
	    print "send >>", $s, "\n" if ($debug);
	    $ob->write($s);
	    sleep($pause);
	    my $r = $ob->input;
	    $ob->write($s);
	    sleep($pause);
	    $r = $ob->input;
	    if ($pwdctr)
	    {
		$s = "!" . $s1 . "SO:FU:RSD OFF" . "\r";
	    }
	    else
	    {
		$s = "SO:FU:RSD OFF" . "\r";
	    }
	    print "send >>", $s if ($debug);
	    $ob->write($s);
	    sleep($pause);
	    $r = $ob->input;
	    
	    print $r, "\n" if ($debug);
	    if ($pwdctr)
	    {
		$s = "!" . $s1 . "SOURCE:CURR " . $s3 . "\r";
	    }
	    else
	    {
		$s = "SOURCE:CURR " . $s3 . "\r";
	    }
	    print "send >>", $s if ($debug);
	    $ob->write($s);
	    sleep($pause);
	    $r = $ob->input;
	    print $r, "\n" if ($debug);
	    $res = $inp. " ". $s."\n";
	}
    }
    return $res;
}

############################################################
##### Utility functions below. Not intended for direct #####
##### execution from main loop, called by the various  #####
##### functions above where appropriate                #####
############################################################

sub set_euro_comm {
    if ( $_[0] ) { $ob->baudrate( $_[0] ) || die "fail setting baudrate"; }
    $ob->parity("even")    || die "fail setting parity";
    $ob->databits(7)       || die "fail setting databits";
    $ob->stopbits(1)       || die "fail setting stopbits";
    $ob->handshake("none") || die "fail setting handshake";
    $ob->datatype('raw');

}

sub set_modbus_comm {
    $ob->baudrate(9600)    || die "fail setting baudrate";
    $ob->parity("none")    || die "fail setting parity";
    $ob->databits(8)       || die "fail setting databits";
    $ob->stopbits(1)       || die "fail setting stopbits";
    $ob->handshake("none") || die "fail setting handshake";
    $ob->datatype('raw');
}

sub set_omron_comm {
    $ob->baudrate(9600)    || die "fail setting baudrate";
    $ob->parity("even")    || die "fail setting parity";
    $ob->databits(8)       || die "fail setting databits";
    $ob->stopbits(1)       || die "fail setting stopbits";
    $ob->handshake("none") || die "fail setting handshake";
    $ob->datatype('raw');
}

sub set_comm {
    $ob->baudrate(9600)    || die "fail setting baudrate";
    $ob->parity("none")    || die "fail setting parity";
    $ob->databits(8)       || die "fail setting databits";
    $ob->stopbits(1)       || die "fail setting stopbits";
    $ob->handshake("none") || die "fail setting handshake";
}

sub construct_packet {

    #adress, command, data
    my $adr = $_[0];
    my $a1  = int( $adr / 10 );
    my $a2  = $adr % 10;
    my $s   = $_[1] . $_[2] . "\003";
    $s = xorstr($s);
    $s = "\004" . $a1 . $a1 . $a2 . $a2 . "\002" . $s;
}

sub read_packet 
{
    #adress, command
    my $adr = $_[0];
    my $a1  = int( $adr / 10 );
    my $a2  = $adr % 10;
    my $s = "\004" . $a1 . $a1 . $a2 . $a2 . $_[1] . "\005";
    return $s;
}

sub xorstr 
{
    my $xorstring = $_[0];
    my $i         = 0;
    my $xo        = substr( $xorstring, 0, 1 );

    for (my $i = 1 ; $i < length($xorstring) ; $i++ ) {
        $xo ^= substr( $xorstring, $i, 1 );
#printf "%d %d %x %x\n",$i,ord($xo),ord($xo),ord(substr($xorstring,$i,1));;
    }
    $xorstring = $xorstring . $xo;
    return $xorstring;
}

sub gnirts {
    my $s   = shift;
    my $rep = "";
    for ( my $i = length($s) ; $i >= 0 ; $i-- ) {
        $rep = $rep . substr( $s, $i, 1 );
    }
    return $rep;
}

sub rbuf {
    my ($blf, $inb, $outb, $errfl, $r);
    $inb = 0;
    my $c   = "";
    ( $blf, $inb, $outb, $errfl ) = $ob->status;
    #print "rbuf1:",$inb," ",$c,"\n";
    if ($inb) {
        while ($inb) {
            $r = $ob->input;
            $c = $c . $r;

            #print "received:",$inb,"\n",$c,"\n";
            #printf "%x \n",ord(substr($c,0,1));
            #	for ($i=0;$i<$inb;$i++) { printf " %d ",ord(substr($r,$i,1));}
            ( $blf, $inb, $outb, $errfl ) = $ob->status;
        }
    }
    #print "end:",$c,"\n";
    return $c;
}

sub setbrooks {
    $ob->baudrate($brooks_baudrate) || die "fail setting baudrate";
    $ob->parity($brooks_parity)     || die "fail setting parity";
}

sub resetbrooks {
    $ob->baudrate($baudrate) || die "fail setting baudrate";
    $ob->parity($parity)     || die "fail setting parity";
}

sub setlinkam {
    $ob->baudrate($linkam_baudrate) || die "fail setting baudrate";
}

sub resetlinkam {
    $ob->baudrate($baudrate) || die "fail setting baudrate";
}

sub brooksinit {
    &setbrooks();
    my $r = "";
    my $a;
    my $ss = "";
    my $id = shift;
    $ss = $ss . sprintf "%c", 130;
    $ss = $ss . sprintf "%c", 128;
    $ss = $ss . sprintf "%c", 0;
    $ss = $ss . sprintf "%c", 0;
    $ss = $ss . sprintf "%c", 0;
    $ss = $ss . sprintf "%c", 0;
    $ss = $ss . sprintf "%c", 11;
    $ss = $ss . sprintf "%c", 6;
    $ss = $ss . pch( $id );
    $ss = xorstr($ss);
    $ss = $pre . $ss;
    $ob->write($ss);
    my $rep = &rdata();
    if ($rep)
    {
	### Set tagname info in global hashes ###
	$name{$id} = substr( $rep, 11, 3 );
	$type{$id} = substr( $rep, 4,  1 );
	if ( length($rep) > 10 ) {
	    $r = $id . " ";
	    for ( my $i = 0 ; $i < 3 ; $i++ ) {
		$a = sprintf " %d ", ord( substr( $name{$id}, $i, 1 ) );
		$r = $r . $a;
	    }
	    $r = $r . "\n";
	}
	&resetbrooks();
	return $r;
    }
    else
    {
	&resetbrooks();
	return undef;
    }
}

sub rdata {
    my ($c, $istart, $blf, $inb, $outb, $errfl, $r);
    my ($ack, $add1, $add2, $repname, $cmdno, $bytecount, $statusbyte1, $statusbyte2);
    my $giveup    = 20;
    $inb = 0;

    for ( my $i = 1 ; $i < $giveup ; $i++ ) {
        select undef, undef, undef, $minipause;
        ( $blf, $inb, $outb, $errfl ) = $ob->status;
        if ( $inb > 5 ) {
            select undef, undef, undef, $minipause;
            $i = $giveup;
        }
    }
    if ( $inb < 5 ) { return "" }
    $r      = $ob->input;
    $istart = 0;
    do {
        $c = ord( substr( $r, $istart++, 1 ) );
        if ($debug) { print $c, "\n"; }
    } while ( ( $c == 255 ) && ($inb) );
    $istart--;
    if ($debug) { print $istart, "\n"; }

    my $checkxor = substr( $r, $istart, length($r) - $istart );
    $checkxor = xorstr($checkxor);
    if ($debug) { print "xo>", ord( substr( $checkxor, -1, 1 ) ), "\n"; }
    $ack = substr( $r, $istart, 1 );
    if ($debug) { printf "ack> %x\n", ord($ack); }

    $c = substr( $r, $istart + 1, 1 );
    if ($debug) { printf "add1 %x\n", ord($c); }
    $c = substr( $r, $istart + 2, 1 );
    if ($debug) { printf "add2 %x\n", ord($c); }
    for (my $i = 1 ; $i <= 3 ; $i++ ) {
        $c = substr( $r, $istart + 2 + $i, 1 );
        if ($debug) { printf "name %d %d %x\n", $i, ord($c), ord($c); }
    }

    $c = substr( $r, $istart + 6, 1 );
    if ($debug) { printf "cmd %d %x\n", ord($c), ord($c); }

    $c = substr( $r, $istart + 7, 1 );
    if ($debug) { printf "bytecount %d %x\n", ord($c), ord($c); }
    $bytecount = ord($c);

    my $rep = substr( $r, $istart + 8, $bytecount );
    for (my $i = 0 ; $i < length($rep) ; $i++ ) {
        $c = substr( $rep, $i, 1 );
        if ($debug) { printf "data %d  %d %x\n", $i, ord($c), ord($c); }
    }
    return $rep;
}

sub pdeb()
{
    print join("\n",@_);
}

sub brooks_query {
    my $id = shift;
    my $tag = shift;
    my @args = @_;
    my $length = @args;
    &setbrooks();
    my $ss = "";
    $ss = $cmdpre . $type{ $id } . $name{ $id };
    my $c  = sprintf "%c", $tag;
    $ss = $ss . $c;
    $c  = sprintf "%c", $length;
    $ss = $ss . $c;
    foreach my $item (@args)
    {
	$ss = $ss . sprintf("%c", $item);
    }
    $ss = xorstr($ss);
    $ss = $pre . $ss;
    &pdeb($ss) if ($debug);
    $ob->write($ss);
    my $dat = &rdata();
    &resetbrooks();
    my @l = ();
    foreach my $c (split(//,$dat))
    {
        push @l,ord($c);
    }
    return join(' ',@l);
}


sub readflow {
    &setbrooks();
    my $ss = "";
    $ss = $cmdpre . $type{ $_[0] } . $name{ $_[0] };
    my $c  = sprintf "%c", 1;
    $ss = $ss . $c;
    $c  = sprintf "%c", 0;
    $ss = $ss . $c;
    $ss = xorstr($ss);
    $ss = $pre . $ss;
    $ob->write($ss);

    if ($debug) {
        &pdeb($ss);
    }

    my $dat = rdata();
    &resetbrooks();
    if ($debug) {
        &pdeb($dat);
    }
    my $f = -1;
    if ( length($dat) > 6 ) {
        $f = sprintf "%6.3f", unpack( "f", &gnirts( substr( $dat, 3, 4 ) ) );
    }
    return $f;
}

sub setflow {
    &setbrooks();
    my $ss = "";
    $ss = $cmdpre . $type{ $_[0] } . $name{ $_[0] };
    my $c  = sprintf "%c", 236;
    $ss = $ss . $c;
    $c  = sprintf "%c", 5;
    $ss = $ss . $c;
    $c  = sprintf "%c", 57;                            #setpoint %

    $ss = $ss . $c;
    $ss = $ss . gnirts( pack( "f", $_[1] ) );
    $ss = xorstr($ss);
    $ss = $pre . $ss;
    if ($debug) { &pdeb($ss); }
    $ob->write($ss);
    my $dat = &rdata();
    &resetbrooks();
    my $f = -1;
    if ( length($dat) > 6 ) {
        $f = sprintf "%6.3f", unpack( "f", &gnirts( substr( $dat, 3, 4 ) ) );
    }
    return $f;
}

sub setoverride {
    &setbrooks();
    my $ss = "";
    $ss = $cmdpre . $type{ $_[0] } . $name{ $_[0] };
    my $c  = sprintf "%c", 231;
    $ss = $ss . $c;
    $c  = sprintf "%c", 1;
    $ss = $ss . $c;
    $c  = sprintf "%c", $_[1];
    $ss = $ss . $c;
    $ss = xorstr($ss);
    $ss = $pre . $ss;
    if ($debug) { &pdeb($ss); }
    $ob->write($ss);
    my $dat = &rdata();
    &resetbrooks();
    if ($debug) { &pdeb($dat); }
    ord( substr( $dat, 2, 1 ) );
}

sub pch {
    my $s  = "";
    my $id = shift;
    my ($c,$cs,$ss,$cp,$sum);
    for (my $i = 0 ; $i < length($id) ; $i++ ) {
        $c = substr( $id, $i, 1 );
        $cs = sprintf "%vb", $c;

        # print  substr( $cs, length($cs)-6, 6 ),"\n";
        $s = $s . substr( $cs, length($cs) - 6, 6 );

        #    print $s,"\n";

        #print $c," ",ord($c)," ",length($cs),"\n";
    }

    my $pa = "";
    for (my $i = 0 ; $i < 6 ; $i++ ) {
        $ss = substr( $s, $i * 8, 8 );

        #    print $ss, "\n";
        $sum = 0;
        for (my $j = 0 ; $j < 8 ; $j++ ) {
            $sum += ( substr( $ss, 7 - $j, 1 ) * ( 2**$j ) );

        }
        $cp = sprintf "%c", $sum;
        $pa = $pa . $cp;
    }
    return $pa;
}

sub modbusbytepack
{
    my $cstr = $crc.' ';
    my $str="";
    for (@_[1..$#_]) {
	$str .= chr( $_);
	$cstr .= $_ . " ";	
    }
    my $rep = &crcstr($cstr);
    my @r = split ( " ", $rep );
    $str .= chr( $r[0] );
    $str .= chr( $r[1] );
    return $str;
}

sub modbuspack 
{
    my $cstr = $crc.' ';
    $str  = "";
    $str .= chr( $_[0] );
    $cstr .= $_[0] . " ";
    $str .= chr( $_[1] );
    $cstr .= $_[1] . " ";
    my $high = int( $_[2] / 256 );
    $cstr .= $high . " ";
    my $low = int( $_[2] % 256 );
    $cstr .= $low . " ";
    $str .= chr($high);
    $str .= chr($low);
    $high = int( $_[3] / 256 );
    $cstr .= $high . " ";
    $low = int( $_[3] % 256 );
    $cstr .= $low . " ";
    $str .= chr($high);
    $str .= chr($low);
#    my $rep = `$cstr`;
    my $rep = &crcstr($cstr);
    my @r = split ( " ", $rep );
    $str .= chr( $r[0] );
    $str .= chr( $r[1] );
    #    for (0..7) { print ord(substr($str,$_,1)),"\n"};
    return $str;
};

sub modbusfloatpack {
    my $address   = 32768 + 2 * $_[1];
    my $noofwords = 2;
    my $ssp        =  &gnirts( pack( "f", $_[2] ) );

    my $cstr = $crc.' ';
    my $str  = "";

    # device
    $str .= chr( $_[0] );
    $cstr .= $_[0] . " ";

    # function code 
    $str .= chr(16);
    $cstr .= 16 . " ";

    #address
    my $high = int( $address / 256 );
    $cstr .= $high . " ";
    my $low = int( $address % 256 );
    $cstr .= $low . " ";

    $str .= chr($high);
    $str .= chr($low);

    #  number of words
    $high = int( $noofwords / 256 );
    $cstr .= $high . " ";
    $low = int( $noofwords % 256 );
    $cstr .= $low . " ";
    $str .= chr($high);
    $str .= chr($low);

    #  number of databytes
    $str .= chr(4);
    $cstr .= 4 . " ";

    # data
    for ( 0 .. 3 ) {
        my $d = ord( substr( $ssp, $_, 1 ) );
        $cstr .= $d . " ";
        $str .= chr($d);

        #printf "%X\n",ord(substr($ssp,$_,1))

    }
#    my $rep = `$cstr`;
    my $rep = &crcstr($cstr);
    my @r = split ( " ", $rep );
    $str .= chr( $r[0] );
    $str .= chr( $r[1] );
    #    for (0..7) { printf "%X \n", ord(substr($str,$_,1));};
    return $str;
}


sub crcstr($)
{
    my $str = shift;
    my @data = split(/[\s\t]+/,$str);
    shift @data if (@data && $data[0] =~ /[a-zA-Z]/);
    return join(' ',&crc(@data))." \n";
}

sub crc
{
    my @data = ();
    foreach (@_)
    {
	my $val = $_;
	next unless (defined($val) && $val =~ /\d/);
	push @data,$val+0;
    }
    my $carry_flag;
    my $crc=0xffff;
    for (my $i=0;$i<@data;$i++)
    {
	$crc=$crc ^ $data[$i];
	for (my $j=0;$j<8;$j++)
	{
	    $a=$crc;
	    $carry_flag= $a & 0x0001;
	    $crc=$crc >> 1;
	    if ($carry_flag==1) { $crc=$crc^0xa001 };
	}
    }
    my $val1 = sprintf("%d",$crc%256);
    my $val2 = sprintf("%d",$crc/256);
    return ($val1,$val2);
}
