$LIST OFF
$STANDARD_LEVEL   SYSTEM
C-----------------------------------------------------------------------
C  IPCTEST     Keven Miller  15 Jan 2001   kpmiller@reeltapetransfer.com
C     Use TELNET from another machine to make tcp test connections.
C-----------------------------------------------------------------------
      PROGRAM IPCTEST
C
$INCLUDE "IPCCOMF"
C
      CHARACTER   HOSTNAME*64
      INTEGER     HLEN, ERR, SOCK1, SOCK2, SOCK, PORT
      RECORD /IPC_ADR/  ADR
C
C  HOSTNAME (ARPANAME) TEST
C
      ERR = IPC_HOSTNAME ( HOSTNAME, HLEN )
      PRINT *,"Arpa name ",HOSTNAME(1:HLEN),"(",HLEN,")", " err",ERR
C
C  NS NODENAME TEST
C
      ERR = IPC_NODENAME ( HOSTNAME, HLEN )
      PRINT *,"Node name ",HOSTNAME(1:HLEN),"(",HLEN,")", " err",ERR
C
C  START TCP SERVER
C
      PORT = 40000
      ERR = IPC_LISTEN ( SOCK1, PORT, IPC_SOCK_STREAM, 1 )
      IF (ERR.NE.0) CALL IPCERR (ERR,"TCP LISTEN")
      IF (ERR.EQ.0) PRINT *,"TCP listening on port ",PORT
C
C  START UDP SERVER
C
      PORT = 0
      ERR = IPC_LISTEN ( SOCK2, PORT, IPC_SOCK_DGRAM, 0 )
      IF (ERR.NE.0) CALL IPCERR (ERR,"UDP LISTEN")
      IF (ERR.EQ.0) PRINT *,"UDP listening on port ",PORT
C
C  SEND UDP MSG TO SELF
C     If you have JINETD running, you can set the PORT value to 13
C     to get the system's daytime response
C
      ADR.PORT = PORT
      ADR.IP(1:1) = CHAR(127)
      ADR.IP(2:2) = CHAR(0)
      ADR.IP(3:3) = CHAR(0)
      ADR.IP(4:4) = CHAR(1)
      HOSTNAME = "UDC test message"
      ERR = IPC_SENDTO (SOCK2,HOSTNAME,16,ADR)
      IF (ERR.NE.0) CALL IPCERR (ERR,"UDP SEND")
C
C  RECV UDP MSG FROM SELF
C
      HOSTNAME = "Junk"
      ERR = IPC_RECVFROM (SOCK2,HOSTNAME,HLEN,ADR)
      IF (ERR.NE.0) CALL IPCERR (ERR,"UDP RECV")
      PRINT *,"UDP from",
     *ICHAR(ADR.IP(1:1)),ICHAR(ADR.IP(2:2)),
     *ICHAR(ADR.IP(3:3)),ICHAR(ADR.IP(4:4)),":",ADR.PORT," ",
     *"""",HOSTNAME(1:HLEN),""""
C
C  Wait for TCP connection
C  MUST initialize these variables to get accurate error messages!
      SOCK = 0
      PRINT *,"Use telnet to connect to tcp port 40000"
      PRINT *,"Waiting for TCP connection (15 SEC)..."
      ERR = IPC_SOCKOPT (SOCK1,IPC_OPT_TIMEOUT,150)
      IF (ERR.NE.0) CALL IPCERR (ERR,"ACCEPT TIMEOUT")
C
      ERR = IPC_ACCEPT (SOCK,SOCK1,ADR,.TRUE.)
      IF (ERR.NE.0) CALL IPCERR (ERR,"TCP ACCEPT")
      IF (ERR.EQ.0) PRINT *,"TCP from",
     *ICHAR(ADR.IP(1:1)),ICHAR(ADR.IP(2:2)),
     *ICHAR(ADR.IP(3:3)),ICHAR(ADR.IP(4:4)),":",ADR.PORT
C
      ERR = IPC_SOCKOPT (SOCK1,IPC_OPT_TIMEOUT,0)
      IF (ERR.NE.0) CALL IPCERR (ERR,"ACCEPT TIMEOUT 0")
C
      IF (SOCK.NE.0) THEN
         ERR = IPC_SOCKOPT (SOCK,IPC_OPT_ACCEPT,0)
         IF (ERR.NE.0) CALL IPCERR (ERR,"OPT ACCEPT")
C
C  SEND DATA TEST
C
         HOSTNAME = "Enter a char within 10 seconds"
         ERR = IPC_SEND (SOCK,HOSTNAME,30)
         IF (ERR.NE.0) CALL IPCERR (ERR,"TCP SEND")
C
C  RECV DATA TEST
C
         ERR = IPC_SOCKOPT (SOCK,IPC_OPT_TIMEOUT,100)
         IF (ERR.NE.0) CALL IPCERR (ERR,"RECV TIMEOUT 100")
C
         ERR = IPC_RECV (SOCK,HOSTNAME,HLEN,.TRUE.)
         IF (ERR.NE.0) CALL IPCERR (ERR,"TCP RECV PREV")
         IF (ERR.EQ.0) PRINT *,"Preview ",HOSTNAME (1:HLEN)
         ERR = IPC_RECV (SOCK,HOSTNAME,HLEN,.FALSE.)
         IF (ERR.NE.0) CALL IPCERR (ERR,"TCP RECV")
         IF (ERR.EQ.0) PRINT *,"Recv    ",HOSTNAME (1:HLEN)
C
C  Signal gracefull shutdown; Note 10 second recv still in effect
C
         ERR = IPC_SHUT (SOCK)
         IF (ERR.NE.0) CALL IPCERR (ERR,"TCP SHUT")
C  Wait for peer to shutdown -- we get err 68
         ERR = IPC_RECV (SOCK,HOSTNAME,HLEN,.FALSE.)
C 68 = peer has shutdown socket
C 64 = peer Aborted the connection
         IF (ERR.NE.68 .AND. ERR.NE.0 .AND. ERR.NE.64)
     *      CALL IPCERR (ERR,"SHUT RECV")
         IF (ERR.EQ.0) PRINT *,"Unexpected data ",HOSTNAME (1:HLEN)
         ERR = IPC_CLOSE (SOCK)
         IF (ERR.NE.0) CALL IPCERR (ERR,"TCP CLOSE")
      ENDIF
C
C  Test TCP by hostname; 13 is daytime port
C  Place a known hostname here
      PRINT *,"Using TCP to daytime port 13"
      HOSTNAME = "localhost"
      ERR = IPC_CONNECT (SOCK,ADR,HOSTNAME (1:9),13,40001,0)
      IF (ERR.NE.0) THEN
         CALL IPCERR (ERR,"TCP CONN 1")
      ELSE
         ERR = IPC_RECV (SOCK,HOSTNAME,HLEN,.FALSE.)
         IF (ERR.NE.0) CALL IPCERR (ERR,"TCP RECV 1")
         IF (ERR.EQ.0) PRINT *,"Recv from loopback:13 ",
     *      """",HOSTNAME (1:HLEN),""""
         ERR = IPC_RECV (SOCK,HOSTNAME,HLEN,.FALSE.)
         IF (ERR.EQ.0) PRINT *,"Recv from loopback:13 ",
     *      HOSTNAME (1:HLEN)
         IF (ERR.NE.68 .AND. ERR.NE.0)
     *      CALL IPCERR (ERR,"TCP RECV 1 SHUT")
C
         ERR = IPC_CLOSE (SOCK)
         IF (ERR.NE.0) CALL IPCERR (ERR,"TCP CLOSE 1")
      ENDIF
C
C  Test TCP by ADR
C
      PRINT *,"TCP Connect by adr 127.0.0.1  ..."
      ADR.PORT = 13
      ADR.IP(1:1) = CHAR(127)
      ADR.IP(2:2) = CHAR(0)
      ADR.IP(3:3) = CHAR(0)
      ADR.IP(4:4) = CHAR(1)
      HOSTNAME = " "
      ERR = IPC_CONNECT (SOCK,ADR,HOSTNAME,0,0,50)
      IF (ERR.NE.0) THEN
         CALL IPCERR (ERR,"TCP CONN 2")
      ELSE
         ERR = IPC_RECV (SOCK,HOSTNAME,HLEN,.FALSE.)
         IF (ERR.NE.0) CALL IPCERR (ERR,"TCP RECV 2")
         IF (ERR.EQ.0) PRINT *,"Recv ",HOSTNAME (1:HLEN)
         ERR = IPC_RECV (SOCK,HOSTNAME,HLEN,.FALSE.)
         IF (ERR.EQ.0) PRINT *,"Recv ",HOSTNAME (1:HLEN)
         IF (ERR.NE.68.AND.ERR.NE.0) CALL IPCERR(ERR,"TCP RECV 2 SHUT")
C
         ERR = IPC_CLOSE (SOCK)
         IF (ERR.NE.0) CALL IPCERR (ERR,"TCP CLOSE 2")
      ENDIF
C
C  CLOSE SERVERS
C
      ERR = IPC_CLOSE (SOCK2)
      IF (ERR.NE.0) CALL IPCERR (ERR,"UDP CLOSE")
      ERR = IPC_CLOSE (SOCK1)
      IF (ERR.NE.0) CALL IPCERR (ERR,"TCP CLOSE")
C
      STOP
      END
C-----------------------------------------------------------------------
C  IPCERR   Print err message and location
C     NOWAITIO has no effect
C-----------------------------------------------------------------------
      SUBROUTINE IPCERR (PERR,WHERE)
      INTEGER     PERR
      CHARACTER   WHERE*(*)
C
      INTEGER*4   ERR, MYLEN, EERR
      CHARACTER   MSG*80
      SYSTEM INTRINSIC  IPCERRMSG
C
      PRINT *,"Error at ",WHERE
      ERR = PERR
      CALL IPCERRMSG ( ERR, MSG, MYLEN, EERR )
      IF (EERR.NE.0) PRINT *,"IPCERRMSG error",EERR," on error",ERR
      IF (EERR.EQ.0) PRINT *,MSG(1:MYLEN)
      RETURN
      END
C-----------------------------------------------------------------------
C  IPC_NODENAME      Get the NS nodename
C     HOSTNAME output   NS NODE hostname
C     HLEN     output   length of NS nodename
C     Returns error code from NSINFO.
C     NOWAITIO has no effect
C-----------------------------------------------------------------------
C
      INTEGER FUNCTION IPC_NODENAME ( HOSTNAME, HLEN )
C
      INTEGER     HLEN
      CHARACTER   HOSTNAME*(*)
C
      CHARACTER   NODENAME*52
      INTEGER*2   IERR, NLEN
      SYSTEM INTRINSIC  NSINFO
C
      CALL NSINFO (,,,IERR,18,NLEN,19,NODENAME)
      HLEN = NLEN
      IF (HLEN.GT.SIZEOF(HOSTNAME)) HLEN = SIZEOF(HOSTNAME)
      HOSTNAME = NODENAME
      IPC_HOSTNAME = IERR
      RETURN
      END
C-----------------------------------------------------------------------
C  IPC_HOSTNAME      Get the ARPA hostname
C     HOSTNAME output   ARPA hostname
C     HLEN     output   length of ARPA hostname
C     Returns error code from NSINFO.
C     NOWAITIO has no effect
C-----------------------------------------------------------------------
C
      INTEGER FUNCTION IPC_HOSTNAME ( HOSTNAME, HLEN )
C
      INTEGER     HLEN
      CHARACTER   HOSTNAME*(*)
C
      CHARACTER   ARPANAME*255
      INTEGER*2   IERR, ALEN
      SYSTEM INTRINSIC  NSINFO
C
      CALL NSINFO (,,,IERR,36,ALEN,37,ARPANAME)
      HLEN = ALEN
      IF (HLEN.GT.SIZEOF(HOSTNAME)) HLEN = SIZEOF(HOSTNAME)
      HOSTNAME = ARPANAME
      IPC_HOSTNAME = IERR
      RETURN
      END
C-----------------------------------------------------------------------
C  IPC_CLOSE      Close and release socket resources
C     If no error then set SOCK = 0
C     Returns IPC error code
C     NOWAITIO has no effect
C-----------------------------------------------------------------------
      INTEGER FUNCTION IPC_CLOSE ( SOCK )
C
      INTEGER*4   SOCK
C
      INTEGER*4   ERR
      SYSTEM INTRINSIC  IPCSHUTDOWN
C
      CALL IPCSHUTDOWN (SOCK,,,ERR)
      IF (ERR.EQ.0) SOCK = 0
      IPC_CLOSE = ERR
      RETURN
      END
C-----------------------------------------------------------------------
C  IPC_SHUT       Send and set GRACEFULL shutdown
C     SOCK remains open for RECV only
C     Returns IPC error code
C     NOWAITIO has no effect
C-----------------------------------------------------------------------
      INTEGER FUNCTION IPC_SHUT (SOCK)
C
      INTEGER*4   SOCK
C
      INTEGER*4   ERR, FLAGS
      SYSTEM INTRINSIC  IPCSHUTDOWN
C
C  Set flags to graceful shutdown
C
      FLAGS = 16384
      CALL IPCSHUTDOWN (SOCK,FLAGS,,ERR)
      IPC_SHUT = ERR
      RETURN
      END
C-----------------------------------------------------------------------
C  IPC_LISTEN     Start a TCP or UCP listener on port PORT.
C     SOCKTYPE specifies either TCP or UDP; see IPCCOMF.
C     For TCP, max queue length of QUEUE, If zero, use system default
C     If PORT is zero, system will use a random port number which is
C     returned in PORT
C     Returns IPC error code
C     NOWAITIO has no effect
C-----------------------------------------------------------------------
      INTEGER FUNCTION IPC_LISTEN (SOCK,PORT,SOCKTYPE,QUEUE)
C
$INCLUDE "IPCCOMF"
C
      INTEGER*4   SOCK
      INTEGER     PORT, SOCKTYPE, QUEUE
C
      INTEGER*4   ERR, KIND, PROTOCOL
      INTEGER*2   IERR, OPTS (12), IQUE
      RECORD /IPC_ADR/  ADR
      SYSTEM INTRINSIC  IPCCREATE, IPCCONTROL, ADDOPT, INITOPT
C
      SOCK = 0
      IQUE = 0
      IF (PORT.NE.0) IQUE = IQUE +1
      IF (SOCKTYPE.EQ.IPC_SOCK_STREAM.AND.QUEUE.NE.0) IQUE = IQUE +1
      CALL INITOPT (OPTS,IQUE,IERR)
      ERR = IERR
      IF (ERR.NE.0) GOTO 999
C
C  If port = 0 then system will assign a randon port number
C
      IF (PORT.NE.0) THEN
         ADR.PORT = PORT
         CALL ADDOPT (OPTS,0,128,SIZEOF (ADR.IPORT),ADR.IPORT,IERR)
         ERR = IERR
         IF (ERR.NE.0) GOTO 999
      END IF
C
      IF (SOCKTYPE.EQ.IPC_SOCK_STREAM.AND.QUEUE.NE.0) THEN
         IQUE = QUEUE
         CALL ADDOPT (OPTS,1,6,SIZEOF(IQUE),IQUE,IERR)
         ERR = IERR
         IF (ERR.NE.0) GOTO 999
      END IF
C
C  Default to TCP socket
C
      KIND = 3
      PROTOCOL = 4
      IF (SOCKTYPE.EQ.IPC_SOCK_DGRAM) THEN
C
C  User specified UDP socket
C
         KIND = 1
         PROTOCOL = 5
      ENDIF
      CALL IPCCREATE (KIND,PROTOCOL,,OPTS,SOCK,ERR)
      IF (ERR.NE.0) GOTO 999
C
C  Change default TCP port timeout of 60 seconds to 0; indefinate wait
C
      IF (SOCKTYPE.EQ.IPC_SOCK_STREAM) THEN
         IQUE = 0
         CALL IPCCONTROL (SOCK,3,IQUE,SIZEOF(IQUE),,,,ERR)
         IF (ERR.NE.0) THEN
            CALL IPCERR (ERR,"IPC_LISTEN TIMEOUT")
            ERR = 0
         ENDIF
      ENDIF
C
C  If port = 0 then get the assigned port number to return to user
C
      IF (PORT.EQ.0) THEN
         ADR.PORT = 0
         CALL IPCCONTROL (SOCK,514,,,ADR.IPORT,I,,ERR)
         IF (ERR.NE.0) GOTO 999
         PORT = ADR.PORT
      ENDIF
C
 999  CONTINUE
      IPC_LISTEN = ERR
      RETURN
      END
C-----------------------------------------------------------------------
C  IPC_SENDTO     Send UDP packet
C     User MUST provide ADR structure of destination IP and PORT
C     CLEN is length to send, and returns actual length sent.
C     Returns IPC error code
C     NOWAITIO has no effect
C-----------------------------------------------------------------------
      INTEGER FUNCTION IPC_SENDTO (SOCK,CBUF,CLEN,ADR)
C
$INCLUDE "IPCCOMF"
C
      INTEGER*4   SOCK
      INTEGER     CLEN
      CHARACTER   CBUF*(*)
      RECORD /IPC_ADR/  ADR
C
      INTEGER*4   ERR, MYLEN
      INTEGER     RLEN
      SYSTEM INTRINSIC  IPCSENDTO
C
C  PORT is actually a 16 bit unsigned number (1-65535)
C  Fortran does not supprt unisgned, so the ADR structure gives the
C  user a INTEGER*4 for port. Here we change the high INTEGER*2 to
C  the required family value, make the call, then return the high
C  INTEGER*2 to a zero.
C
      ADR.FAMILY = IPC_AF_INET
      CLEN = IPCSENDTO (SOCK,CBUF,CLEN,,ADR.FAMILY,SIZEOF(ADR),ERR)
      ADR.FAMILY = 0
      IPC_SENDTO = ERR
      RETURN
      END
C-----------------------------------------------------------------------
C  IPC_RECVFROM      Receive UDP packet
C     Rlen returns actual length of packet read
C     ADR has PORT and IP of sender
C     Returns IPC error code
C     NOWAITIO has no effect
C-----------------------------------------------------------------------
      INTEGER FUNCTION IPC_RECVFROM (SOCK,CBUF,RLEN,ADR)
C
$INCLUDE "IPCCOMF"
C
      INTEGER*4   SOCK
      INTEGER     RLEN
      CHARACTER   CBUF*(*)
      RECORD /IPC_ADR/  ADR
C
      INTEGER*4   ERR
      SYSTEM INTRINSIC  IPCRECVFROM
C
C  PORT is actually a 16 bit unsigned number (1-65535)
C  Fortran does not supprt unisgned, so the ADR structure gives the
C  user a INTEGER*4 for port. Here we change the high INTEGER*2 to
C  the required family value, make the call, then return the high
C  INTEGER*2 to a zero.
C
      RLEN = IPCRECVFROM (SOCK,CBUF,SIZEOF(CBUF),,ADR.FAMILY,
     *   SIZEOF(ADR),ERR)
      ADR.FAMILY = 0
      IPC_RECVFROM = ERR
      RETURN
      END
C-----------------------------------------------------------------------
C  IPC_ACCEPT     Accept incomming TCP request
C     Accept connection on call socket CSOCK returning user socket SOCK.
C     ADR returns connector's PORT and IP
C     DEFER, if TRUE, will defer connection SOCK until you either
C     accept, reject with function IPC_SOCKOPT or close.
C     A rejected SOCK is closed for you.
C     You may set a timeout with IPC_SOCKOPT previous to this function.
C     Returns IPC error code
C     NOWAITIO will affect this call -- needs changes
C-----------------------------------------------------------------------
      INTEGER FUNCTION IPC_ACCEPT (SOCK,CSOCK,ADR,DEFER)
C
$INCLUDE "IPCCOMF"
C
      INTEGER*4   SOCK,CSOCK
      LOGICAL     DEFER
      RECORD /IPC_ADR/  ADR
C
      INTEGER*4   ERR, FLAGS
      INTEGER*2   IERR, IX, OPTS (10), CODE, CLEN
      STRUCTURE /IPC_ADR0/
         INTEGER*2   IPORT
         CHARACTER   IP*4
         INTEGER*2   Z
      END STRUCTURE
      RECORD /IPC_ADR0/ ADR0
      SYSTEM INTRINSIC  IPCRECVCN, INITOPT, ADDOPT, READOPT
C
      FLAGS = 0
      IF (DEFER) FLAGS = 8192
C
      CALL INITOPT (OPTS,1,IERR)
      ERR = IERR
      IF (ERR.NE.0) GOTO 999
C
      CALL ADDOPT (OPTS,0,141,SIZEOF(ADR),ADR.FAMILY,IERR)
      ERR = IERR
      IF (ERR.NE.0) GOTO 999
C
      CALL IPCRECVCN (CSOCK,SOCK,FLAGS,OPTS,ERR)
      IF (ERR.NE.0) GOTO 999
C
      CLEN = SIZEOF(ADR0)
      CALL READOPT (OPTS,0,CODE,CLEN,ADR0.IPORT,IERR)
      ERR = IERR
      IF (ERR.NE.0) GOTO 999
      ADR.IP = ADR0.IP
      ADR.IPORT = ADR0.IPORT
      ADR.FAMILY = 0
C
 999  CONTINUE
      IPC_ACCEPT = ERR
      RETURN
      END
C-----------------------------------------------------------------------
C  IPC_SEND    Send TCP packet
C     Send data buffer CBUF of length CLEN
C     Returns IPC error code
C     NOWAITIO may affect this call -- needs testing
C-----------------------------------------------------------------------
      INTEGER FUNCTION IPC_SEND (SOCK,CBUF,CLEN)
C
      INTEGER*4   SOCK
      INTEGER     CLEN
      CHARACTER   CBUF*(*)
C
      INTEGER*4   ERR, DLEN
      SYSTEM INTRINSIC  IPCSEND
C
      DLEN = CLEN
      CALL IPCSEND (SOCK,CBUF,DLEN,,,ERR)
      IPC_SEND = ERR
      RETURN
      END
C-----------------------------------------------------------------------
C  IPC_RECV    Receive TCP packet
C     Recv data buffer CBUF of length SIZEOF (CBUF)
C     RLEN returns actual data length
C     If PREVIEW is TRUE, return data without removing it from buffer
C     so that the next recv will re-read it.
C     Returns IPC error code
C     NOWAITIO may affect this call -- needs testing
C        When IOWAIT,IODONTWAIT are called, data is returned in this
C        CBUF parameter, not the target of IOWAIT,IODONTWAIT.
C        Length is returned in TargetLength of IOWAIT,IODONTWAIT
C-----------------------------------------------------------------------
      INTEGER FUNCTION IPC_RECV (SOCK,CBUF,RLEN,PREVIEW)
C
      INTEGER*4   SOCK
      INTEGER     RLEN
      LOGICAL     PREVIEW
      CHARACTER   CBUF*(*)
C
      INTEGER*4   ERR, DLEN, FLAGS
      SYSTEM INTRINSIC  IPCRECV
C
C  Set flags to no output (32768) incase user is doing NOWAIT io
C
      FLAGS = 32768
      IF (PREVIEW) FLAGS = FLAGS + 2
      DLEN = SIZEOF (CBUF)
      CALL IPCRECV (SOCK,CBUF,DLEN,FLAGS,,ERR)
      RLEN = DLEN
      IPC_RECV = ERR
      RETURN
      END
C-----------------------------------------------------------------------
C  IPC_CONN       Make a TCP connection to another host
C     Make a TCP connection to either HOST name and TOPORT
C     (if HOST length > 0 and 1st char is > blank) or IP,PORT of ADR.
C     Return the connected socket in SOCK
C     If FROMPORT is non-zero, use this as the local port.
C     TSEC is tenth-seconds timeout to make the connection.
C     If TSEC is zero, the use system default of 60 seconds.
C     Returns IPC error code
C     NOWAITIO may affect this call -- needs testing
C-----------------------------------------------------------------------
      INTEGER FUNCTION IPC_CONNECT (SOCK,ADR,HOST,TOPORT,FROMPORT,TSEC)
C
$INCLUDE "IPCCOMF"
C
      INTEGER*4   SOCK
      INTEGER     FROMPORT, TOPORT, TSEC
      CHARACTER   HOST*(*)
      RECORD /IPC_ADR/  ADR
C
      INTEGER*4   ERR, DEST, ERR1
      INTEGER*2   OPTS(9), IERR
      STRUCTURE /IPC_ADR1/
         INTEGER*2   PROTOCOL
         CHARACTER   IP*4
      END STRUCTURE
      RECORD /IPC_ADR1/ ADR1
      SYSTEM INTRINSIC  IPCCONNECT,IPCSHUTDOWN,IPCDEST,IPCRECV,
     *   INITOPT,ADDOPT
C
C  We need a DESTination socket; one defining the TO address
C
      DEST = 0
      IF (SIZEOF(HOST).GT.0 .AND. HOST (1:1).GT." ") THEN
         ADR.PORT = TOPORT
         CALL IPCDEST (3,HOST,SIZEOF(HOST),4,ADR.IPORT,
     *      SIZEOF(ADR.IPORT),,,DEST,ERR)
      ELSE
         CALL INITOPT (OPTS,1,IERR)
         ERR = IERR
         IF (ERR.NE.0) GOTO 999
         ADR1.PROTOCOL = 8
         ADR1.IP = ADR.IP
         CALL ADDOPT (OPTS,0,16,SIZEOF(ADR1),ADR1.PROTOCOL,IERR)
         ERR = IERR
         IF (ERR.NE.0) GOTO 999
         CALL IPCDEST (3,,,4,ADR.IPORT,SIZEOF(ADR.IPORT),,OPTS,
     *      DEST,ERR)
      ENDIF
      IF (ERR.NE.0) GOTO 999
C
C  Now we start connection, optionally setting our local port number
C
      IPORT = 0
      IF (FROMPORT.NE.0) IPORT = 1
      CALL INITOPT (OPTS,IPORT,IERR)
      ERR = IERR
      IF (ERR.NE.0) GOTO 999
C
      IF (FROMPORT.NE.0) THEN
         ADR.PORT = FROMPORT
         CALL ADDOPT (OPTS,0,128,SIZEOF(ADR.IPORT),ADR.IPORT,IERR)
         ERR = IERR
         IF (ERR.NE.0) GOTO 999
      END IF
C
      CALL IPCCONNECT (-1,DEST,,OPTS,SOCK,ERR)
      IF (ERR.NE.0) GOTO 999
C
C  Complete connection
C
      IF (TSEC.GT.0) THEN
         ERR = IPC_SOCKOPT (SOCK,IPC_OPT_TIMEOUT,TSEC)
         IF (ERR.NE.0) GOTO 999
      ENDIF
      CALL IPCRECV (SOCK,,,,,ERR)
      IF (ERR.NE.0) THEN
         CALL IPCSHUTDOWN (SOCK,,,ERR1)
         SOCK = 0
      ELSE
         ERR = IPC_SOCKOPT (SOCK,IPC_OPT_TIMEOUT,0)
      ENDIF
C
 999  CONTINUE
      IPC_CONNECT = ERR
      IF (DEST.NE.0) CALL IPCSHUTDOWN (DEST,,,ERR1)
      RETURN
      END
C-----------------------------------------------------------------------
C  IPC_SOCKOPT    Set socket options; timeout, nowaitIO, accept/reject
C     Valid modes are defined in IPCCOMF as IPC_OPT_xxxx
C     Only TIMEOUT uses IVAL as the tenths of seconds to timeout on
C     Returns IPC error code
C     NOWAITIO has no effect
C-----------------------------------------------------------------------
      INTEGER FUNCTION IPC_SOCKOPT (SOCK,MODE,IVAL)
C
$INCLUDE "IPCCOMF"
C
      INTEGER*4   SOCK
      INTEGER     MODE, IVAL
C
      INTEGER*4   ERR, REQ
      INTEGER*2   TENTHSEC
      SYSTEM INTRINSIC  IPCCONTROL
C
      REQ = MODE
      IF (REQ.EQ.IPC_OPT_TIMEOUT) THEN
         TENTHSEC = IVAL
         CALL IPCCONTROL (SOCK,REQ,TENTHSEC,SIZEOF(TENTHSEC),,,,ERR)
      ELSE
         CALL IPCCONTROL (SOCK,REQ,,,,,,ERR)
      ENDIF
C
      IPC_SOCKOPT = ERR
      RETURN
      END
C-----------------------------------------------------------------------
C  IPCSOCK END
C-----------------------------------------------------------------------