      PROGRAM KERMIT
           IMPLICIT NONE
C
C= File transfer program using kermit protocol
C
C
C                  REVISION LIST
C
C     1.0  This Kermit was the direct implemention of the Cyber-170
C          version, University of Texas.  L. Tate, SAI, Sept. 1985.
C
C     2.0  Added the CONNECT, GET, FINISH, BYE commands.  This required
C          significant changes to the io interface.  The local on/off
C          option was also part of this.  L. Tate, SAI, Nov. 1985.
C
C     2.1  Correct bug in SUDT.  When use the SVC 1,X'27' which
C          set full duplex on a terminal it previously used a trashed
C          file control block.  This had caused unpredicatable results
C          in alot of the io including 2 reads pending at once.
C          Correcting this problem allowed removal of HIOALL routine.
C          Files to be read are opened with OPENMODE='R' and files to
C          be written are opened with OPENMODE='U'.  Also added the
C          TAKE command.   L. Tate, SAI, Mar. 1986.
C
C     2.2  Improved receive/get reliablity by moving the terminal
C          reporting to before the ACK/NAK is sent.  The problem seems
C          to have been during the reporting time, the sending flooded
C          the 8-line buffer and caused a break, losing data.  Also
C          corrected error in printl routine which wrote to stdout
C          instead of the parameter fd. L. Tate, SAI, Mar. 1986.
C
C     2.3  Added to SERVER the ability to recognize the I packet.
C          This packet is used by advanced Kermits (2.27 at least)
C          to initialize the Server.
C          Changed the method by which nowait is established so that
C          if ECHO was off for the terminal before kermit operation,
C          it will remain so afterwards.  Good for network operation.
C          Corrected the error reporting code such that now the error
C          messages are produced.  However, they can be very cryptic.
C          What is needed is a general method of handling text, like
C          help messages and error messages, such that memory is not
C          filled but ready access is available.
C          L. TATE, SAI, MAY 1986.
C
C     AS IN TO LFC=UT
C     AS OUT TO LFC=UT
C
C
C
      INCLUDE      'KVER.INS'
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KMSG.COM'
      INCLUDE      'KDBUG.COM'
C
      INTEGER      NCMD            ;PARAMETER (NCMD=15)
      CHARACTER*10 CMD(NCMD)       !commands
     $   /'BYE', 'CONNECT','EXIT','FINISH','GET','HELP',
     $    'QUIT','RECEIVE','SEND','SERVER',
     $    'SET', 'SHOW', 'STATUS','TAKE', 'X'/
      INTEGER      NNOLOCAL        ;PARAMETER (NNOLOCAL =  3)
      CHARACTER*63 NOLOCAL (NNOLOCAL)
     $/'This KERMIT does not support the following commands; BYE,',
     $ 'CONNECT, FINISH, and GET.  These commands require KERMIT',
     $ 'to be installed on MPX3.2B or greater.'/
      INTEGER      IDX             !current command
      CHARACTER*80 CMDLIN          !command line that started program
      INTEGER      IOS
C
      INTEGER      MATCH           !get and match command
      INTEGER      OPEN
C
      CALL SLINE(CMDLIN)           !get startup command line
      CALL INIT(CMDLIN)            !pass to initialize
C
      IOS = OPEN('STDIN','R')
      IF (IOS .NE. STDIN) THEN
        CALL PRTMSG(' Cannot open standard input', -IOS)
        STOP
      ENDIF
      IOS = OPEN('STDOUT','W')
      IF (IOS .NE. STDOUT) THEN
        CALL PRTMSG(' Cannot open standard output',-IOS)
        STOP
      ENDIF
C
C initializing program
C
      INPUTFD = OPEN('KERMIT.INI', 'R')
      IF (INPUTFD .LE. 0) INPUTFD = STDIN
C
      CALL PRINTL(STDOUT, VERSION)
      DO, BEGIN
        IF (INPUTFD .EQ. STDIN) THEN
          CALL PUTSTR(STDOUT, PROMPT)
          CALL FLUSH(STDOUT)
        ENDIF
        CALL FLUSH(INPUTFD)
        IDX = MATCH(CMD, NCMD, .TRUE.)
        IF (IDX .EQ. ERROR .OR. IDX .EQ. 0) GOTO 200
        IF (IDX .EQ. EOF) THEN
          IF (INPUTFD .NE. STDIN) THEN
            CALL TAKEDONE
            GOTO 200
          ELSE
            CALL EXITPGM
          ENDIF
        ENDIF
        GOTO (130, 40, 50, 140, 20, 90, 50, 30, 10, 80, 100,
     $        110, 120, 60, 50) IDX
C
 10     CONTINUE                   !send
          CALL SNDFILE
          GOTO 200
 20     CONTINUE                   !get
          IF (.NOT. LOCALON) GOTO 190
          CALL GETFROM
          GOTO 200
 30     CONTINUE                   !receive
          CALL RCVFILE
          GOTO 200
 40     CONTINUE                   !connect
          IF (.NOT. LOCALON) GOTO 190
          CALL CONNECT
          GOTO 200
 50     CONTINUE                   !exit
          CALL EXITPGM
 60     CONTINUE                   !take
          CALL TAKE
          GOTO 200
 80     CONTINUE                   !server
          CALL SERVER
          GOTO 200
 90     CONTINUE                   !help
          CALL HELP
          GOTO 200
 100    CONTINUE                   !set
          CALL SET
          GOTO 200
 110    CONTINUE                   !show
          CALL SHOW
          GOTO 200
 120    CONTINUE                   !status
          CALL STATUS
          GOTO 200
 130    CONTINUE                   !bye
          IF (.NOT. LOCALON) GOTO 190
          CALL BYE
          GOTO 200
 140    CONTINUE                   !finish
          IF (.NOT. LOCALON) GOTO 190
          CALL FINISH
          GOTO 200
 190    CONTINUE                   !no local
          CALL OUTTBL(NOLOCAL, 1, NNOLOCAL)
          GOTO 200
 200    CONTINUE
      ENDDO
      END
      SUBROUTINE INIT(COMLIN)
           IMPLICIT NONE
           CHARACTER*80  COMLIN    !command line of program
C
C= initializes all kermit context
C
      INCLUDE      'KVER.INS'
      INCLUDE      'KDEF.INS'
      INCLUDE      'KDBUG.COM'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KPACK.COM'
      INCLUDE      'KMSG.COM'
C
      INTEGER      I               !index
      CHARACTER*2  MACH            !machine type code
C
      INTEGER      LASTCHR         !last non blank character
      INTEGER      ICHAR           !character to int
      INTEGER      MATCH
      INTEGER      OPEN
C
C dbugcom
C
      CALL M_UPRIV
      CALL BREAKR
C
      DEBUG = .FALSE.              !no debug on
      DBGFD = 0                    !standoutput
      DBGFILE = 'L.KERMLOG'        !standoutput
C
C protcom
C
      PACKET = 0
      RECPACK = 0
      FILESTR = 0
      PSIZE = 0
      PACKNUM = 0
      NUMTRY = 0
      MAXRTRY = MAXTRY
      MAXRINI = MAXINIT
      STATE = C
      IFD = STDIN
      OFD = STDOUT
      COMPORT = 'UT'
      FFD = 0
      DELAYFP =  0
      STARTIM = 0
      ENDTIM = 0
      SCHCNT = 0
      RCHCNT = 0
      SCHOVRH = 0
      RCHOVRH = 0
      ECHO = .FALSE.
      ESCCHR = 29                  ! CONTROL-]
      LOG = .FALSE.
      LFD = 0
      LOGFILE = 'L.SESSION'
      INSTACK = 0                  !initialize stack pointer
      INSTKFD = 0                  !zero stack for good measure
C
C packcom
C
      SYNC = SNDSYNC = SOH
      PACKSIZ = SPKSIZ = MAXPACK
      TIMEOUT = STIMOUT = MYTIME
      NPAD = SPAD = MYPAD
      PADCH = SPADCH = MYPADCH
      EOLCH = SPEOL = MYEOL
      QUOTECH = SPQUOTE = MYQUOTE
      QUOTE8 = S8QUOTE = QUOT8CH
      CHKTYP = SCHKTYP = MYCKTYP
      RESERVE  = UNUSED = 0
      RPREFIX = SREPEAT = PREFXCH
C
C msgcom
C
      IF (LOCALON) THEN
        VERSION = 'Gould KERMIT version 2.3, Local/Remote enabled'
      ELSE
        VERSION = 'Gould KERMIT version 2.3, Local/Remote disabled'
      ENDIF
      CALL GETMACH(MACH)
      PROMPT(1) = NEL
      CALL DPC2AS('kermit-'//MACH//'>', PROMPT(2), 19)
      I = LASTCHR(COMLIN)
      IF (I .GT. 18  ) I = 18
      IF (I .GT. 0) CALL DPC2AS(COMLIN(:I)//'>', PROMPT(2), I+1)
CLT 2.3  FIXED THE LOGIC FOR LNAME
      I = 2
      LNAME = 0
      DO WHILE (PROMPT(I) .NE. ICHAR('>') .AND. I .LT. 21)
        LNAME = LNAME + 1
        NAME(LNAME) = PROMPT(I)
        I = I + 1
      ENDDO
C
      CALL BREAKR
      CALL X:SYNCH
C
      RETURN
      END
      SUBROUTINE EXITPGM
           IMPLICIT NONE
C
C= Exit kermit
C
      INTEGER      I               !index
C
      DO I=1, 10
        CALL CLOSE(I)
      ENDDO
      STOP
      END
      SUBROUTINE RCVFILE
           IMPLICIT NONE
C
C= Top level subroutine to start receive state.
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KPACK.COM'
C
      INTEGER      RECEIVE         !receive file
      INTEGER      GTTY            !get tty status
      LOGICAL      CONFIRM         !confirm input
C
      IF (.NOT. CONFIRM(INPUTFD)) RETURN
C
C receive file
C
      CALL STTY(IFD, 'BINARY', ON)
      CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
      CALL STTY(IFD, 'NOWAIT', ON)
      IF (INPUTFD .NE. STDIN .AND. OFD .NE. STDOUT) THEN
        CALL PRINTL(STDOUT, 'Receiving file ')
        CALL PUTSTR(STDOUT, FILESTR)
        CALL FLUSH(STDOUT)
      ENDIF
      IF (RECEIVE(R) .EQ. OK) THEN
        CALL PRINTL(STDOUT, 'Receive complete.')
      ELSE
        CALL PRINTL(STDOUT, 'Received failed.')
      ENDIF
      CALL STTY(IFD, 'NOWAIT', OFF)
      CALL STTY(IFD, 'TIMEOUT', 0)
      CALL STTY(IFD, 'BINARY', OFF)
      RETURN
      END
      SUBROUTINE SNDFILE
           IMPLICIT NONE
C
C= Sends a file to other kermit
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KPACK.COM'
C
      CHARACTER*16 FNAME           !name of file to send
      INTEGER      IRET            !return status
C
      LOGICAL      ISFILE
      INTEGER      SEND
C
C pick up file name and save it for opening later
C
      CALL SETVAL(FILESTR, 'S', IRET, 16, 0, 0,
     $  'Filename to send', .TRUE.)
      IF (IRET .EQ. ERROR) RETURN
C
C check to make sure it's there to send
C
      CALL AS2DPC(FILESTR, FNAME)
      IF (.NOT. ISFILE(FNAME)) THEN
        CALL PRINTL(STDOUT, '?File ')
        CALL PUTSTR(STDOUT, FILESTR)
        CALL PRINT(STDOUT,' is not found.')
        CALL PUTC(STDOUT, NEL)
        RETURN
      ENDIF
C
      CALL STTY(IFD, 'BINARY', ON)
      CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
      CALL STTY(IFD, 'NOWAIT', ON)
C
C delay the first packet
C
      IF (DELAYFP .GT. 0) CALL SLEEP(DELAYFP)
C
C start sending packet
C
      IF (INPUTFD .NE. STDIN .AND. OFD .NE. STDOUT) THEN
        CALL PRINTL(STDOUT, 'Sending file ')
        CALL PUTSTR(STDOUT, FILESTR)
        CALL FLUSH(STDOUT)
      ENDIF
      PACKNUM = 0
      IF (SEND() .EQ. OK) THEN
        CALL PRINTL(STDOUT, 'Send complete.')
      ELSE
        CALL PRINTL(STDOUT, 'Send failed.')
      ENDIF
      CALL STTY(IFD, 'NOWAIT', OFF)
      CALL STTY(IFD, 'TIMEOUT', 0)
      CALL STTY(IFD, 'BINARY', OFF)
      RETURN
      END
      SUBROUTINE SERVER
           IMPLICIT NONE
C
C= Start kermit server routine
C
C     The server currently knows about the send and receive packets
C     and also the generic kermit packets logout and finish.
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KDBUG.COM'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KPACK.COM'
C
      INTEGER      PTYP
      INTEGER      I
      INTEGER      NUM             !packet number
      INTEGER      RECSTAT         !receive status
      INTEGER      SNDSTAT         !send status
      CHARACTER*72 SRVMES (4 )
     $ /'[Kermit server running on Gould host.  Please type your',
     $  'escape sequence to return to your local machine.  Shut',
     $  'down server by typing the Kermit BYE command on your',
     $  'local machine.]'/
      CHARACTER*56    FILENAME
C
      LOGICAL CONFIRM
      INTEGER      RDPACK          !read a packet
      INTEGER      SNDPAR          !build init packet
      INTEGER      GTTY            !get terminal stuff
      INTEGER      RECEIVE         !receive file
      INTEGER      SEND            !send file
      INTEGER      LASTCHR         !last non-blank character
      INTEGER      MAX
      INTEGER      SLEN            !string length
      LOGICAL*1    ISFILE          !does file exist
C
      IF (.NOT. CONFIRM(INPUTFD)) RETURN
C
C initialize msg #, say no tries yet
C
      PACKNUM = 0
      NUMTRY = 0
      CALL OUTTBL(SRVMES, 1, 4)
C
      CALL STTY(IFD, 'BINARY', ON)
      CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
      CALL STTY(IFD, 'NOWAIT', ON)
C
 10   CONTINUE
      PTYP = RDPACK(LEN, NUM, RECPACK)
      IF (PTYP .EQ. S) THEN
        PACKNUM = NUM
        CALL RDPARAM(RECPACK)
        I = SNDPAR(PACKET)
        CALL SNDPACK(Y, PACKNUM, I, PACKET)
        NUMTRY = 0
        PACKNUM = MOD(PACKNUM+1, 64)
        RECSTAT = RECEIVE(F)
        IF (DEBUG(DBGON)) THEN
          IF (RECSTAT .EQ. ERROR) THEN
            CALL PRINTL(DBGFD, 'Receive failed.')
          ELSE
            CALL PRINTL(DBGFD, 'Receive completed.')
          ENDIF
        ENDIF
      ELSE IF (PTYP .EQ. R) THEN
        I = 0
        CALL STRCPY(RECPACK, FILESTR)
        CALL AS2DPC(FILESTR, FILENAME)
        CALL FILCHK(FILENAME)
C
CLT 2.3 5/12/86 CHECK TO SEE IF FILE EXISTS
C
        IF (ISFILE(FILENAME)) THEN
          CALL DPC2AS(FILENAME, FILESTR, MAX(1,LASTCHR(FILENAME)))
          SNDSTAT = SEND()
          PACKNUM = 0
          IF (DEBUG(DBGON)) THEN
            IF (SNDSTAT .EQ. ERROR) THEN
              CALL PRINTL(DBGFD, 'Send failed.')
            ELSE
              CALL PRINTL(DBGFD, 'Send completed.')
            ENDIF
          ENDIF
CLT 2.3 5/12/86 SEND ERROR PACKET IF NOT FOUND
        ELSE
          CALL DPC2AS('? FILE ', PACKET, 7)
          I = LASTCHR(FILENAME)
          CALL DPC2AS(FILENAME, PACKET(8), I)
          CALL DPC2AS(' NOT FOUND', PACKET(I+8), 10)
          CALL SNDPACK(E, PACKNUM, SLEN(PACKET), PACKET)
        ENDIF
      ELSE IF (PTYP .EQ. G) THEN
        IF (RECPACK(1) .EQ. L) THEN
          CALL SNDPACK(Y, NUM, 0, 0)
          CALL STTY(IFD, 'NOWAIT', OFF)
          CALL STTY(IFD, 'TIMEOUT', 0)
          CALL STTY(IFD, 'BINARY', OFF)
          CALL EXITPGM   !LOGOUT
        ELSE IF (RECPACK(1) .EQ. F) THEN
          CALL SNDPACK(Y, NUM, 0, 0)
          CALL STTY(IFD, 'NOWAIT', OFF)
          CALL STTY(IFD, 'TIMEOUT', 0)
          CALL STTY(IFD, 'BINARY', OFF)
          CALL EXITPGM
C
CLT 2.3 5/12/86 SEND ERROR MESSAGE FOR UNSUPPORTED COMMAND
C
        ELSE
          CALL DPC2AS('? UNSUPPORTED SERVER COMMAND', PACKET, 28)
          CALL SNDPACK(E, PACKNUM, SLEN(PACKET), PACKET)
        ENDIF
C
CLT 2.3 5/8/86 RECEIVE SERVER INIT PACKET
C
      ELSE IF (PTYP .EQ. ITYP) THEN
        PACKNUM = NUM
        CALL RDPARAM(RECPACK)
        I = SNDPAR(PACKET)
        CALL SNDPACK(Y, PACKNUM, I, PACKET)
C
CLT END
C
      ELSE
CLT 2.3 5/12/86 Added error message for unrecognized packet
        CALL DPC2AS('? UNRECOGNIZED SERVER PACKET',PACKET,28)
        CALL SNDPACK(E,PACKNUM, SLEN(PACKET), PACKET)
        IF (DEBUG(DBGON)) THEN
          CALL PRINTL(DBGFD, 'server: invalid packet type: ')
          CALL PUTINT(DBGFD, PTYP, 1)
          CALL FLUSH(DBGFD)
        ENDIF
      ENDIF
      GOTO 10
      END
      SUBROUTINE SET
           IMPLICIT NONE
C
C= Set some attributes.
C
      INCLUDE      'KVER.INS'
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KPACK.COM'
C
      INTEGER      TSIZE           !set commands
        PARAMETER (TSIZE = 10)
      CHARACTER*10 SETTYP(TSIZE)
     $ /'DEBUG','DELAY','ECHO', 'ESCAPE',
     $          'INIT-RETRY','LOG','PORT','RECEIVE','RETRY','SEND'/
      INTEGER      NNOLOCAL        ;PARAMETER (NNOLOCAL = 3 )
      CHARACTER*63 NOLOCAL (NNOLOCAL)
     $/'This KERMIT does not support the following SET commands;',
     $ 'PORT and LOG.  These commands require KERMIT to be installed',
     $ 'on MPX3.2B or greater.'/
      INTEGER      INDX
      INTEGER      ESIZE           ;PARAMETER (ESIZE = 2)
        CHARACTER*3 ECHOTYP(ESIZE) /'OFF','ON'/
      CHARACTER*63 HLPASCH/
     $'Decimal, octal (O), or hexidecimal (H) code for ASCII character'
     $/
C
      INTEGER      MATCH
C
      INDX = MATCH (SETTYP, TSIZE, .FALSE.)
      IF (INDX .LE. 0) RETURN
      GOTO (10, 20, 23, 27, 30, 80, 70, 40, 50, 60) INDX
C
C set debugging modes
C
 10   CONTINUE                     !debug
      CALL DBUGCMD
      RETURN
C
 20   CONTINUE                     !set first packet delay
      CALL SETVAL(DELAYFP,'I',0,60,0,60,
     $ 'Number of seconds to delay first packet', .TRUE.)
      RETURN
C
 23   CONTINUE                     !set echo on/off
      INDX = MATCH(ECHOTYP, ESIZE, .TRUE.)
      IF (INDX .LE. 0) RETURN
      ECHO = INDX .EQ. 2
      RETURN
C
 27   CONTINUE                     !escape
      CALL SETVAL(ESCCHR, 'I', 0, 31, 0, 31, HLPASCH, .TRUE.)
      RETURN
C
 30   CONTINUE                     ! set initial packet retry count
      CALL SETVAL(MAXRINI,'I',1,50,1,50,
     $   'Initial packet retry count', .TRUE.)
      RETURN
C
 40   CONTINUE                     !set receive packet attributes
      CALL SETPACK(PACKSIZ)
      RETURN
C
 50   CONTINUE                     !set packet retry count
      CALL SETVAL(MAXRTRY, 'I',1,50,1,50,
     $  'Packet retry count', .TRUE.)
      RETURN
C
 60   CONTINUE                     !set send packet attributes
      CALL SETPACK(SPKSIZ)
      RETURN
C
 70   CONTINUE                     !set port
      IF (.NOT. LOCALON) GOTO 90
      CALL PORTCMD
      RETURN
C
 80   CONTINUE                     !set log
      IF (.NOT. LOCALON) GOTO 90
      CALL LOGGER
      RETURN
C
 90   CONTINUE                     !no local
      CALL OUTTBL(NOLOCAL, 1, NNOLOCAL)
      RETURN
      END
      SUBROUTINE SHOW
           IMPLICIT NONE
C
C= Show the current program settings
C
      INCLUDE      'KVER.INS'
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KPACK.COM'
      INCLUDE      'KDBUG.COM'
      INCLUDE      'KMSG.COM'
C
      INTEGER      MM,DD,YY,HR,MIN,SEC
C
      INTEGER      CTL
      LOGICAL      CONFIRM
C
      IF (.NOT. CONFIRM(INPUTFD)) RETURN
      CALL PRINTL(STDOUT, VERSION)
C
C display current date and time
C
      CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
      CALL PUTC(STDOUT, NEL)
      CALL PUTDAY(STDOUT, MM, DD, YY)
      CALL PRINT(STDOUT,', ')
      CALL PUTMNTH(STDOUT,MM)
      CALL PUTC(STDOUT,' ')
      CALL PUTINT(STDOUT,DD, 1)
      CALL PRINT(STDOUT,', ')
      CALL PUTINT(STDOUT,YY, 1)
      CALL PUTC(STDOUT,' ')
      IF (HR .LT. 10) CALL PRINT(STDOUT,'0')
      CALL PUTINT(STDOUT,HR,1)
      CALL PUTC(STDOUT,':')
      IF (MIN .LT. 10) CALL PRINT(STDOUT,'0')
      CALL PUTINT(STDOUT,MIN,1)
      CALL PUTC(STDOUT,':')
      IF (SEC .LT. 10) CALL PRINT(STDOUT,'0')
      CALL PUTINT(STDOUT,SEC,1)
C
C display current debug modes
C
      CALL PRINTL(STDOUT,'Debugging: ')
      IF (DEBUG(DBGSTAT)) CALL PRINT(STDOUT,'States ')
      IF (DEBUG(DBGPACK)) CALL PRINT(STDOUT,'Packets ')
      IF (.NOT. DEBUG(DBGON)) CALL PRINT(STDOUT,'Off ')
      IF (DEBUG(DBGON)) THEN
        CALL PRINT(STDOUT,'  Debug log file: '//DBGFILE)
      ENDIF
C
C session log
C
      IF (LOCALON) THEN
        CALL PRINTL(STDOUT, 'Session log: ')
        IF (LOG) THEN
          CALL PRINT(STDOUT, 'ON')
        ELSE
          CALL PRINT(STDOUT, 'OFF')
        ENDIF
        IF (LOGFILE .NE. ' ') THEN
          CALL PRINT( STDOUT, '  Session log file: ')
          CALL PRINT(STDOUT, LOGFILE)
        ENDIF
      ENDIF
C
C display current port
C
      IF (LOCALON) THEN
        CALL PRINTL(STDOUT, 'Selected Communications port: ')
        CALL PRINT (STDOUT, COMPORT)
        CALL PRINTL(STDOUT, 'Connection escape character: ^')
        CALL PUTC(STDOUT, CTL(ESCCHR))
        CALL PRINTL(STDOUT, 'Local echo: ')
        IF (ECHO) THEN
          CALL PRINT(STDOUT, 'ON')
        ELSE
          CALL PRINT(STDOUT, 'OFF')
        ENDIF
      ENDIF
C
C display packet settings
C
      CALL PRINTL(STDOUT,'Packet Parameters')
      CALL PRINTL(STDOUT,
     $   '                    Receive   Send')
      CALL PRINTL(STDOUT,'  Size:             ')
      CALL PUTINT(STDOUT,PACKSIZ,10)
      CALL PUTINT(STDOUT,SPKSIZ,10)
      CALL PRINTL(STDOUT,'  Timeout:          ')
      CALL PUTINT(STDOUT,TIMEOUT,10)
      CALL PUTINT(STDOUT,STIMOUT,10)
      CALL PRINTL(STDOUT,'  Padding:          ')
      CALL PUTINT(STDOUT,NPAD,10)
      CALL PUTINT(STDOUT,SPAD,10)
      CALL PRINTL(STDOUT,'  Pad character:    ')
      CALL PUTC(STDOUT,'^')
      CALL PUTC(STDOUT,CTL(PADCH))
      CALL PRINT(STDOUT,'        ')
      CALL PUTC(STDOUT,'^')
      CALL PUTC(STDOUT,CTL(SPADCH))
      CALL PRINTL(STDOUT,'  End-of-Line:      ')
      CALL PUTC(STDOUT,'^')
      CALL PUTC(STDOUT,CTL(EOLCH))
      CALL PRINT(STDOUT,'        ')
      CALL PUTC(STDOUT,'^')
      CALL PUTC(STDOUT,CTL(SPEOL))
      CALL PRINTL(STDOUT,'  Control quote:    ')
      CALL PUTC(STDOUT,QUOTECH)
      CALL PRINT(STDOUT,'         ')
      CALL PUTC(STDOUT,SPQUOTE)
      CALL PRINTL(STDOUT,'  Start-of-Packet:  ')
      CALL PUTC(STDOUT,'^')
      CALL PUTC(STDOUT,CTL(SYNC))
      CALL PRINT(STDOUT,'        ')
      CALL PUTC(STDOUT,'^')
      CALL PUTC(STDOUT,CTL(SNDSYNC))
C
C display protocol stuff
C
      CALL PRINTL(STDOUT,'Delay before sending first packet: ')
      CALL PUTINT(STDOUT,DELAYFP,1)
      CALL PRINTL(STDOUT,'Init packet retry count: ')
      CALL PUTINT(STDOUT,MAXRINI,1)
      CALL PRINTL(STDOUT,'Packet retry count: ')
      CALL PUTINT(STDOUT,MAXRTRY,1)
      CALL PUTC(STDOUT,NEL)
      RETURN
      END
      SUBROUTINE STATUS
           IMPLICIT NONE
C
C= Tell how long last transfer took.
C
      INCLUDE      'KVER.INS'
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KPACK.COM'
      INCLUDE      'KTIME.COM'
C
      INTEGER      HR,MIN,SEC
      INTEGER      NSEC
C
      LOGICAL      CONFIRM
C
C confirm the command
C
      IF (.NOT. CONFIRM(INPUTFD)) RETURN
C
      CALL PRINTL(STDOUT,'Max characters in packet: ')
      CALL PUTINT(STDOUT, PACKSIZ, 1)
      CALL PRINT(STDOUT,' received; ')
      CALL PUTINT(STDOUT, SPKSIZ, 1)
      CALL PRINT(STDOUT,' sent')
      CALL PUTC(STDOUT,NEL)
      IF (ENDTIM .LT. STARTIM) ENDTIM = ENDTIM + 86400
      NSEC = ENDTIM - STARTIM
      HR = NSEC / 3600
      NSEC = NSEC - (HR * 3600)
      MIN = NSEC / 60
      NSEC = NSEC - (MIN * 60)
      CALL PRINTL(STDOUT,'Number of characters transmitted in ')
      IF (HR .GT. 0) THEN
        CALL PUTINT(STDOUT,HR,1)
        CALL PRINT(STDOUT,' hours ')
      ENDIF
      IF (MIN .GT. 0 .OR. HR .GT. 0) THEN
        CALL PUTINT(STDOUT,MIN,1)
        CALL PRINT(STDOUT,' minutes ')
      ENDIF
      CALL PUTINT(STDOUT,NSEC,1)
      CALL PRINT(STDOUT,' seconds')
      CALL PRINTL(STDOUT,'             Sent:  ')
      CALL PUTINT(STDOUT, SCHCNT, 20)
      CALL PRINT(STDOUT,' Overhead:  ')
      CALL PUTINT(STDOUT, SCHOVRH, 1)
      CALL PRINTL(STDOUT,'         Received:  ')
      CALL PUTINT(STDOUT, RCHCNT, 20)
      CALL PRINT(STDOUT,' Overhead:  ')
      CALL PUTINT(STDOUT, RCHOVRH, 1)
      CALL PRINTL(STDOUT,'Total Transmitted:  ')
      CALL PUTINT(STDOUT, RCHCNT+SCHCNT, 20)
      CALL PRINT(STDOUT,' Overhead:  ')
      CALL PUTINT(STDOUT, RCHOVRH+SCHOVRH, 1)
      CALL PUTC(STDOUT, NEL)
      CALL PRINTL(STDOUT,'Total characters transmitted per sec: ')
      CALL PUTINT(STDOUT,(SCHCNT+RCHCNT)/(ENDTIM-STARTIM),1)
      CALL PRINTL(STDOUT,'Effective data rate: ')
      CALL PUTINT(STDOUT,((SCHCNT+RCHCNT)-(SCHOVRH+RCHOVRH)) /
     $                    (ENDTIM-STARTIM) * 10, 1)
      CALL PRINT(STDOUT,' baud')
      CALL FLUSH(STDOUT)
      IF (STATE .NE. C) THEN
        CALL GETEMSG(PACKET)
        CALL PRINTL(STDOUT,'?Kermit:  ')
        CALL PUTSTR(STDOUT, PACKET)
        CALL FLUSH(STDOUT)
      ENDIF
C
C timing
C
      IF (LOCALON) THEN
        CALL PRINTL(STDOUT, 'Connect timing averages: ')
        CALL PRINT(STDOUT, 'GETC ')
        CALL PUTINT(STDOUT, GETIME/GETCOUNT, 5)
        CALL PRINT(STDOUT, ' PUTC ')
        CALL PUTINT(STDOUT, PUTIME/PUTCOUNT, 5)
        CALL PRINT(STDOUT, ' WAIT ')
        CALL PUTINT(STDOUT, WAITIME/WAITCNT, 5)
        CALL PRINT(STDOUT, ' TOTAL ')
        CALL PUTINT(STDOUT, TOTIME, 5)
      ENDIF
      RETURN
      END
      SUBROUTINE DBUGCMD
           IMPLICIT NONE
C
C= Set the debugging modes.
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KDBUG.COM'
C
      INTEGER      DEBUGFN(17)     !file name
      INTEGER      TSIZE           ;PARAMETER (TSIZE = 5)
      CHARACTER*10 DBGTYP(TSIZE)
     $ /'ALL','LOG-FILE','OFF','PACKETS','STATES'/
      INTEGER      INDX
      INTEGER      IRET
C
      INTEGER      MATCH
      LOGICAL      CONFIRM
      INTEGER      OPEN
C
      INDX = MATCH(DBGTYP, TSIZE, .FALSE.)
      IF (INDX .LE. 0) RETURN
      GOTO (10, 20, 30, 40, 50) INDX
C
 10   CONTINUE                     !set all debug modes
      DEBUG = .TRUE.
      GOTO 100
C
 20   CONTINUE                     !set logfile
      CALL SETVAL(DEBUGFN, 'S', IRET, 16, 0, 0,
     $       'Debug output logfile specification', .TRUE.)
      IF (IRET .EQ. OK) THEN
        CALL AS2DPC(DEBUGFN, DBGFILE)
        IF (DBGFD .NE. 0) THEN
          CALL CLOSE(DBGFD)
          DBGFD = 0
        ENDIF
        GOTO 100
      ENDIF
      RETURN
C
 30   CONTINUE                     !turn off all debugging
        DEBUG = .FALSE.
        RETURN
C
 40   CONTINUE                     !toggle debug packets
        IF (.NOT. CONFIRM(INPUTFD))RETURN
        DEBUG(DBGPACK) = .NOT. DEBUG(DBGPACK)
        DEBUG(DBGON) = DEBUG(DBGPACK) .OR. DEBUG(DBGSTAT)
        GOTO 100
C
 50   CONTINUE                     !toggle debug states
        IF (.NOT. CONFIRM(INPUTFD)) RETURN
        DEBUG(DBGSTAT) = .NOT. DEBUG(DBGSTAT)
        DEBUG(DBGON) = DEBUG(DBGPACK) .OR. DEBUG(DBGSTAT)
        GOTO 100
C
 100  CONTINUE                     !open the debug file in not done
        IF (DBGFD .EQ. 0) THEN
          DBGFD = OPEN(DBGFILE, 'W')
        ENDIF
      RETURN
      END
      SUBROUTINE SETPACK(ATTR)
           IMPLICIT NONE
           INTEGER  ATTR(12)       !attributes
C
C= Set packet send or receive attributes.
C
C  Setpack will wet the attributes of the passed attribute list.
C  This subroutine will set the appropriate packet parameter.
C  The parameter to set is passed in an array and is very order
C  dependent.  See common block /packet/ for the ordering.
C  Note that send and receive parameter ordering and storage
C  size in the common block are identical.  Keep it that way!
C
      INCLUDE      'KDEF.INS'
C
      INTEGER      TSIZE           ;PARAMETER (TSIZE=7)
      CHARACTER*10 ATTRTYP(TSIZE)  !commands
     $ /'EOL','PACKLEN','PADCHR','PADLEN','QUOTECHR',
     $  'SYNCCHR','TIMEOUT'/
      INTEGER      INDX
      CHARACTER*63 HLPASCH/
     $'Decimal, octal (O), or hexidecimal (H) code for ASCII character'
     $/
C
      INTEGER      MATCH
      LOGICAL      CONFIRM
C
      INDX = MATCH(ATTRTYP, TSIZE, .FALSE.)
      IF (INDX .LE. 0) RETURN
      GOTO (10, 20, 30, 40, 50, 60, 70) INDX
C
 10   CONTINUE                     !set eol character
      CALL SETVAL(ATTR(5), 'I',1,31,127,127,HLPASCH,.TRUE.)
      RETURN
C
 20   CONTINUE                     !set maximum packet length
      CALL SETVAL(ATTR(1), 'I',20,94,20,94,
     $ 'Maximum packet length', .TRUE.)
      RETURN
C
 30   CONTINUE                     !set pad character
      CALL SETVAL(ATTR(4), 'I', 0, 31, 127, 127, HLPASCH, .TRUE.)
      RETURN
C
 40   CONTINUE                     !set pad length
      CALL SETVAL(ATTR(3), 'I', 0, 94, 0, 94,
     $    'Number of pad characters to use', .TRUE.)
      RETURN
C
 50   CONTINUE                     !set quote character
      CALL SETVAL(ATTR(6), 'I',33, 62,  97, 126, HLPASCH, .TRUE.)
      RETURN
C
 60   CONTINUE                     !set sync character
      CALL SETVAL(ATTR(12),'I', 0,127,   0, 127, HLPASCH, .TRUE.)
      RETURN
C
 70   CONTINUE                     !set timeout value
      SETVAL (ATTR(2), 'I', 0, 94, 0, 94,
     $ 'Number of seconds to wait before timeout', .TRUE.)
      RETURN
      END
      SUBROUTINE PORTCMD
           IMPLICIT NONE
C
C= Selects the port to be used.
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
C
      INTEGER      PORTSTR(7)      !port string to read
      CHARACTER*6  PORTNM          !char device name
      CHARACTER*6  PORTWR          !write port
      INTEGER      IRET            !error code
      INTEGER      INEW            !new input
      INTEGER      ONEW            !new output
C
      INTEGER      OPEN            !open port
      INTEGER      XTOI            !hex ascii to integer
      CHARACTER*4  ITOX            !integer to hex ascii
C
      CALL SETVAL(PORTSTR, 'S', IRET, 6, 0, 0,
     $       'Select communication port', .TRUE.)
      IF (IRET .EQ. OK) THEN
        CALL AS2DPC(PORTSTR, PORTNM)
C
        IF (PORTNM .EQ. COMPORT) THEN      !ignore no change
        ELSE
C
C now open
C
          IF (PORTNM .EQ. 'UT') THEN
            IF (IFD .NE. STDIN) CALL CLOSE(IFD)
            IF (OFD .NE. STDOUT) CALL CLOSE(OFD)
            IFD = STDIN
            OFD = STDOUT
            COMPORT = PORTNM
          ELSE
            INEW = OPEN('@'//PORTNM,'R')
            IF (INEW .LE. 0) THEN
              CALL PRINTL(STDOUT, 'Failed to open read channel, code= ')
              CALL PUTINT(STDOUT, -INEW, 3)
              RETURN
            ENDIF
            PORTWR = PORTNM(1:2)
            PORTWR(3:6) = ITOX(XTOI(PORTNM(3:6))+8)
            ONEW = OPEN('@'//PORTWR,'W')
            IF (ONEW .LE. 0) THEN
              CALL CLOSE(INEW)
              CALL PRINTL(STDOUT,'Failed to open write channel,code= ')
              CALL PUTINT(STDOUT, -ONEW, 3)
              RETURN
            ENDIF
            IF (IFD .NE. STDIN) CALL CLOSE(IFD)
            IF (OFD .NE. STDOUT) CALL CLOSE(OFD)
            COMPORT = PORTNM
            IFD = INEW
            OFD = ONEW
          ENDIF
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE CONNECT
           IMPLICIT NONE
C
C= Connects stdin/stdout to in/out port
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KTIME.COM'
C
      INTEGER      BELL            ;PARAMETER (BELL = X'07')
      INTEGER      ZERO            ;PARAMETER (ZERO = X'30')
      INTEGER      BREAK           ;PARAMETER (BREAK = X'42')
      INTEGER      CLOSE           ;PARAMETER (CLOSE = X'43')
      INTEGER      QUIT            ;PARAMETER (QUIT = X'51')
      INTEGER      RESUME          ;PARAMETER (RESUME=X'52')
      INTEGER      LOWA            ;PARAMETER (LOWA = X'61')
      INTEGER      LOWZ            ;PARAMETER (LOWZ = X'7A')
      INTEGER      LOW2UP          ;PARAMETER (LOW2UP = X'20')
      INTEGER      INCHR           !char from stdin
      INTEGER      TTCHR           !char from port
      CHARACTER*10 CNUM            !character
      CHARACTER*10 CNUM2
      INTEGER      STIME
      INTEGER      FTIME
CLT   LOGICAL      PAUSER                                          !XXX
CLT   LOGICAL      DUMPER                                          !XXX
C
      INTEGER      GETC            !get character
      LOGICAL      CONFIRM         !confirm connect
      INTEGER      CTL             !convert ctl to non-control
      CHARACTER*(*)ITOA
CLT   LOGICAL      OPTION                                          !XXX
C
      IF (.NOT. CONFIRM(INPUTFD)) RETURN
CLT   PAUSER = OPTION (1)                                          !XXX
CLT   DUMPER = OPTION (2)                                          !XXX
C
      IF (IFD .EQ. STDIN .OR. OFD .EQ. STDOUT) THEN
        CALL PRINTL(STDOUT, '?No external port selected.')
        RETURN
      ENDIF
C
      CALL PUTC(STDOUT, NEL)
      CALL PRINT(STDOUT, '[Connecting to port, type ^')
      CALL PUTC(STDOUT, CTL(ESCCHR))
      CALL PRINT(STDOUT, ' C to return to local]')
      CALL PUTC(STDOUT, NEL)
      CALL PUTC(STDOUT, NEL)
C
      CALL STTY(STDIN, 'BINARY', ON)
      CALL STTY(STDIN, 'SIZE', 1)
      CALL STTY(STDOUT, 'SIZE', 1)
      CALL STTY(STDIN, 'NOWAIT', ON)
      CALL STTY(STDOUT, 'NOWAIT', ON)
      CALL STTY(IFD, 'BINARY', ON)
      CALL STTY(IFD, 'SIZE', 1)
      CALL STTY(OFD, 'SIZE', 1)
      CALL STTY(IFD, 'NOWAIT', ON)
      CALL STTY(OFD, 'NOWAIT', ON)
      GETIME = PUTIME = 0
      GETCOUNT = PUTCOUNT = 0
      WAITIME = WAITCNT = 0
      CALL MSEC(TOTIME)
C
      DO, BEGIN
CLT     IF (DUMPER) CALL DUMPF('BEGIN')                            !XXX
CLT     IF (PAUSER) PAUSE BEGIN                                    !XXX
        CALL MSEC(STIME)
        INCHR = GETC(STDIN, INCHR)
        CALL MSEC(FTIME)
CLT     IF (DUMPER) CALL DUMPF('AFTER STDIN')                      !XXX
        GETCOUNT = GETCOUNT + 1
        GETIME = FTIME - STIME + GETIME
        CALL MSEC(STIME)
        TTCHR = GETC(IFD, TTCHR)
        CALL MSEC(FTIME)
        GETCOUNT = GETCOUNT + 1
        GETIME = FTIME - STIME + GETIME
C
CLT     IF (INCHR .NE. ERROR .OR. TTCHR .NE. ERROR) THEN
CLT       CNUM = ITOA(INCHR)
CLT       CNUM2 = ITOA(TTCHR)
CLT       CALL DISPLAY('KERMIT/CONNECT - PARSE CHARACTER'//CNUM//CNUM2)
CLT     ENDIF
        IF (INCHR .EQ. EOF) THEN
CLT       CALL DISPLAY('KERMIT/CONNECT - EOF')
          LEAVE
        ELSE IF (INCHR .EQ. ERROR) THEN
          CONTINUE
        ELSE IF (INCHR .EQ. ESCCHR) THEN
 10       CONTINUE
CLT       CALL DISPLAY('KERMIT/CONNECT - WAIT FOR NON-ERROR')
          DO WHILE (GETC(STDIN, INCHR) .EQ. ERROR)
            CALL IOWAIT(50 )
          ENDDO
          IF (INCHR .GE. LOWA .AND. INCHR .LE. LOWZ)
     $       INCHR = INCHR - LOW2UP
          CNUM = ITOA(INCHR)
CLT       CALL DISPLAY('KERMIT/CONNECT - NON-ERROR ='//CNUM)
          IF (INCHR .EQ. CLOSE) THEN
            LEAVE
          ELSE IF (INCHR .EQ. BREAK) THEN
            CALL SENDBRK(OFD)
          ELSE IF (INCHR .EQ. ZERO) THEN
            CALL PUTC(OFD, 0)
          ELSE IF (INCHR .EQ. QUIT) THEN
            LOG = .FALSE.
          ELSE IF (INCHR .EQ. RESUME) THEN
            IF (FFD .NE. 0) LOG = .TRUE.
          ELSE IF (INCHR .EQ. ESCCHR) THEN
            CALL PUTC(OFD, ESCCHR)
          ELSE IF (INCHR .EQ. QMARK) THEN
            CALL STTY(STDOUT, 'SIZE', -1)
            CALL STTY(STDOUT, 'NOWAIT', OFF)
            CALL PRINTL(STDOUT,'0   Send NULL')
            CALL PRINTL(STDOUT,'B   Send BREAK')
            CALL PRINTL(STDOUT,'C   Close connection')
            CALL PRINTL(STDOUT,'Q   Quit logging')
            CALL PRINTL(STDOUT,'R   Resume logging')
            CALL PUTC(STDOUT, NEL)
            CALL PRINT(STDOUT, '^')
            CALL PUTC(STDOUT, CTL(ESCCHR))
            CALL PRINT(STDOUT,'  Send this character')
            CALL PRINTL(STDOUT,'?   This message')
            CALL PRINTL(STDOUT,'Command>')
            CALL STTY(STDOUT, 'NOWAIT', ON)
            CALL STTY(STDOUT, 'SIZE', 1)
            GOTO 10
          ELSE
            CALL PUTC(STDOUT, BELL)
          ENDIF
        ELSE
CLT       CALL DISPLAY('KERMIT/CONNECT - PUTC OFD')
          CALL MSEC(STIME)
          CALL PUTC(OFD, INCHR)
          CALL MSEC(FTIME)
          PUTCOUNT = PUTCOUNT + 1
          PUTIME = PUTIME + FTIME - STIME
          IF (ECHO) CALL PUTC(STDOUT, INCHR)
        ENDIF
C
        IF (TTCHR .EQ. EOF) THEN
          CALL PRINTL(STDOUT, '?EOF on port connection')
          LEAVE
        ELSE IF (TTCHR .EQ. ERROR) THEN
          CONTINUE
        ELSE
CLT       CALL DISPLAY('KERMIT/CONNECT - PUTC STDOUT')
          CALL MSEC(STIME)
          CALL PUTC(STDOUT, TTCHR)
          CALL MSEC(FTIME)
          PUTIME = PUTIME + FTIME - STIME
          PUTCOUNT = PUTCOUNT + 1
          IF (LOG) THEN
            IF (TTCHR .GE. BLANK .AND. TTCHR .LT. DEL) THEN
              CALL PUTC(LFD, TTCHR)
            ELSE IF (TTCHR .EQ. CR) THEN
              CALL PUTC(LFD, NEL)
            ENDIF
          ENDIF
        ENDIF
C
        CALL MSEC(STIME)
        IF (TTCHR .EQ. ERROR .AND. INCHR .EQ. ERROR) THEN
          CALL IOWAIT(50 )
        ENDIF
        CALL MSEC(FTIME)
        WAITIME = WAITIME + FTIME - STIME
        WAITCNT = WAITCNT + 1
C
      ENDDO
CLT   IF (DUMPER) CALL DUMPF('ENDDO')                              !XXX
CLT   IF (PAUSER) PAUSE ENDDO                                      !XXX
C
      CALL MSEC(FTIME)
      TOTIME = FTIME - TOTIME
      CALL FLUSH(IFD)
      CALL FLUSH(STDIN)
      CALL STTY(STDIN, 'BINARY', OFF)
      CALL STTY(STDIN, 'SIZE', 80)
      CALL STTY(STDOUT, 'SIZE', -1)
      CALL STTY(STDIN, 'NOWAIT', OFF)
      CALL STTY(STDOUT, 'NOWAIT', OFF)
      CALL STTY(IFD, 'BINARY', OFF)
      CALL STTY(IFD, 'SIZE', -1)
      CALL STTY(OFD, 'SIZE', -1)
      CALL STTY(IFD, 'NOWAIT', OFF)
      CALL STTY(OFD, 'NOWAIT', OFF)
CLT   IF (DUMPER) CALL DUMPF('EXIT CONNECT')                       !XXX
C
      RETURN
      END
      SUBROUTINE LOGGER
           IMPLICIT NONE
C
C= Performs log command
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
C
      INTEGER      NCMD            ;PARAMETER (NCMD = 3)
      CHARACTER*8  CMD(NCMD)
     $   /'LOG-FILE', 'OFF', 'ON'/
      INTEGER      IRET
      INTEGER      TSTR(17)     !temp file string
      INTEGER      INDX
C
      INTEGER      MATCH
      INTEGER      OPEN            !open file
C
      INDX = MATCH(CMD, NCMD, .FALSE.)
      IF (INDX .LE. 0) RETURN
C
      GOTO (10, 20, 30) INDX
C
 10   CONTINUE
        CALL SETVAL(TSTR, 'S', IRET, 16, 0, 0,
     $       'Session log filename', .TRUE.)
        IF (IRET .EQ. OK) THEN
          CALL AS2DPC(TSTR, LOGFILE)
          LFD = OPEN(LOGFILE, 'W')
          IF (LFD .LE. 0) THEN
            CALL PRINTL(STDOUT, '?Failed to open session log file ')
            CALL PUTINT(STDOUT, -LFD, 3)
            LOG = .FALSE.
          ELSE
            LOG = .TRUE.
          ENDIF
        ENDIF
        GOTO 100
C
 20   CONTINUE
        LOG = .FALSE.
        IF (LFD .GT. 0) CALL CLOSE(LFD)
        GOTO 100
C
 30   CONTINUE
        IF (LFD .EQ. 0) THEN
          LFD = OPEN(LOGFILE, 'W')
          IF (LFD .EQ. ERROR)
     $      CALL PRINTL(STDOUT, '?Failed to open session log file')
        ENDIF
        LOG = LFD .GT. 0
        GOTO 100
C
 100  CONTINUE
      RETURN
      END
      SUBROUTINE FINISH
          IMPLICIT NONE
C
C= Sends finish command to target port
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KPACK.COM'
C
      INTEGER      PTYP, LEN, NUM
C
      LOGICAL      CONFIRM
      INTEGER      RDPACK
C
      IF (.NOT. CONFIRM(INPUTFD)) RETURN
C
      IF (IFD .EQ. STDIN ) THEN
        CALL PRINTL(STDOUT, '?No communication port selected.')
        RETURN
      ENDIF
C
      CALL STTY(IFD, 'BINARY', ON)
      CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
      CALL STTY(IFD, 'NOWAIT', ON)
      NUMTRY = 0
      PACKET(1) = F                !f is constant , fort codes as halfw.
      DO WHILE (NUMTRY .LE. MAXTRY)
        NUMTRY = NUMTRY + 1
        CALL SNDPACK(G, 0, 1, PACKET)
        PTYP = RDPACK(LEN, NUM, RECPACK)
        IF (PTYP .EQ. Y) LEAVE
      ENDDO
      CALL STTY(IFD, 'NOWAIT', OFF)
      CALL STTY(IFD, 'TIMEOUT', 0)
      CALL STTY(IFD, 'BINARY', OFF)
      RETURN
      END
      SUBROUTINE BYE
           IMPLICIT NONE
C
C= Sends bye to remote and exits kermit
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KPACK.COM'
C

      INTEGER      PTYP            !packet type
      INTEGER      LEN, NUM
C
      LOGICAL      CONFIRM
      INTEGER      RDPACK
C
      IF (.NOT. CONFIRM(INPUTFD)) RETURN
C
      CALL STTY(IFD, 'BINARY', ON)
      CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
      CALL STTY(IFD, 'NOWAIT', ON)
      IF (IFD .EQ. STDIN ) THEN
        CALL PRINTL(STDOUT, '?No communication port selected.')
        RETURN
      END IF
C
      PACKET(1) = L
      NUMTRY = 0
      DO WHILE (NUMTRY .LE. MAXTRY)
        NUMTRY = NUMTRY + 1
        CALL SNDPACK(G, 0, 1, PACKET)
        PTYP = RDPACK(LEN, NUM, RECPACK)
        IF (PTYP .EQ. Y) LEAVE
      ENDDO
      CALL STTY(IFD, 'NOWAIT', OFF)
      CALL STTY(IFD, 'TIMEOUT', 0)
      CALL STTY(IFD, 'BINARY', OFF)
      CALL EXITPGM
      END
      SUBROUTINE GETFROM
           IMPLICIT NONE
C
C= Get file from remote server
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KPACK.COM'
C
      INTEGER      IRET            !return status
      INTEGER      PTYP            !packet type
      INTEGER      LEN
      INTEGER      NUM
C
      INTEGER      SLEN            !length of string
      INTEGER      RECEIVE
      INTEGER      MOD
      INTEGER      RDPACK          !read packet
      INTEGER      SNDPAR          !pack send parameters
C
      CALL SETVAL(FILESTR, 'S', IRET, 16, 0, 0,
     $   'Filename to get', .TRUE.)
      IF (IRET .EQ. ERROR) RETURN
C
      IF (IFD .EQ. STDIN) THEN
        CALL PRINTL(STDOUT, '?No communication port selected.')
        RETURN
      END IF
C
      IF (INPUTFD .NE. STDIN .AND. OFD .NE. STDOUT) THEN
        CALL PRINTL(STDOUT, 'Getting file ')
        CALL PUTSTR(STDOUT, FILESTR)
        CALL FLUSH(STDOUT)
      ENDIF
C
      CALL STTY(IFD, 'BINARY', ON)
      CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
      CALL STTY(IFD, 'NOWAIT', ON)
C
      NUMTRY = 0
      DO WHILE (NUMTRY .LE. MAXRINI)
        NUMTRY = NUMTRY + 1
        CALL SNDPACK(R, 0, SLEN(FILESTR), FILESTR)
        PTYP = RDPACK(LEN, NUM, RECPACK)
        IF (PTYP .EQ. S) THEN
          PACKNUM = NUM
          CALL RDPARAM(RECPACK)
          LEN = SNDPAR(PACKET)
          CALL SNDPACK(Y, PACKNUM, LEN, PACKET)
          NUMTRY = 0
          PACKNUM = MOD(PACKNUM+1, 64)
          IF (RECEIVE(F) .EQ. OK) THEN
            CALL PRINTL(STDOUT, 'Receive complete.')
          ELSE
            CALL PRINTL(STDOUT, 'Receive failed.')
          ENDIF
          LEAVE
        ENDIF
      ENDDO
      CALL STTY(IFD, 'NOWAIT', OFF)
      CALL STTY(IFD, 'TIMEOUT', 0)
      CALL STTY(IFD, 'BINARY', OFF)
      RETURN
      END
      SUBROUTINE TAKE
           IMPLICIT NONE
C
C Provides a means to redirect input to file.
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
C
      INTEGER      TAKEFILE(17)    !take file input name
      CHARACTER*16 CTAKEFIL        !input file name
      INTEGER      IRET            !return code
      INTEGER      TAKEFD          !file desc to take from
C
      LOGICAL      ISFILE          !check for file existence
      INTEGER      OPEN
C
C
      CALL SETVAL(TAKEFILE, 'S', IRET, 16, 0, 0,
     $    'Filename to take commands from',.TRUE.)
      IF (IRET .EQ. ERROR) RETURN
C
C check to make sure it's there
C
      CALL AS2DPC(TAKEFILE, CTAKEFIL)
      IF (.NOT. ISFILE(CTAKEFIL)) THEN
        CALL PRINTL(STDOUT, '?File ')
        CALL PUTSTR(STDOUT, TAKEFILE)
        CALL PRINT(STDOUT, ' is not found.')
        CALL PUTC(STDOUT, NEL)
        RETURN
      ENDIF
C
C open file
C
      IF (INSTACK .GE. MAXINSTK) THEN
        CALL PRINTL(STDOUT, '?Exceed input TAKE stack depth.')
        RETURN
      ENDIF
      TAKEFD = OPEN(CTAKEFIL, 'R')
      IF (TAKEFD .EQ. ERROR) THEN
        CALL PRINTL(STDOUT, '?Cannot open ')
        CALL PUTSTR(STDOUT, TAKEFILE)
        CALL PRINT(STDOUT, '.')
        CALL PUTC(STDOUT, NEL)
        RETURN
      ENDIF
C
C remember where was
C
      INSTACK = INSTACK + 1
      INSTKFD(INSTACK) = INPUTFD
C
C redirect
C
      INPUTFD = TAKEFD
      RETURN
      END
      SUBROUTINE TAKEDONE
           IMPLICIT NONE
C
C= Returns to next level of input file.
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
C
      IF (INPUTFD .NE. STDIN) CALL CLOSE(INPUTFD)
      IF (INSTACK .LE. 0) THEN
        INSTACK = 0
        INPUTFD = STDIN
      ELSE
        INPUTFD = INSTKFD(INSTACK)
        INSTACK = INSTACK - 1
      ENDIF
      RETURN
      END
      INTEGER FUNCTION MATCH (TABLE, TABLEN, NELOK)
           IMPLICIT NONE
           CHARACTER*(*) TABLE(*)  !table of commands
           INTEGER       TABLEN    !number of elements
           LOGICAL       NELOK
C
C= Decides which input came in, handles ? help
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
C
      CHARACTER*40  WORD           !word to input
      INTEGER       ASTR(41)       !ascii string
      INTEGER      LEN             !length of word
      INTEGER      T1, T2          !internal indexes
      INTEGER      CHP             !character pointer
C
      INTEGER      GETWORD         !get word from input
C
      LEN = GETWORD(INPUTFD, ASTR, 40)
      IF (LEN .EQ. 0 .OR. LEN .EQ. EOF) THEN
        MATCH = LEN
        IF (LEN .EQ. 0 .AND. .NOT. NELOK) THEN
          MATCH = ERROR
          CALL PRINTL(STDOUT, '? Null switch or keyword given')
        ENDIF
        RETURN
      ENDIF
      CALL AS2DPC(ASTR, WORD)
C
C begin matching
C
      T1 = 1
      T2 = TABLEN
      CHP = 1
      DO WHILE (CHP .LE. LEN)
C
C if we find a ?, the give the possiblities
C
        IF (WORD(CHP:CHP) .EQ. '?') THEN
          CALL PRINTL(STDOUT, 'One of the following:')
          CALL OUTTBL(TABLE, T1, T2)
          MATCH = ERROR
          RETURN
        ENDIF
C
C while word is less than lower table entry
C
        DO WHILE (WORD(CHP:CHP) .GT. TABLE(T1)(CHP:CHP) .AND.
     $            T1 .LE. T2)
          T1 = T1 + 1
        ENDDO
C
C while word is greater than upper table entry
        DO WHILE (WORD(CHP:CHP) .LT. TABLE(T2)(CHP:CHP) .AND.
     $           T2 .GE. T1)
          T2 = T2 - 1
        ENDDO
C
C if we know we have a mismatch
C
        IF (T2 .LT. T1) THEN
          CALL PRINTL(STDOUT, '? Does not match switch or keyword - '//
     $                WORD)
          MATCH = ERROR
          RETURN
        ENDIF
        CHP = CHP + 1
      ENDDO
C
C after looking at the whole word, is it still ambiguous
C
      IF (T1 .NE. T2) THEN
        CALL PRINTL(STDOUT, '? Ambigious - '//WORD)
        MATCH = ERROR
      ELSE
        MATCH = T1
      ENDIF
      RETURN
      END
      SUBROUTINE OUTTBL(TABLE, START, FIN)
           IMPLICIT NONE
           CHARACTER*(*) TABLE (*)  !table to output
           INTEGER  START          !start of table
           INTEGER FIN             !end of table
C
C= Outputs table in table format
C
      INCLUDE      'KDEF.INS'
C
      INTEGER      ICOL            !column
      CHARACTER*80 LINE            !output line
      INTEGER      NCOLS           !number of columns
      INTEGER      IPOS
      INTEGER      I
      INTEGER      COLWID          !width of column
      INTEGER      NL              !last character in line
      INTEGER      LINECNT         !count of lines output
C
      INTEGER      LASTCHR         !last non-blank character in line
      LOGICAL      MORE            !continue on
C
      LINECNT = 0
      COLWID = LEN(TABLE) + 2
      NCOLS = 80 / COLWID
      LINE = ' '
      ICOL = 1
      DO I=START, FIN
        IPOS = (ICOL - 1) * COLWID + 1
        LINE (IPOS:) = TABLE(I)
        ICOL = ICOL + 1
        IF (ICOL .GT. NCOLS .OR. I .EQ. FIN) THEN
          NL = LASTCHR(LINE)
          IF (NL .LE. 0) NL = 1
          LINECNT = LINECNT + 1
          IF (LINECNT .GE. 23) THEN
            IF (.NOT. MORE()) RETURN
            LINECNT = 0
          ENDIF
          CALL PRINTL(STDOUT, LINE(:NL))
          LINE = ' '
          ICOL = 1
        ENDIF
      ENDDO
      RETURN
      END
      LOGICAL FUNCTION CONFIRM (FD)
           IMPLICIT NONE
           INTEGER    FD   !file device
C
C= Looks for a newline to confirm command
C
C  Confirm will expect that the next token of input be a
C  newline for confirmation to be true.  If the next token
C  is a question mark, then confirmation is false and a
C  "confirm with a carriage return" message will be displayed'
C  any other text will cause a 'not confirmed text message
C  to be displayed and confirm will return false
C
      INCLUDE      'KDEF.INS'
C
      INTEGER      CH              !character input
C
      INTEGER      GETC            !get character
C
      CONFIRM = .FALSE.
 10   CONTINUE
      IF (GETC(FD, CH) .EQ. NEL) THEN
        CONFIRM = .TRUE.
      ELSE IF (CH .EQ. EOF) THEN
        RETURN
      ELSE IF (CH .EQ. BLANK .OR. CH .EQ. TAB) THEN
        GOTO 10
      ELSE IF (CH .EQ. QMARK) THEN
        CALL PRINTL(STDOUT, 'Confirm with a carriage return')
      ELSE
        CALL PRINTL(STDOUT, '? Not confirmed - ')
 20     CONTINUE
        CALL PUTC(STDOUT, CH)
        CH = GETC(FD, CH)
        IF (CH .NE. NEL .AND. CH .NE. EOF) GOTO 20
        CALL PUTC(STDOUT, NEL)
      ENDIF
      RETURN
      END
      SUBROUTINE SETVAL(VAR, VTYP, MN1, MX1, MN2, MX2, HLPMSG,
     $                   CONFRM)
           IMPLICIT NONE
           INTEGER    VAR(41)  !string to fill
           CHARACTER*1  VTYP    !type of input (s, i)
           INTEGER      MN1     !error code         minimum value
           INTEGER      MX1     !length of string   maximum value
           INTEGER      MN2     !                   minimum value
           INTEGER      MX2     !                   maximum value
           CHARACTER*(*) HLPMSG    !help message to output
           LOGICAL      CONFRM     !must confirm
C
C= Reads input of specified type within range of parameters for int.
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
C
      INTEGER      STR(41)         !input string
      INTEGER      LEN
      INTEGER      I
C
      LOGICAL      CONFIRM         !confirm input
      INTEGER      CTOI            !character to integer
      INTEGER      GETWORD         !get a word from input
C
      LEN = GETWORD(INPUTFD, STR, 40)
      IF (LEN .EQ. 0 .OR. LEN .EQ. EOF) THEN
        IF (VTYP .EQ. 'I') THEN
          CALL PRINTL(STDOUT,'First nonspace character is not a digit')
        ELSE
          CALL PRINTL(STDOUT,'Invalid, Missing parameter')
          MN1 = ERROR
        ENDIF
        RETURN
      ENDIF
      IF (STR(1) .EQ. QMARK) THEN
        CALL PRINTL(STDOUT, HLPMSG)
        CALL FLUSH(INPUTFD)
        IF (VTYP .EQ. 'S') MN1 = ERROR
        RETURN
      ENDIF
C
C confirm the request if necessary
C
      IF (CONFRM) THEN
        IF (.NOT. CONFIRM(INPUTFD)) THEN
          IF (VTYP .EQ. 'S') MN1 = ERROR
          RETURN
        ENDIF
      ENDIF
C
C go ahead and set variable
C
      IF (VTYP .EQ. 'I') THEN
        I = CTOI(STR)
        IF (I .GE. MN1 .AND. I .LE. MX1) THEN
          VAR(1) = I
        ELSE IF (I .GE. MN2 .AND. I .LE. MX2) THEN
          VAR(2) = I
        ELSE
          CALL PRINTL(STDOUT, '? Value is not within range of ')
          CALL PUTINT(STDOUT, MN1, 1)
          CALL PRINT(STDOUT, '-')
          CALL PUTINT(STDOUT, MX1, 1)
          CALL PRINT(STDOUT, ', or ')
          CALL PUTINT(STDOUT, MN2, 1)
          CALL PRINT(STDOUT, '-')
          CALL PUTINT(STDOUT, MX2, 1)
        ENDIF
      ELSE
        DO I=1, LEN
          VAR(I) = STR(I)
        ENDDO
        VAR(LEN+1) = 0
        MN1 = OK
      ENDIF
      RETURN
      END
      SUBROUTINE HELP
           IMPLICIT NONE
C
C= Prints help messages
C
      INCLUDE      'KVER.INS'
      INCLUDE      'KDEF.INS'
C
      INTEGER      MAXHLPS         ;PARAMETER   (MAXHLPS = 16)
      CHARACTER*10 HLPCMDS(MAXHLPS)
     $ /'BYE','CONNECT','EXIT','FINISH','GET','HELP','KERMIT','QUIT',
     $  'RECEIVE','SEND','SERVER','SET','SHOW','STATUS','TAKE','X'/
C
C help send
C
      INTEGER      LMES10          ;PARAMETER (LMES10 = 5)
      CHARACTER*63 MES10  (LMES10)
     $ /' ' ,
     $ 'SEND local-filename',
     $ ' ',
     $ 'Sends file to remote KERMIT.',
     $ ' '/
C
C help get
C
      INTEGER      LMES20          ;PARAMETER (LMES20 = 5)
      CHARACTER*63 MES20 (LMES20)
     $ /' ',
     $ 'GET remote-filename',
     $ ' ',
     $ 'Tells a user Kermit to send a file.',
     $ ' '/
C
C help receive
C
      INTEGER      LMES30          ;PARAMETER (LMES30 = 5)
      CHARACTER*63 MES30(LMES30)
     $ /' ',
     $ 'RECEIVE',
     $ ' ',
     $ 'Expects one or more files to arrive.',
     $ ' '/
C
C help connect
C
      INTEGER      LMES40          ;PARAMETER (LMES40 = 17)
      CHARACTER*63 MES40 (LMES40)
     $ /' ',
     $ 'CONNECT',
     $ ' ',
     $ 'Enter terminal emulation mode; presents the illusion of',
     $ 'being directly connected as a terminal to the remote',
     $ 'system.  When escape character is typed, interprets next',
     $ 'character as follows:',
     $ '  0        (zero) Transmits a NUL',
     $ '  B        Transmits a BREAK',
     $ '  C        Close a connection, return to local KERMIT',
     $ '  Q        Quit logging (if logging is being done)',
     $ '  R        Resume logging',
     $ '  ?        Show available arguments to the escape character',
     $ '  (escape character again):  Transmit the escape character',
     $ '           itself',
     $ 'Invalid arguements are beeped and reenters connect mode.',
     $ ' '/
C
C help kermit
C
      INTEGER      LMES50          ;PARAMETER (LMES50 = 19)
      CHARACTER*63 MES50(LMES50)
     $ /' ',
     $ 'Kermit is a file transfer protocol for use over an',
     $ 'asynchronous serial telecommunication line.  Files are',
     $ 'broken up into ""packets"" with checksums and other control',
     $ 'information to ensure (with high probability) error-free',
     $ 'and complete transmission.',
     $ ' ',
     $ 'This implementation of Kermit is for the GOULD concept32',
     $ 'computers.  It may be run remotely using a micro or if',
     $ 'the os is MPX3.2B or greater, may be run locally as a',
     $ 'terminal emulator',
     $ ' ',
     $ 'Commands are: SEND, GET, RECEIVE, CONNECT, EXIT, X, QUIT,',
     $ 'BYE, FINISH, SERVER, SET, SHOW, STATUS',
     $ ' ',
     $ 'For further information, type ""HELP"" for any of the above',
     $ 'e.g.  ""HELP RECEIVE"" or see the Kermit Users Guide and',
     $ 'Kermit Protocol manual.',
     $ ' '/
C
C help exit, quit, x
C
      INTEGER      LMES60          ;PARAMETER (LMES60 = 3)
      CHARACTER*63 MES60  (LMES60)
     $ /' ',
     $  'Exit from Kermit.',
     $  ' '/
C
C help take
C
      INTEGER      LMES70          ;PARAMETER (LMES70 = 5)
      CHARACTER*63 MES70 (LMES70)
     $ /' ',
     $ 'TAKE local-filename',
     $ ' ',
     $ 'Read and execute Kermit commands from a local file.',
     $ ' '/
C
C help server
C
      INTEGER      LMES90          ;PARAMETER (LMES90=16)
      CHARACTER*63 MES90 (LMES90)
     $ /' ',
     $ 'SERVER',
     $ ' ',
     $ 'Act as a server for another Kermit.  Take all further',
     $ 'commands only from the other Kermit.  After issuing',
     $ 'this command, escape back to your local system and issue',
     $ 'SEND or GET, BYE, or other server-oriented',
     $ 'commands from there.  If your local Kermit does not have',
     $ 'a BYE command, it does not have the full ability to',
     $ 'communicate with a Kermit server (in which case you can',
     $ 'only use the SEND command).  If your local Kermit does',
     $ 'have a BYE command, use it to shut down and log out',
     $ 'the Kermit server when you are done with it; otherwise,',
     $ 'connect back to the Gould, type several Control-C''s to',
     $ 'stop the server, and logout.',
     $ ' '/
C
C help set
C
      INTEGER      LMES100         ;PARAMETER (LMES100=122)
      CHARACTER*63 MES100(LMES100)
     $/' ',
     $ 'SET',
     $ ' ',
     $ '  Establish system-dependent parameters.  You can examine',
     $ 'their values with the SHOW command.  Numeric values may be',
     $ 'decimal, octal (postfixed with a O), or hexadecimal (post-',
     $ 'fixed with an H).  The following may be SET:',
     $ ' ',
     $ ' DEBUG options',
     $ '   Show packet traffic explicitly.  Options are:',
     $ '   ALL      Set all debug options.',
     $ '   LOG-FILE Log states and packets to the specified file.',
     $ '            The default log-file is file L.KERMLOG',
     $ '   OFF      Don''t display debugging information. (this is',
     $ '            the default).  If debugging was in effect, turn',
     $ '            it off and close any log file.',
     $ '   PACKETS  Display each incoming and outgoing packet',
     $ '            (lengthy)',
     $ '   STATES   Show kermit state transitions and packet numbers',
     $ '            (brief).',
     $ ' ',
     $ ' LOG options',
     $ '   Log all inputs from remote port during connection.',
     $ '   Options are:',
     $ '   LOG-FILE Log inputs to specified file.  The default',
     $ '            log-file is file L.SESSION',
     $ '   OFF      Turn off the session logging',
     $ '   ON       Turn on the session logging',
     $ ' ',
     $ ' PORT terminal-address',
     $ '   Sets the communicaton port; to which connect, send,',
     $ '   receive and server interact with.  Any MPX terminal ',
     $ '   address may be used.  Examples: TY7EC0, U17CC4, or UT.',
     $ '   Default is UT',
     $ ' ',
     $ ' ESCAPE decimal-number',
     $ '   Control character used to escape from connect mode.',
     $ '   Default is 29, (^])',
     $ ' ',
     $ ' ECHO on/off',
     $ '   Turns on or off the echo by kermit during connect mode.',
     $ ' ',
     $ ' DELAY decimal-number',
     $ '   How many seconds to wait before sending the first',
     $ '   packet.  This gives you time to ""escape"" back and',
     $ '   issue a RECEIVE command.',
     $ ' ',
     $ ' INIT-RETRY decimal-number',
     $ '   Set the maximum number of retries allowed for the',
     $ '   initial connection before giving up.',
     $ ' ',
     $ ' RETRY decimal-number',
     $ '   Set the maximum number of retries allowed for sending',
     $ '   a particular packet.',
     $ ' ',
     $ ' SEND parameter',
     $ '   Parameters for outgoing packets as follows:',
     $ ' ',
     $ '   EOLCHR  octal-number',
     $ '     The octal value of the ASCII character to be used',
     $ '     as a line terminator for packets, if one is required',
     $ '     by the other system.  Carriage return (15B) by default.',
     $ ' ',
     $ '   PACKLEN decimal-number',
     $ '     Maximum packet length to send, decimal number, between',
     $ '     20 and 94, 94 by default.',
     $ ' ',
     $ '   PADCHR octal-number',
     $ '     Character to use for padding.  Default is NUL.',
     $ ' ',
     $ '   PADLEN decimal-number',
     $ '     How much padding to send before a packet.  Default',
     $ '     is no padding.',
     $ ' ',
     $ '   QUOTECHR octal-number',
     $ '     What printable character to use for quoting of control',
     $ '     characters.  The default is ''#'' (43B).  There should',
     $ '     be no reason to change this.',
     $ ' ',
     $ '   SYNCCHR octal-number',
     $ '     The control character that marks the beginning of the',
     $ '     packet.  Normally SOH (Control-A, ASCII 1).  There',
     $ '     should be no reason to change this.',
     $ ' ',
     $ '   TIMEOUT decimal-number',
     $ '     How many seconds the other Kermit wants before being',
     $ '     asked for retransmission.',
     $ ' ',
     $ ' RECEIVE parameter',
     $ '   Parameters to request or expect for incoming packets,',
     $ '   as follows:',
     $ ' ',
     $ '   EOLCHR  octal-number',
     $ '     The octal value of the ASCII character to be used',
     $ '     as a line terminator for packets, if one is required',
     $ '     by the other system.  Carriage return (15B) by default.',
     $ ' ',
     $ '   PACKLEN decimal-number',
     $ '     Maximum packet length to send, decimal number, between',
     $ '     20 and 94, 94 by default.',
     $ ' ',
     $ '   PADCHR octal-number',
     $ '     Character to use for padding.  Default is NUL.',
     $ ' ',
     $ '   PADLEN decimal-number',
     $ '     How much padding to send before a packet.  Default',
     $ '     is no padding.',
     $ ' ',
     $ '   QUOTECHR octal-number',
     $ '     What printable character to use for quoting of control',
     $ '     characters.  The default is ''#'' (43B).  There should',
     $ '     be no reason to change this.',
     $ ' ',
     $ '   SYNCCHR octal-number',
     $ '     The control character that marks the beginning of the',
     $ '     packet.  Normally SOH (Control-A, ASCII 1).  There',
     $ '     should be no reason to change this.',
     $ ' ',
     $ '   TIMEOUT decimal-number',
     $ '     How many seconds the other Kermit wants before being',
     $ '     asked for retransmission.',
     $ ' '/
C
C help show
C
      INTEGER LMES110              ;PARAMETER (LMES110= 4 )
      CHARACTER*63 MES110(LMES110) !show help
     $/' ',
     $ 'Display current SET parameters, version of Kermit, and',
     $ 'other info.',
     $ ' '/
C
C help status
C
      INTEGER      LMES120         ;PARAMETER (LMES120= 3)
      CHARACTER*63 MES120(LMES120)
     $/' ',
     $ 'Give statistics about the most recent file transfer.',
     $ ' '/
C
C help help
C
      INTEGER      LMES130         ;PARAMETER (LMES130=16)
      CHARACTER*63 MES130 (LMES130)
     $/' ',
     $ 'HELP [topic]',
     $ ' ',
     $ 'Typing HELP alone prints a brief summary of Kermit',
     $ 'and its commands.  You can also type',
     $ ' ',
     $ '   HELP command',
     $ ' ',
     $ 'for any Kermit command, e.g. ""HELP SEND"", to get more',
     $ 'detailed information about a specific command.  Type',
     $ ' ',
     $ '   HELP ?',
     $ ' ',
     $ 'to see a list of all the available help commands, or',
     $ 'consult the Kermit Users Guide.',
     $ ' '/
      INTEGER      LMES140         ;PARAMETER (LMES140 =  6 )
      CHARACTER*63 MES140(LMES140)
     $ /' ',
     $  'BYE',
     $ ' ',
     $ 'This command sends a message to the remote server to log',
     $ 'itself out',
     $ ' '/
      INTEGER      LMES150         ;PARAMETER (LMES150 =  6 )
      CHARACTER*63 MES150 (LMES150)
     $/' ',
     $ 'FINISH',
     $ ' ',
     $ 'This command causes the remote server to shut itself down',
     $ 'leaving the local KERMIT at KERMIT command level.',
     $ ' '/
      INTEGER      LMES160         ;PARAMETER (LMES160 =3 )
      CHARACTER*63 MES160 (LMES160)
     $/' ',
     $ 'This command is cannot be used on this version of KERMIT.',
     $ ' '/
      INTEGER      IDX             !index of code
C
      INTEGER      MATCH           !command parser
C
      IDX = MATCH(HLPCMDS,MAXHLPS,.TRUE.)
      IF (IDX .EQ. EOF .OR. IDX .EQ. ERROR) RETURN
      IF (IDX .EQ. 0) GOTO 50
      GOTO ( 140,40, 60, 150,20, 130, 50, 60, 30, 10, 90,
     $      100, 110, 120, 70, 60) IDX
 10   CONTINUE                     !send
        CALL OUTTBL(MES10, 1, LMES10)
        GOTO 200
 20   CONTINUE                     !get
        IF (.NOT. LOCALON) GOTO 160
        CALL OUTTBL(MES20, 1, LMES20)
        GOTO 200
 30   CONTINUE                     !receive
        CALL OUTTBL(MES30, 1, LMES30)
        GOTO 200
 40   CONTINUE                     !connect
        IF (.NOT. LOCALON) GOTO 160
        CALL OUTTBL(MES40, 1, LMES40)
        GOTO 200
 50   CONTINUE                     !kermit
        CALL OUTTBL(MES50, 1, LMES50)
        GOTO 200
 60   CONTINUE                     !exit
        CALL OUTTBL(MES60, 1, LMES60)
        GOTO 200
 70   CONTINUE                     !take
        CALL OUTTBL(MES70, 1, LMES70)
        GOTO 200
 90   CONTINUE                     !server
        CALL OUTTBL(MES90, 1, LMES90)
        GOTO 200
 100  CONTINUE                     !set
        CALL OUTTBL(MES100, 1, LMES100)
        GOTO 200
 110  CONTINUE                     !show
        CALL OUTTBL(MES110, 1, LMES110)
        GOTO 200
 120  CONTINUE                     !status
        CALL OUTTBL(MES120, 1, LMES120)
        GOTO 200
 130  CONTINUE                     !help
        CALL OUTTBL(MES130, 1, LMES130)
        GOTO 200
 140  CONTINUE                     !bye
        IF (.NOT. LOCALON) GOTO 160
        CALL OUTTBL(MES140, 1, LMES140)
        GOTO 200
 150  CONTINUE                     !finish
        IF (.NOT. LOCALON) GOTO 160
        CALL OUTTBL(MES150, 1, LMES150)
        GOTO 200
 160  CONTINUE                     !no local
        CALL OUTTBL(MES160, 1, LMES160)
        GOTO 200
 200  CONTINUE
      RETURN
      END
      LOGICAL FUNCTION MORE()
           IMPLICIT NONE
C
C= Returns true if continue, else false
C
      INCLUDE      'KDEF.INS'
C
      INTEGER      INCHR
C
      INTEGER      GETC
C
      CALL FLUSH(STDIN)
      CALL STTY(STDIN, 'READSIZE', 1)
      CALL PRINTL(STDOUT, 'Enter CR for more')
      MORE = GETC(STDIN, INCHR) .EQ. NEL
      CALL STTY(STDIN, 'READSIZE', 80)
      RETURN
      END
      INTEGER FUNCTION RECEIVE(ISTATE)
            IMPLICIT NONE
            INTEGER    ISTATE      !state to start at
C
C= Receive a file state switching routine.
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KDBUG.COM'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KPACK.COM'
      INCLUDE      'KMSG.COM'
C
      INTEGER      MM,DD,YY, HR, MIN, SEC
      INTEGER      MSG(MAXPACK)
      INTEGER      I
C
      INTEGER      RINIT
      INTEGER      RDATA
      INTEGER      RFILE
      INTEGER      SLEN            !length of string
      INTEGER      ICHAR           !character to integer
C
C
C initialize statistics variables
C
      CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
      STARTIM = HR*3600 + MIN*60 + SEC
      SCHCNT = 0
      RCHCNT = 0
      SCHOVRH = 0
      RCHOVRH = 0
      TOTSDRC = 0
      TOTRTRY = 0
CLT 2.3 ZERO ALL PREVIOUS ABORTS
      ABORTYP = .FALSE.
      IF (IFD .NE. STDIN) CALL PUTC(STDOUT, NEL)
C
C set packet retry count & current state
C
      NUMTRY = 0
      STATE = ISTATE
C
C take appropriate action for the current state
C
      CALL MONSDRC(STATE)
 10   CONTINUE
      IF (STATE .EQ. D) THEN
        STATE = RDATA()
      ELSE IF (STATE .EQ. F) THEN
        STATE = RFILE()
      ELSE IF (STATE .EQ. R) THEN
        STATE = RINIT()
      ELSE IF (STATE .EQ. C) THEN
        CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
        ENDTIM = HR * 3600 + MIN * 60 + SEC
        RECEIVE = OK
        GOTO 90
      ELSE IF (STATE .EQ. A) THEN
        CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
        ENDTIM = HR * 3600 + MIN * 60 + SEC
        RECEIVE = ERROR
        IF (FFD .NE. 0) CALL CLOSE(FFD)
CLT 2.3 SHORTEN MESSAGE
        CALL GETEMSG(MSG)
        CALL SNDPACK(E, PACKNUM, SLEN(MSG), MSG)
        GOTO 90
      ELSE
        CALL PRTMSG(' Receive - state error = ',STATE)
        IF (FFD .NE. 0) CALL CLOSE(FFD)
        RECEIVE = ERROR
        GOTO 90
      ENDIF
      IF (DEBUG(DBGSTAT)) THEN
        CALL PUTC(DBGFD, STATE)
        CALL PUTINT(DBGFD, PACKNUM, 1)
        CALL PUTC(DBGFD, BLANK)
        IF (MOD(PACKNUM+1, 16) .EQ. 0) CALL PUTC(DBGFD, NEL)
      ENDIF
      GOTO 10
 90   CONTINUE                     !return
      CALL MONSDRC(STATE)
      RETURN
      END
      INTEGER FUNCTION RINIT()
           IMPLICIT NONE
C
C= Receive a send-init packet
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KDBUG.COM'
      INCLUDE      'KPROT.COM'
C
      INTEGER      PTYP
      INTEGER      NUM
C
      INTEGER      RDPACK
      INTEGER      SNDPAR
C
      IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
      NUMTRY = NUMTRY + 1
      IF (NUMTRY .GT. MAXRINI) THEN
        RINIT = A
        ABORTYP(TOOMANY) = .TRUE.
        ABORTYP(READING) = .TRUE.
        ABORTYP(INITERR) = .TRUE.
        RETURN
      ENDIF
C
C read a packet and hope for best
C
      PTYP = RDPACK(LEN, NUM, PACKET)
C
C is it a valid packet type
C
      IF (PTYP .EQ. S) THEN
        TOTSDRC = TOTSDRC + 1
        NUMTRY = 0
        CALL MONSDRC(F)
        PACKNUM = NUM
        CALL RDPARAM(PACKET)
        LEN = SNDPAR(PACKET)
        CALL SNDPACK(Y, NUM, LEN, PACKET)
        PACKNUM = MOD(PACKNUM+1, 64)
        RINIT = F
C
C did we get a checksum error
C
      ELSE IF (PTYP .EQ. ERROR) THEN
        RINIT = STATE
        CALL MONSDRC(STATE)
        CALL SNDPACK(N, NUM, 0, 0)
      ELSE
        RINIT = A
        ABORTYP(INVALID) = .TRUE.
        ABORTYP(READING) = .TRUE.
        ABORTYP(INITERR) = .TRUE.
      ENDIF
      RETURN
      END
      INTEGER FUNCTION RFILE()
            IMPLICIT NONE
C
C= Read a filename packet
C
C  Rfile expects to see a filename (type f) packet.  However it may
C  find a send-init retry, end-of-file retry or break packet.
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KDBUG.COM'
      INCLUDE      'KPROT.COM'
C
      INTEGER      PTYP
      INTEGER      NUM
C
      INTEGER      RDPACK
      INTEGER      SNDPAR
      INTEGER      GETFILE
C
      IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
      NUMTRY = NUMTRY + 1
      IF (NUMTRY .GT. MAXRTRY) THEN
        RFILE = A
        ABORTYP(TOOMANY) = .TRUE.
        ABORTYP(READING) = .TRUE.
        ABORTYP(FILERR) = .TRUE.
        RETURN
      ENDIF
C
C read a packet
C
      PTYP = RDPACK(LEN, NUM, PACKET)
C
C is it a filename packet?
C
      IF (PTYP .EQ. F) THEN
        IF (NUM .NE. PACKNUM) THEN
          RFILE = A
          ABORTYP(SEQERR) = .TRUE.
          ABORTYP(READING) = .TRUE.
          ABORTYP(FILERR) = .TRUE.
          RETURN
        ENDIF
        IF (DEBUG(DBGON)) THEN
          CALL PRINTL(DBGFD, 'Receiving file ')
          CALL PUTSTR(DBGFD, PACKET)
          CALL FLUSH(DBGFD)
        ENDIF
        FFD = GETFILE(PACKET)
        IF (FFD .LE. 0) THEN
          FFD = 0
          RFILE = A
          ABORTYP(LCLFILE) = .TRUE.
          ABORTYP(READING) = .TRUE.
          ABORTYP(FILERR) = .TRUE.
        ELSE
          NUMTRY = 0
          TOTSDRC = TOTSDRC + 1
          CALL MONSDRC(D)
          CALL STRCPY(PACKET, FILESTR)
          CALL SNDPACK(Y, NUM, 0, 0)
          PACKNUM = MOD(PACKNUM+1, 64)
          RFILE = D
        ENDIF
C
C is it an old send-init packet?
C
      ELSE IF (PTYP .EQ. S) THEN
        IF (MOD(NUM+1, 64) .EQ. PACKNUM) THEN
          NUMTRY = 0
          TOTSDRC = TOTSDRC + 1
          CALL MONSDRC(STATE)
          LEN = SNDPAR(PACKET)
          CALL SNDPACK(Y, NUM, LEN, PACKET)
          RFILE = STATE
        ELSE
          RFILE = A
          ABORTYP(SEQERR) = .TRUE.
          ABORTYP(READING) = .TRUE.
          ABORTYP(INITERR) = .TRUE.
        ENDIF
C
C is it an old eof packet
C
      ELSE IF (PTYP .EQ. Z) THEN
        IF (MOD(NUM+1, 64) .EQ. PACKNUM) THEN
          NUMTRY = 0
          TOTSDRC = TOTSDRC + 1
          CALL MONSDRC(STATE)
          CALL SNDPACK(Y, NUM, 0, 0)
          RFILE = STATE
        ELSE
          RFILE = A
          ABORTYP(SEQERR) = .TRUE.
          ABORTYP(READING) = .TRUE.
          ABORTYP(INITERR) = .TRUE.
        ENDIF
C
C is it a break packet?
C
      ELSE IF (PTYP .EQ. B) THEN
        IF (NUM .NE. PACKNUM) THEN
          RFILE = A
          ABORTYP(SEQERR) = .TRUE.
          ABORTYP(READING) = .TRUE.
          ABORTYP(BRKERR) = .TRUE.
        ELSE
          NUMTRY = 0
          TOTSDRC = TOTSDRC + 1
          CALL MONSDRC(C)
          CALL SNDPACK(Y, PACKNUM, 0, 0)
          RFILE = C
        ENDIF
C
C did we get a checksum error
C
      ELSE IF (PTYP .EQ. ERROR) THEN
        RFILE = STATE
        CALL MONSDRC(STATE)
        CALL SNDPACK(N, NUM, 0, 0)
C
C invalid packet type
C
      ELSE
        RFILE = A
        ABORTYP(INVALID) = .TRUE.
        ABORTYP(READING) = .TRUE.
        ABORTYP(FILERR) = .TRUE.
      ENDIF
      RETURN
      END
      INTEGER FUNCTION RDATA()
           IMPLICIT NONE
C
C= Read a data packet
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KDBUG.COM'
      INCLUDE      'KPROT.COM'
C
C
C check retry count
C
      INTEGER      PTYP
      INTEGER      NUM
C
      INTEGER      RDPACK
C
      IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
      NUMTRY = NUMTRY + 1
      IF (NUMTRY .GT. MAXRTRY) THEN
        RDATA = A
        ABORTYP(TOOMANY) = .TRUE.
        ABORTYP(READING) = .TRUE.
        ABORTYP(DATAERR) = .TRUE.
        RETURN
      ENDIF
C
C read a packet
C
      PTYP = RDPACK(LEN, NUM, PACKET)
C
C did we get a data packet
C
      IF (PTYP .EQ. D) THEN
        IF (NUM .NE. PACKNUM) THEN
          IF (MOD(NUM+1, 64) .EQ. PACKNUM) THEN
            CALL MONSDRC(STATE)
            CALL SNDPACK(Y, NUM, 0, 0)
            RDATA = STATE
          ELSE
            RDATA = A
            ABORTYP(SEQERR) = .TRUE.
            ABORTYP(READING) = .TRUE.
            ABORTYP(DATAERR) = .TRUE.
          ENDIF
        ELSE
          TOTSDRC = TOTSDRC + 1
          CALL MONSDRC(STATE)
          CALL BUFEMP(PACKET, FFD, LEN)
          CALL SNDPACK(Y, PACKNUM, 0, 0)
          NUMTRY = 0
          PACKNUM = MOD(PACKNUM+1, 64)
          RDATA = STATE
        ENDIF
C
C is it an old filename packet
C
      ELSE IF (PTYP .EQ. F) THEN
        IF (MOD(NUM+1, 64) .EQ. PACKNUM) THEN
          TOTSDRC = TOTSDRC + 1
          CALL MONSDRC(STATE)
          CALL SNDPACK(Y, NUM, 0, 0)
          NUMTRY = 0
          RDATA = STATE
        ELSE
          RDATA = A
          ABORTYP(SEQERR) = .TRUE.
          ABORTYP(READING) = .TRUE.
          ABORTYP(FILERR ) = .TRUE.
        ENDIF
C
C is it an eof packet
C
      ELSE IF (PTYP .EQ. Z) THEN
        IF (NUM .NE. PACKNUM) THEN
          RDATA = A
          ABORTYP(SEQERR) = .TRUE.
          ABORTYP(READING) = .TRUE.
          ABORTYP(EOFERR ) = .TRUE.
        ELSE
          TOTSDRC = TOTSDRC + 1
          CALL MONSDRC(F)
          CALL SNDPACK(Y, PACKNUM, 0, 0)
          CALL CLOSE(FFD)
          FFD =  0
          PACKNUM = MOD(PACKNUM+1,64)
          NUMTRY = 0
          RDATA = F
        ENDIF
      ELSE IF (PTYP .EQ. ERROR) THEN
        RDATA = STATE
        CALL MONSDRC(STATE)
        CALL SNDPACK(N, NUM, 0, 0)
      ELSE
        RDATA = A
        ABORTYP(INVALID) = .TRUE.
        ABORTYP(READING) = .TRUE.
        ABORTYP(DATAERR) = .TRUE.
      ENDIF
      RETURN
      END
      INTEGER FUNCTION SEND()
           IMPLICIT NONE
C
C= Send file state swithcing routine
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KDBUG.COM'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KPACK.COM'
      INCLUDE      'KMSG.COM'
C
      INTEGER      MM,DD,YY, HR, MIN, SEC
      INTEGER      I
      INTEGER      MSG(MAXPACK)
C
      INTEGER      SLEN
      INTEGER      SDATA
      INTEGER      SFILE
      INTEGER      SEOF
      INTEGER      SBREAK
      INTEGER      SINIT
      INTEGER      ICHAR
C
C
C initialize statics variables
C
      CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
      STARTIM = HR * 3600 + MIN * 60 + SEC
      SCHCNT = 0
      RCHCNT = 0
      SCHOVRH = 0
      RCHOVRH = 0
      STATE = S
      NUMTRY = 0
      TOTSDRC = 0
      TOTRTRY = 0
CLT 2.3 CLEAR ALL PREVIOUS ABORT MESSAGES
      ABORTYP = .FALSE.
      IF (IFD .NE. STDIN) CALL PUTC(STDOUT, NEL)
C
C take appropriate action for the current state
C
 10   CONTINUE
      CALL MONSDRC(STATE)
      IF (STATE .EQ. D) THEN
        STATE = SDATA()
      ELSE IF (STATE .EQ. F) THEN
        STATE = SFILE()
      ELSE IF (STATE .EQ. Z) THEN
        STATE = SEOF()
      ELSE IF (STATE .EQ. S) THEN
        STATE = SINIT()
      ELSE IF (STATE .EQ. B) THEN
        STATE = SBREAK()
      ELSE IF (STATE .EQ. C) THEN
        CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
        ENDTIM = HR * 3600 + MIN * 60 + SEC
        SEND = OK
        GOTO 90
      ELSE IF (STATE .EQ. A) THEN
        CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
        ENDTIM = HR * 3600 + MIN * 60 + SEC
        SEND = ERROR
        IF (FFD .NE. 0) CALL CLOSE(FFD)
CLT 2.3 SHORTEN ABORT MESSAGE
        CALL GETEMSG(MSG)
        CALL SNDPACK(E, PACKNUM, SLEN(MSG), MSG)
        GOTO 90
      ELSE
        CALL PRTMSG('Send - state error = ',STATE)
        SEND = ERROR
        IF (FFD .NE. 0) CALL CLOSE(FFD)
        GOTO 90
      ENDIF
      IF (DEBUG(DBGSTAT)) THEN
        CALL PUTC(DBGFD, STATE)
        CALL PUTINT(DBGFD, PACKNUM, 1)
        CALL PUTC(DBGFD, BLANK)
        IF (MOD(PACKNUM+1, 16) .EQ. 0) CALL PUTC(DBGFD, NEL)
      ENDIF
      GOTO 10
 90   CONTINUE
      CALL MONSDRC(STATE)
      RETURN
      END
      INTEGER FUNCTION SINIT()
           IMPLICIT NONE
C
C= send the send-init packet and wait for reply
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KDBUG.COM'
      INCLUDE      'KPROT.COM'
C
      INTEGER      PTYP
      INTEGER      NUM
      INTEGER      LEN
      CHARACTER*16 FILENAM
C
      INTEGER      OPEN
      INTEGER      RDPACK
      INTEGER      SNDPAR
C
      IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
      NUMTRY = NUMTRY + 1
      IF (NUMTRY .GT. MAXRINI) THEN
        SINIT = A
        ABORTYP(TOOMANY) = .TRUE.
        ABORTYP(SENDING) = .TRUE.
        ABORTYP(INITERR) = .TRUE.
        RETURN
      ENDIF
C
C send the send-init packet with the right info
C
      LEN = SNDPAR(PACKET)
      CALL SNDPACK(S, PACKNUM, LEN, PACKET)
C
C pick up and process reply
C
      PTYP = RDPACK(LEN, NUM, RECPACK)
      IF (PTYP .EQ. N) THEN
        SINIT = STATE
        RETURN
      ELSE IF (PTYP .EQ. Y) THEN
        IF (PACKNUM .NE. NUM) THEN
          SINIT = STATE
          RETURN
        ENDIF
        CALL RDPARAM(RECPACK)
        TOTSDRC = TOTSDRC + 1
        NUMTRY = 0
        PACKNUM = MOD(PACKNUM+1,64)
        CALL AS2DPC (FILESTR, FILENAM)
        CALL FILCHK(FILENAM)
        FFD = OPEN(FILENAM, 'R')
CLT 2.3 FLAG UNABLE TO OPEN FILE
        IF (FFD .LE. 0) THEN
          SINIT = A
          ABORTYP(LCLFILE) = .TRUE.
          ABORTYP(SENDING) = .TRUE.
          ABORTYP(FILERR) = .TRUE.
        ELSE
          SINIT = F
        ENDIF
      ELSE IF (PTYP .EQ. ERROR) THEN
        SINIT = STATE
      ELSE
        SINIT = A
        ABORTYP(INVALID) = .TRUE.
        ABORTYP(SENDING) = .TRUE.
        ABORTYP(INITERR) = .TRUE.
      ENDIF
      RETURN
      END
      INTEGER FUNCTION SFILE()
           IMPLICIT NONE
C
C= Send a filename packet and wait for reply
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KDBUG.COM'
      INCLUDE      'KPROT.COM'
C
      INTEGER      PTYP
      INTEGER      NUM
C
      INTEGER      RDPACK
      INTEGER      BUFFIL
      INTEGER      SLEN
C
C
C have we tried this too many times?
C
      IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
      NUMTRY = NUMTRY + 1
      IF (NUMTRY .GT. MAXRTRY) THEN
        SFILE = A
        ABORTYP (TOOMANY) = .TRUE.
        ABORTYP(SENDING) = .TRUE.
        ABORTYP(FILERR) = .TRUE.
        RETURN
      ENDIF
C
C send a filename packet
C
      CALL SNDPACK(F, PACKNUM, SLEN(FILESTR), FILESTR)
C
C check on the reply
C
      PTYP = RDPACK(LEN, NUM, RECPACK)
      IF (PTYP .EQ. N) THEN
        IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
          SFILE = STATE
          RETURN
         ELSE
          PTYP = Y
          NUM = NUM - 1
        ENDIF
      ENDIF
      IF (PTYP .EQ. Y) THEN
        IF (PACKNUM .NE. NUM) THEN
          SFILE = STATE
          RETURN
        ENDIF
        TOTSDRC = TOTSDRC + 1
        NUMTRY = 0
        PACKNUM = MOD(PACKNUM+1,64)
C
C get first packet of data from the file
C
        PSIZE = BUFFIL(FFD, PACKET)
        SFILE = D
      ELSE IF (PTYP .EQ. ERROR) THEN
        SFILE = STATE
      ELSE
        SFILE = A
        ABORTYP(INVALID) = .TRUE.
        ABORTYP(SENDING) = .TRUE.
        ABORTYP(FILERR) = .TRUE.
      ENDIF
      RETURN
      END
      INTEGER FUNCTION SDATA()
           IMPLICIT NONE
C
C= Send a data packet and wait for reply
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KDBUG.COM'
      INCLUDE      'KPROT.COM'
C
      INTEGER      PTYP
      INTEGER      NUM
      INTEGER      LEN
C
      INTEGER      RDPACK
      INTEGER      BUFFIL
C
C
C have we tried this too many times
C
      IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
      NUMTRY = NUMTRY + 1
      IF (NUMTRY .GT. MAXRTRY) THEN
        SDATA = A
        ABORTYP (TOOMANY) = .TRUE.
        ABORTYP(SENDING) = .TRUE.
        ABORTYP(DATAERR) = .TRUE.
        RETURN
      ENDIF
C
C send the current data buffer
C
      IF (PSIZE .EQ. EOF) THEN
        SDATA = Z
        RETURN
      ENDIF
      CALL SNDPACK(D, PACKNUM, PSIZE, PACKET)
C
C check on the reply
C
      PTYP = RDPACK(LEN, NUM, RECPACK)
      IF (PTYP .EQ. N) THEN
        IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
          SDATA = STATE
          RETURN
        ELSE
          PTYP = Y
          NUM = NUM - 1
        ENDIF
      ENDIF
      IF (PTYP .EQ. Y) THEN
        IF (PACKNUM .NE. NUM) THEN
          SDATA = STATE
          RETURN
        ENDIF
        TOTSDRC = TOTSDRC + 1
        NUMTRY = 0
        PACKNUM = MOD (PACKNUM+1,64)
        PSIZE = BUFFIL(FFD, PACKET)
        IF (PSIZE .EQ. EOF) THEN
          SDATA = Z
        ELSE
          SDATA = STATE
        ENDIF
      ELSE IF (PTYP .EQ. ERROR) THEN
        SDATA = STATE
      ELSE
        SDATA = A
        ABORTYP(INVALID) = .TRUE.
        ABORTYP(SENDING) = .TRUE.
        ABORTYP(DATAERR) = .TRUE.
      ENDIF
      RETURN
      END
      INTEGER FUNCTION SEOF()
           IMPLICIT NONE
C
C= Send an eof packet and wait for reply
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KDBUG.COM'
      INCLUDE      'KPROT.COM'
C
      INTEGER      PTYP
      INTEGER      NUM
      INTEGER      LEN
C
      INTEGER      RDPACK
C
C
C have we tried this too many times
C
      IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
      NUMTRY = NUMTRY + 1
      IF (NUMTRY .GT. MAXRTRY) THEN
        SEOF  = A
        ABORTYP (TOOMANY) = .TRUE.
        ABORTYP(SENDING) = .TRUE.
        ABORTYP(EOFERR) = .TRUE.
        RETURN
      ENDIF
C
C send the eof packet
C
      CALL SNDPACK(Z, PACKNUM, 0, 0)
C
C check the reply
C
      PTYP = RDPACK(LEN, NUM, RECPACK)
      IF (PTYP .EQ. N) THEN
        IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
          SEOF = STATE
          RETURN
        ELSE
          PTYP = Y
          NUM = NUM -1
        ENDIF
      ENDIF
      IF (PTYP .EQ. Y) THEN
        IF (PACKNUM .NE. NUM) THEN
          SEOF = STATE
          RETURN
        ENDIF
        TOTSDRC = TOTSDRC + 1
        NUMTRY = 0
        PACKNUM = MOD(PACKNUM+1,64)
        CALL CLOSE(FFD)
        SEOF = B
      ELSE IF (PTYP .EQ. ERROR) THEN
        SEOF = STATE
      ELSE
        SEOF = A
        ABORTYP(INVALID) = .TRUE.
        ABORTYP(SENDING) = .TRUE.
        ABORTYP(EOFERR) = .TRUE.
      ENDIF
      RETURN
      END
      INTEGER FUNCTION SBREAK()
          IMPLICIT NONE
C
C= Send the break packet and wait for reply
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KDBUG.COM'
      INCLUDE      'KPROT.COM'
C
      INTEGER      PTYP
      INTEGER      NUM
      INTEGER      LEN
C
      INTEGER      RDPACK
C
C
C have we tried this too many times
C
      IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
      NUMTRY = NUMTRY + 1
      IF (NUMTRY .GT. MAXRTRY) THEN
        SBREAK = A
        ABORTYP (TOOMANY) = .TRUE.
        ABORTYP(SENDING) = .TRUE.
        ABORTYP(BRKERR) = .TRUE.
        RETURN
      ENDIF
C
C send the break packet
C
      CALL SNDPACK(B, PACKNUM, 0, 0)
C
C check on the reply
C
      PTYP = RDPACK(LEN, NUM, RECPACK)
      IF (PTYP .EQ. N) THEN
        IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
          SBREAK = STATE
          RETURN
        ELSE
          PTYP = Y
          NUM = NUM - 1
        ENDIF
      ENDIF
      IF (PTYP .EQ. Y) THEN
        IF (PACKNUM .NE. NUM) THEN
          SBREAK = STATE
          RETURN
        ENDIF
        TOTSDRC = TOTSDRC + 1
        NUMTRY = 0
        PACKNUM = MOD(PACKNUM+1,64)
        SBREAK = C
      ELSE IF (PTYP .EQ. ERROR) THEN
        SBREAK = STATE
      ELSE
        SBREAK = A
        ABORTYP(INVALID) = .TRUE.
        ABORTYP(SENDING) = .TRUE.
        ABORTYP(BRKERR) = .TRUE.
      ENDIF
      RETURN
      END
      SUBROUTINE MONSDRC(ISTATE)
           IMPLICIT NONE
           INTEGER   ISTATE
C
C= Monitor send or receive transaction
C
      INCLUDE 'KDEF.INS'
      INCLUDE 'KPROT.COM'
      INCLUDE      'KDBUG.COM'
C
      IF (STDIN .NE. IFD) THEN
        CALL PUTC(STDOUT, CR)
        IF (DEBUG(DBGSTAT)) THEN
          CALL PRINT(STDOUT, 'State ')
          CALL PUTC(STDOUT, ISTATE)
        ENDIF
        CALL PRINT(STDOUT, ' Receive ')
        CALL PUTINT(STDOUT, TOTSDRC, 3)
        CALL PRINT(STDOUT, ' Retry ')
        CALL PUTINT(STDOUT, TOTRTRY, 3)
        CALL FLUSH(STDOUT)
      ENDIF
      RETURN
      END
      SUBROUTINE SNDPACK(TYPE, NUM, LEN, DATA)
           IMPLICIT NONE
           INTEGER   TYPE          !type of packet
           INTEGER   NUM           !packet number
           INTEGER   LEN           !length of packet
           INTEGER   DATA(LEN)     !packet to send
C
C= Send a packet down an output stream
C
C  Sndpack will send a packet of information and log it
C  if debug is turned on.  This subroutine could be made
C  more efficient by not calling a subroutine for each
C  character, but that might cause portability problems.
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KDBUG.COM'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KPACK.COM'
C
      INTEGER      I
      INTEGER      CHKSUM          ! com puted checksum
      INTEGER      TMP
      INTEGER      NCH             !number of characters
C
      INTEGER      TOCHAR
      INTEGER      CHKSUMER      !find checksum
C
      IF (DEBUG(DBGPACK)) THEN
        CALL PRINTL(DBGFD, 'Sending...')
      ENDIF
C
C put out pad chars
C
      DO I=1, SPAD
        CALL PUTC(OFD, SPADCH)
        IF (DEBUG(DBGPACK)) THEN
          CALL PUTC(DBGFD, SPADCH)
        ENDIF
      ENDDO
      CALL PUTC(OFD, SNDSYNC)
C
C packet len assumes one character checksums
C
      CHKSUM = TOCHAR(LEN+3)
      CALL PUTC(OFD, CHKSUM)
      TMP = TOCHAR(NUM)
      CHKSUM = CHKSUM + TMP
      CALL PUTC(OFD, TMP)
      CHKSUM = CHKSUM + TYPE
      CALL PUTC(OFD, TYPE)
      DO I=1, LEN
        CHKSUM = CHKSUM + DATA(I)
        CALL PUTC(OFD, DATA(I))
      ENDDO
      CHKSUM = CHKSUMER(CHKSUM)
      CALL PUTC(OFD, TOCHAR(CHKSUM))
      CALL PUTC(OFD, SPEOL)
      IF (DEBUG(DBGPACK)) THEN
        CALL PUTC(DBGFD, SNDSYNC)
        CALL PUTC(DBGFD, TOCHAR(LEN+3))
        CALL PUTC(DBGFD, TOCHAR(NUM))
        CALL PUTC(DBGFD, TYPE)
        IF (LEN .GT. 0) CALL PUTSTR(DBGFD, DATA)
        CALL PUTC(DBGFD, TOCHAR(CHKSUM))
        CALL PUTC(DBGFD, SPEOL)
        CALL FLUSH(DBGFD)
      ENDIF
C
C force buffer flush since desired eol char won't
C
      CALL FLUSH(OFD)
C
C update the statistics
C
      NCH = SPAD + 5 + LEN + 1
      SCHCNT = SCHCNT + NCH
      SCHOVRH = SCHOVRH + NCH - LEN
      RETURN
      END
      INTEGER FUNCTION RDPACK(LEN, NUM, DATA)
           IMPLICIT NONE
           INTEGER   LEN           !length of packet read
           INTEGER   NUM           !packet number
           INTEGER   DATA(*)       !data read
C
C= Read a packet of information
      INCLUDE      'KDEF.INS'
      INCLUDE      'KDBUG.COM'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KPACK.COM'
      LOGICAL      BREAK
      COMMON /BREAK/BREAK
C
      INTEGER      CHKSUM
      INTEGER      FIELD
      INTEGER      NCH
      INTEGER      CH
      INTEGER      TYPE
      INTEGER      I
      INTEGER      STIME           !start time
      INTEGER      FTIME           !finish time
C
      INTEGER      GETC
      INTEGER      UNCHAR
      INTEGER      CHKSUMER      !compute checksum
C
C debug
C
      IF (DEBUG(DBGPACK)) THEN
        CALL PRINTL(DBGFD, 'Reading...')
      ENDIF
      NCH = 0
C
C hunt for start of packet
C
      LEN = 0
      CHKSUM = 0
      CALL MSEC(STIME)
      BREAK = .FALSE.
 10   CONTINUE
      CALL MSEC(FTIME)
      IF ((FTIME-STIME)/1000 .GT. TIMEOUT .OR. BREAK) THEN
        IF (DEBUG(DBGPACK)) THEN
          IF (BREAK) THEN
            CALL PRINTL(DBGFD, 'BREAK TIMEOUT')
          ELSE
            CALL PRINTL(DBGFD, 'TIMEOUT')
          ENDIF
        ENDIF
        RDPACK = ERROR
        GOTO 30       !RETURN
      ENDIF
      CH = GETC(IFD, CH)
      IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, CH)
      IF (CH .EQ. ERROR) THEN
        GOTO 10
      ENDIF
      NCH = NCH + 1
CLT   IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, CH)
      IF (CH .NE. SYNC) GOTO 10
C
C parse each field of the packet
C
      FIELD = 1
 20   CONTINUE
      CALL MSEC(FTIME)
      IF ((FTIME-STIME)/1000 .GT. TIMEOUT .OR. BREAK) THEN
        RDPACK = ERROR
        GOTO 30       !RETURN
      ENDIF
      IF (FIELD .LE. 5) THEN
C
C a character read in field 4 here is the first char of the
C data field or the checksum character if the data field is
C empty
C
        IF (FIELD .NE. 5 .OR. LEN .GT. 0) THEN
          IF (GETC(IFD, CH) .EQ. SYNC) FIELD = 0
          NCH = NCH + 1
          IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, CH)
        ENDIF
        IF (FIELD .LE. 3) CHKSUM = CHKSUM + CH
C
C if resync
C
        IF (FIELD .EQ. 0) THEN
          CHKSUM = 0
          IF (DEBUG(DBGPACK)) THEN
            CALL PRINTL(DBGFD, 'Reading...')
            CALL PUTC(DBGFD, SYNC)
          ENDIF
C
C if data length
C
        ELSE IF (FIELD .EQ. 1) THEN
          LEN = UNCHAR(CH-3)
C
C if pack number
C
        ELSE IF (FIELD .EQ. 2) THEN
          NUM = UNCHAR(CH)
C
C if packet type
C
        ELSE IF (FIELD .EQ. 3) THEN
          TYPE = CH
C
C if data field is not empty
C
        ELSE IF (FIELD .EQ. 4 .AND. LEN .GT. 0) THEN
C
C read 2nd-len chars of data & checksum char
C
          DO I=1, LEN
            CALL MSEC(FTIME)
            IF ((FTIME-STIME)/1000 .GT. TIMEOUT .OR. BREAK) THEN
              RDPACK = ERROR
              GOTO 30       !RETURN
            ENDIF
            IF (I .GT. 1) THEN
              CH = GETC(IFD, CH)
              NCH = NCH + 1
              IF (CH .EQ. SYNC) THEN
                FIELD = 0
                GOTO 20
              ENDIF
              IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, CH)
            ENDIF
            CHKSUM = CHKSUM + CH
            DATA (I) = CH
          ENDDO
C
C if chksum char
C
        ELSE IF (FIELD .EQ. 5) THEN
          DATA(LEN+1) = 0
          CHKSUM = CHKSUMER(CHKSUM)
        ENDIF
C
C process next packet field
C
        FIELD = FIELD + 1
        GOTO 20
      ENDIF
      IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, NEL)
C
C does the checksum match
C
      IF (CHKSUM .NE. UNCHAR(CH)) THEN
        RDPACK = ERROR
        RCHOVRH = RCHOVRH + NCH
        IF (DEBUG(DBGON)) THEN
          CALL PRINTL(DBGFD, 'chksum error, found ')
          CALL PUTINT(DBGFD, UNCHAR(CH), 1)
          CALL PRINT(DBGFD, ' needed ')
          CALL PUTINT(DBGFD, CHKSUM, 1)
        ENDIF
      ELSE
        RDPACK = TYPE
        RCHOVRH = RCHOVRH + NCH - LEN
      ENDIF
      RCHCNT = RCHCNT + NCH
C
C flush any eol characters and other garbage
C
      CALL FLUSH(IFD)
 30   CONTINUE     !error exit
      IF (DEBUG(DBGON)) THEN
        CALL FLUSH(DBGFD)
      ENDIF
      RETURN
      END
      INTEGER FUNCTION BUFFIL(FD, BUFFER)
           IMPLICIT NONE
           INTEGER   FD            !file device
           INTEGER   BUFFER(*)     !buffer to fill
C
C= Get some data to send.
C
C BUFFIL READS FROM THE FILE TO SEND AND PERFORMS ALL
C THE PROPER ESCAPING OF CONTROL CHARACTERS AND MAPPING
C NEWLINES INTO CRLF SEQUENCES.  IF IT EVER GETS SMART
C ENOUGH, IT WILL ALSO DO THE 8 BIT QUOTING AND REPEAT
C COUNTS.
C
C *** NOTE: THIS ALGORTHM ASSUMES 5 OVERHEAD CHARACTERS FOR THE
C PACKET AND LEAVES 3 CHARACTERS IN CASE THE LAST CHARACTER TO
C BUFFER IS A NEL (EXPANDS TO 4 CHARACTERS).
      INCLUDE      'KDEF.INS'
      INCLUDE      'KDBUG.COM'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KPACK.COM'
C
      INTEGER      I
      INTEGER      CH
C
      INTEGER      GETC
      INTEGER      CTL             !control switch
C
C
C get a packet worth of data
C
      I = 0
 10   CONTINUE
      IF (GETC(FD, CH) .NE. EOF) THEN
        IF (CH .LT. BLANK .OR. CH .EQ. DEL .OR. CH .EQ. NEL .OR.
     $      CH .EQ. SPQUOTE) THEN
          IF (CH .EQ. NEL) THEN
            BUFFER(I+1) = SPQUOTE
            BUFFER(I+2) = CTL(CR)
            I = I + 2
            CH = LF
          ENDIF
          I = I + 1
          BUFFER(I) = SPQUOTE
          IF (CH .NE. SPQUOTE) CH = CTL(CH)
        ENDIF
        I = I + 1
        BUFFER(I) = CH
        IF (I .GE. SPKSIZ-8) THEN
          BUFFIL = I
          GOTO 99
        ENDIF
        GOTO 10
      ENDIF
      IF (I .EQ. 0) THEN
        BUFFIL = EOF
      ELSE
        BUFFIL = I
      ENDIF
 99   CONTINUE
      BUFFER(I+1) = 0
      RETURN
      END
      SUBROUTINE BUFEMP( BUFFER, FD, LEN)
           IMPLICIT NONE
           INTEGER  BUFFER(*)      !buffer to empty
           INTEGER  FD             !file descriptor
           INTEGER  LEN            !length of buffer to empty
C
C= dumps a buffer to a file
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KDBUG.COM'
      INCLUDE      'KPROT.COM'
      INCLUDE      'KPACK.COM'
C
      INTEGER      I
      INTEGER      PREVCH
      INTEGER      CH
C
      INTEGER      CTL
C
C
C write the packet data to the file
C
      I = 1
 10   CONTINUE
      IF (I .LE. LEN) THEN
        CH = BUFFER(I)
        IF (CH .EQ. QUOTECH) THEN
          I = I + 1
          CH = BUFFER(I)
          IF (CH .NE. QUOTECH) CH = CTL(CH)
        ENDIF
C
C convert cr/lf pair to NEL
C
        IF (CH .EQ. LF .AND. PREVCH .EQ. CR) THEN
          CH = NEL
C
C just a lone cr
C
        ELSE IF (PREVCH .EQ. CR) THEN
          CALL PUTC(FD, PREVCH)
        ENDIF
        IF (CH .NE. CR) CALL PUTC(FD, CH)
        PREVCH = CH
        I = I + 1
        GOTO 10
      ENDIF
      RETURN
      END
      INTEGER FUNCTION CHKSUMER (SUM)
           IMPLICIT NONE
           INTEGER   SUM      !sum to find check sum of
C
C= Compute checksum for transmission
C
      INTEGER      HIGHBITS/X'C0'/  !mask for high bits
      INTEGER      SHIFTLOW /X'40'/ !make them low bits
      INTEGER      SIXBITS /X'3F'/  !return only six bits
C
      INTEGER      IAND            !and words together
C
      CHKSUMER = IAND (SUM + IAND (SUM,HIGHBITS) / SHIFTLOW,
     $           SIXBITS)
      RETURN
      END
      SUBROUTINE AS2DPC(ASTR,DSTR)
           IMPLICIT NONE
           INTEGER   ASTR(100)
           CHARACTER*(*)   DSTR

C= Translate ascii integer string to character string
C
C     ASCII STRING IS TERMINATED BY A ZERO BYTE.
C
C
      INTEGER            CLEN
      INTEGER      I
C
      CHARACTER*1  CHAR
      INTEGER      LEN
C
      I = 1
      CLEN = LEN(DSTR)
      DSTR = ' '
10    IF (ASTR(I) .NE. 0 .AND. I .LE. CLEN) THEN
         DSTR(I:I) = CHAR(ASTR(I))
         I = I + 1
         GO TO 10
      ENDIF
C
      RETURN
      END
      SUBROUTINE DPC2AS(DSTR,ASTR,N)
           IMPLICIT NONE
           CHARACTER*(*) DSTR
           INTEGER       ASTR(200)
           INTEGER       N
C
C= TRANSLATE STRING OF DISPLAY CODE CHARACTERS ASCII INTEGER STRING.
C  STRING IS N CHARACTERS (WORDS) LONG.
C
C
      INTEGER      I
C
      INTEGER      ICHAR
C
      DO I=1,N
         ASTR(I) = ICHAR(DSTR(I:I))
      ENDDO
C
C     SET ASCII END-OF-STRING-BUFFER
C
      ASTR(N+1) = 0
C
      RETURN
      END
      INTEGER FUNCTION CTOI(ASTR)
          IMPLICIT NONE
          INTEGER      ASTR(200)

C= CONVERT CHARACTER BUFFER TO INTEGER.
C
C   MC     A SUFFIX OF H WILL CONVERT USING BASE 16 AND A SUFFIX
C     OF O WILL CONVERT USING BASE 8.  DEFAULT SUFFIX IS
C     D.
C
      INCLUDE 'KDEF.INS'
      INTEGER      DIG0, DIG7, DIG9, BIGA, BIGB, BIGD
      INTEGER      BIGF, BIGH, BIGO, LETA, LETB, LETD
      INTEGER      LETF, LETH, LETO
      PARAMETER (DIG0=48, DIG7=55, DIG9=57, BIGA=65, BIGB=66, BIGD=68)
      PARAMETER (BIGF=70, BIGH=72, BIGO=79, LETA=97, LETB=98, LETD=100)
      PARAMETER (LETF=102, LETH=104, LETO=111)
      INTEGER      BASE
      INTEGER      PTR
      INTEGER      EOD
      INTEGER      CH
      INTEGER      TOTAL
      INTEGER      ISNEG
      INTEGER      I

      BASE = 0
      PTR = 0
C
C     FIND LAST VALID DIGIT
C
10    PTR = PTR + 1
      IF (ASTR(PTR) .NE. 0) GO TO 10
      PTR = PTR - 1
      IF (ASTR(PTR) .EQ. LETO .OR. ASTR(PTR) .EQ. BIGO .OR.
     +    ASTR(PTR) .EQ. LETB .OR. ASTR(PTR) .EQ. BIGB .OR.
     +    ASTR(PTR) .EQ. LETH .OR. ASTR(PTR) .EQ. BIGH) THEN
         EOD = PTR - 1
      ELSE
         EOD = PTR
         PTR = PTR + 1
      ENDIF
C
C     TRY TO FIGURE OUT THE BASE
C
      IF (ASTR(PTR) .EQ. 0) THEN
         BASE = 10
      ELSE IF (ASTR(PTR) .EQ. LETO .OR. ASTR(PTR) .EQ. BIGO .OR.
     +         ASTR(PTR) .EQ. LETB .OR. ASTR(PTR) .EQ. BIGB) THEN
         BASE = 8
      ELSE IF (ASTR(PTR) .EQ. LETH .OR. ASTR(PTR) .EQ. BIGH) THEN
         BASE = 16
      ENDIF
C
C     IF DIDN'T FIND A BASE
C
      IF (BASE .EQ. 0) THEN
         CALL PRINTL(STDOUT,'CTOI - Invalid base ')
         CALL PUTC(STDOUT, ASTR(PTR))
         CALL FLUSH(STDOUT)
         CTOI = 0
         RETURN
      ENDIF
C
C     ADD UP THE DIGITS
C
      TOTAL = 0
      ISNEG = 1
      DO 100 I = 1,EOD
         CH = ASTR(I)
         IF (CH .EQ. MINUS) THEN
            ISNEG = -1
            GO TO 100
         ENDIF
         IF (BASE .EQ. 10) THEN
            IF (CH .LT. DIG0 .OR. CH .GT. DIG9) THEN
               CALL PRINTL(STDOUT,'CTOI - Invalid decimal digit ')
               CALL PUTC(STDOUT, CH)
               CALL FLUSH(STDOUT)
               CTOI = 0
               RETURN
            ELSE
               CH = CH - DIG0
            ENDIF
         ELSE IF (BASE .EQ. 8) THEN
            IF (CH .LT. DIG0 .OR. CH .GT. DIG7) THEN
               CALL PRINTL(STDOUT,'CTOI - Invalid octal digit ')
               CALL PUTC(STDOUT, CH)
               CALL FLUSH(STDOUT)
               CTOI = 0
               RETURN
            ELSE
               CH = CH - DIG0
            ENDIF
         ELSE IF (BASE .EQ. 16) THEN
            IF (CH .GE. DIG0 .AND. CH .LE. DIG9) THEN
               CH = CH - DIG0
            ELSE IF (CH .GE. LETA .AND. CH .LE. LETF) THEN
               CH = 10 + CH - LETA
            ELSE IF (CH .GE. BIGA .AND. CH .LE. BIGF) THEN
               CH = 10 + CH - BIGA
            ELSE
               CALL PRINTL(STDOUT,'CTOI - Invalid hex digit ')
               CALL PUTC(STDOUT, CH)
               CALL FLUSH(STDOUT)
               CTOI = 0
               RETURN
            ENDIF
         ENDIF
         TOTAL = TOTAL*BASE + CH
100   CONTINUE
      CTOI = TOTAL * ISNEG
      RETURN
      END
      INTEGER FUNCTION ITOS(INT,STR,MINWID)
           IMPLICIT NONE
           INTEGER INT
           INTEGER STR(200)
           INTEGER MINWID

CCC   ITOS - CONVERT AN INTEGER TO STRING FORMAT.
C
      INCLUDE 'KDEF.INS'
      INTEGER      WIDTH
      INTEGER      VAL
      INTEGER      ASCII0
      INTEGER      TCH
      INTEGER      IPTR
      INTEGER      ENDPTR
C
      INTEGER      MOD
      INTEGER      ICHAR

      WIDTH = 0
      IF (INT .LT. 0) THEN
         WIDTH = 1
         STR(WIDTH) = ICHAR('-')
      ENDIF
      VAL = IABS(INT)
      ASCII0 = ICHAR('0')
10    WIDTH = WIDTH + 1
      STR(WIDTH) = MOD(VAL,10) + ASCII0
      VAL = VAL / 10
      IF (VAL .NE. 0) GO TO 10
      STR(WIDTH+1) = 0
C
C     NOW REVERSE THE DIGITS
C
      IPTR = 1
      ENDPTR = WIDTH
      IF (STR(IPTR) .EQ. ICHAR('-')) IPTR = IPTR + 1
20    IF (IPTR .LT. ENDPTR) THEN
         TCH = STR(IPTR)
         STR(IPTR) = STR(ENDPTR)
         STR(ENDPTR) = TCH
         IPTR = IPTR + 1
         ENDPTR = ENDPTR - 1
         GO TO 20
      ENDIF
      ITOS = WIDTH
      RETURN
      END
      INTEGER FUNCTION GETFILE(FN)
           IMPLICIT NONE
           INTEGER       FN(*)     !file name

C= Open a file for writing packet data to.
C
C     GETFILE WILL TRY TO CREATE A FILE TO WRITE TO.  IF IT
C     ALREADY EXISTS, THEN IT WILL FAIL.
C
      CHARACTER*56 FILENAM
C
      INTEGER      OPEN
C
      INCLUDE 'KDEF.INS'
C
C     GET THE DPC VERSION OF THE FILENAME
C
      CALL AS2DPC(FN,FILENAM)
      CALL FILCHK(FILENAM)
      GETFILE = OPEN(FILENAM, 'W')
      RETURN
      END
      SUBROUTINE GETNOW(MM,DD,YY,HR,MIN,SEC)
           IMPLICIT NONE
           INTEGER  MM,DD,YY
           INTEGER  HR,MIN,SEC

CCC   GET THE CURRENT DATE AND TIME.
C
      INTEGER      IDT(3)              !INTEGER DATE AND TIME
C
      CALL DATE(IDT)
      YY = IDT(1)
      MM = IDT(2)
      DD = IDT(3)
      CALL TIME(IDT)
      HR = IDT(1)
      MIN = IDT(2)
      SEC = IDT(3)
      RETURN
      END
      SUBROUTINE FILCHK(FN)
           IMPLICIT NONE
           CHARACTER *(*) FN
C
C= Check validity of filename, remove special characters
C
      INTEGER PTR,CH
      INTEGER      I
C
      INTEGER      LEN
      INTEGER      ICHAR
      CHARACTER*1  CHAR
C
      PTR = 1
      DO I=1, LEN(FN)
        IF (FN(I:I) .EQ. ' ') THEN
        ELSE IF(FN(I:I) .GE. 'A' .AND. FN(I:I) .LE. 'Z') THEN
          FN(PTR:PTR) = FN(I:I)
          PTR = PTR + 1
        ELSE IF (FN(I:I) .GE. '0' .AND. FN(I:I) .LE. '9' .AND.
     $           I .NE. 1) THEN
          FN(PTR:PTR) = FN(I:I)
          PTR = PTR + 1
        ELSE IF (FN(I:I) .GE. 'a' .AND. FN(I:I) .LE. 'z') THEN
          FN(PTR:PTR) = CHAR(ICHAR(FN(I:I)) - X'20')
          PTR = PTR + 1
        ELSE IF(FN(I:I) .EQ. '.' .OR. FN(I:I) .EQ. '*' .OR.
     $          FN(I:I) .EQ. '_') THEN
          FN(PTR:PTR) = FN(I:I)
          PTR = PTR + 1
        ENDIF
      ENDDO
      IF (PTR .LE. LEN(FN)) FN(PTR:) = ' '
      RETURN
      END
      SUBROUTINE RDPARAM(PDATA)
           IMPLICIT NONE
           INTEGER    PDATA (100)

C= Get the packet parameters from the other kermit
C
      INCLUDE 'KDEF.INS'
      INCLUDE 'KPACK.COM'
      INTEGER PARAMS(11)
      EQUIVALENCE (PARAMS,SPKSIZ)
      INTEGER      I
C
      INTEGER      CTL
      INTEGER      UNCHAR
C
C     CYCLE THROUGH THE LIST OF PARAMETERS UNTIL THE END-OF-LIST
C     IS FOUND (A 0 BYTE).
C     Must be loop because variable length reply
C
      I = 1
      DO WHILE (PDATA(I) .NE. 0 .AND. I .LE. 11)
C
C        IS IT THE PAD CHARACTER?
C
         IF (I .EQ. 4) THEN
            PARAMS(I) = CTL(PDATA(I))
            IF (PARAMS(I) .EQ. 0) PARAMS(I) = NULL
C
C        IS IT THE QUOTE CHARACTER?
C
         ELSE IF (I .EQ. 6) THEN
            PARAMS(I) = PDATA(I)
C
C all else
C
         ELSE
            IF (UNCHAR(PDATA(I)) .NE. 0) THEN
               PARAMS(I) = UNCHAR(PDATA(I))
            ENDIF
         ENDIF
         I = I + 1
      ENDDO
      RETURN
      END
      SUBROUTINE REMOVE(FN)
           IMPLICIT NONE
           INTEGER   FN(100)

C= Remove a file from the local file list.
C
      CHARACTER*56 FNAME

      CALL AS2DPC(FN,FNAME)
      OPEN(UNIT='TMP',FILE=FNAME)
      CLOSE(UNIT='TMP',STATUS='DELETE')
      RETURN
      END
      SUBROUTINE STRCPY(S1,S2)
           IMPLICIT NONE
           INTEGER S1(200),S2(200)

C= Copy one ascii string to another
C
      INTEGER      I1

      I1 = 1
10    S2(I1) = S1(I1)
      IF (S1(I1) .NE. 0) THEN
         I1 = I1 + 1
         GO TO 10
      ENDIF
      RETURN
      END
      INTEGER FUNCTION SLEN(STR)
           IMPLICIT NONE
           INTEGER   STR(200)

C= Return the length of a zero terminated ascii string buffer.
C
      INTEGER      I

      I = 0
10    IF (STR(I+1) .NE. 0) THEN
         I = I + 1
         GO TO 10
      ENDIF
      SLEN = I
      RETURN
      END
      INTEGER FUNCTION SNDPAR(PDATA)
           IMPLICIT NONE
           INTEGER PDATA(100)

C= Setup parameters to send to other kermit.
C
      INCLUDE 'KDEF.INS'
      INCLUDE 'KPACK.COM'
C
      INTEGER      I
      INTEGER      PARAMS(12)
        EQUIVALENCE (PARAMS, PACKSIZ)
C
      INTEGER      CTL
      INTEGER      TOCHAR
C
C     SEND WHAT WE WANT
C
      PDATA (1) = TOCHAR(PACKSIZ)
      PDATA (2) = TOCHAR(TIMEOUT)
      PDATA (3) = TOCHAR(NPAD)
      PDATA (4) = CTL(PADCH)
      PDATA (5) = TOCHAR(EOLCH)
      PDATA (6) = QUOTECH
      PDATA (7) = 0
C
C     RETURN LENGTH OF HOW MANY THINGS WE WANT TO SET
C
      SNDPAR = 6
      RETURN
      END
      SUBROUTINE SLEEP(SECONDS)
           IMPLICIT NONE
           INTEGER     SECONDS
CC
C     SLEEP - HOLD FOR <SECONDS> SECONDS.
C
      INTEGER      I

      DO 100 I=1,SECONDS
         CALL DELAY(1000)
100   CONTINUE
      RETURN
      END
      SUBROUTINE DELAY(MSEC)
           IMPLICIT NONE
           INTEGER  MSEC
C
C=    DELAY - HOLD THINGS UP FOR <MSEC> MILISECS.
C
C     **** THIS IS PROBABLY SYSTEM DEPENDENT CODE *****
C          IF YOU MODIFY IT USE CONDITIONAL COMPILATION
C
      INTEGER      IOS
C
      CALL WAIT(MSEC, 1, IOS)
      RETURN
      END
      INTEGER FUNCTION CTL (ASCCH)
           IMPLICIT NONE
           INTEGER  ASCCH
C
C= Flip control bit protecting control chars and unprotecting
C
      CTL = IEOR(ASCCH,X'40')
      RETURN
      END
      INTEGER FUNCTION TOCHAR(ASCCH)
           IMPLICIT NONE
           INTEGER  ASCCH
C
C= Make an ascii character.
C
      INCLUDE      'KDEF.INS'
C
      TOCHAR = ASCCH + BLANK
      RETURN
      END
      INTEGER FUNCTION UNCHAR(ASCCH)
           IMPLICIT NONE
           INTEGER   ASCCH
C
C= Convert back to control character
C
      INCLUDE      'KDEF.INS'
C
      UNCHAR = ASCCH - BLANK
      RETURN
      END
      SUBROUTINE GETMACH(MACH)
           IMPLICIT NONE
           CHARACTER*(*) MACH  !current machine type
C
C= Retrieves current machine type from os
C
      CHARACTER*2 MACHS(0:5)       !gould machines
     $ /'55','75','27','67','87','97'/
      INTEGER     IMACH            !read machine type
C
      INLINE
        LB         7,X'0CBF'       !get machine type code
        STW        7,IMACH         !store for use
      ENDI
      IF (IMACH .GE. 0 .AND. IMACH .LE. 5) THEN
        MACH = MACHS(IMACH)
      ELSE
        MACH = '**'
      ENDIF
      RETURN
      END
      SUBROUTINE PRTMSG(STR, VAL)
           IMPLICIT NONE
           CHARACTER*(*) STR
           INTEGER       VAL
C
C= Prints a message to output device (normally abort message)
C
 1000 FORMAT (X,A,I4)
      WRITE ('UT',1000,ERR=10) STR, VAL
 10   CONTINUE
      RETURN
      END
      SUBROUTINE DISPLAY (S)
           IMPLICIT NONE
           CHARACTER*(*) S
C
C= Display string on console
C
      INTEGER      WORD
      CHARACTER*80 STRING
        EQUIVALENCE (WORD, STRING) !word bound string
C
      STRING = S
      CALL CARRIAGE
      CALL M:TELEW(STRING)
      RETURN
      END
      INTEGER FUNCTION NOFIND (STRING,CHARN)
      IMPLICIT     NONE
C= Return position of 1st character in STRING that does not match CHARN.
C
C                            RETURN THE INDEX OF THE FIRST
C                            CHARACTER IN STRING THAT DOES
C                            NOT MATCH CHARN.
C                            RETURNS 0 IF THE STRINGS MATCH.
C
C                            FORMAL PARAMETER DECLARATIONS.
      CHARACTER*(*) STRING,CHARN
C
C                            LOCAL DECLARATIONS.
C
C                            LENGTH OF STRING PARAMETER.
      INTEGER STRLEN
C                            STRING SEARCH POINTER.
      INTEGER I
C                            LENGTH OF STRING FUNCTION
      INTRINSIC LEN

C
C-------------------------------------------------------------------
C
C                            FIND LENGTH OF INPUT STRING.
      STRLEN = LEN(STRING)
C                            PRESET FUNCTION VALUE TO INDICATE
C                            SEARCH FAILED TO FIND NON-CHARN
C                            CHARACTER.
      NOFIND = 0
C                            INITIALIZE STRING SEARCH POINTER.
      I=0
  10  CONTINUE
C                            POINT TO NEXT CHARACTER IN STRING
      I = I + 1
C                            BEYOND END OF STRING - SEARCH FAILED.
      IF( I .GT. STRLEN ) GO TO 20
C                            DO IT AGAIN IF THIS CHARACTER MATCHES.
      IF( STRING(I:I) .EQ. CHARN ) GO TO 10
C                            MISMATCH ENCOUNTERED - NOTE
C                            POSITION AND RETURN.
      NOFIND = I
C
  20  CONTINUE
C
      RETURN
      END
      INTEGER FUNCTION LASTCHR (STRING)
      IMPLICIT     NONE
C= Return position of last non-blank character in STRING.
C
C                            FIND THE LAST NON-BLANK CHARACTER
C                            IN THE INPUT STRING.
C
C
      CHARACTER*(*) STRING   ! GIVEN STRING
C
C     RETURNS LASTCHR        ! POSITION OF LAST NON-BLANK CHARACTER
C                                IN STRING
C
      INTEGER CHR
C
      INTEGER   LEN
      INTRINSIC LEN
C
      INTEGER     ZERO,ONE
      PARAMETER  (ZERO=0,ONE=1)
C     CHARACTER*1 BLANK
C     PARAMETER  (BLANK=' ')
C
C     REVISED 12/08/82, PDM.  CORRECT TREATMENT OF EMPTY LINE.
C
C------------------------------------------------------------------
C
C
      CHR = LEN(STRING) + ONE
  10  CONTINUE
           CHR = CHR - ONE
           IF (CHR.LE.ZERO) GOTO 20
      IF (STRING(CHR:CHR).EQ.' ') GOTO 10
20    CONTINUE
C
      LASTCHR = CHR
C
C
      RETURN
      END
      SUBROUTINE LADJ(STRING)
      IMPLICIT NONE
C= Left-justify a string.
C                            Left-justify a string.
C-------------------------------------------------------------------
C Written May 6, 1983 by Fred Preller, Simulation Associates, Inc.
C-------------------------------------------------------------------
      CHARACTER*(*) STRING
C-------------------------------------------------------------------
      INTEGER       FIRST    ! First non-blank character position
      CHARACTER*1   BLANK/' '/
C-------------------------------------------------------------------
      INTEGER   NOFIND
      EXTERNAL  NOFIND
C-------------------------------------------------------------------
      FIRST = NOFIND(STRING,BLANK)
C Note the criteria: FIRST = 0   => totally blank line, and
C                    FIRST = 1   => line already justified.
      IF( FIRST .GT. 1 ) STRING = STRING(FIRST:)
      RETURN
      END
      SUBROUTINE BREAKR
           IMPLICIT NONE
C= Establish break receiver
C
C BREAKR ESTABLISHES A BREAK RECEIVER THAT REMAINS ACTIVE AS
C LONG AS THE TASK IS ACTIVE.  WHEN A BREAK IS RECEIVED, THE
C BREAK FLAG IS SET.  THE USER MUST CLEAR THE FLAG TO ENSURE
C THAT SUBSEQUENT BREAKS ARE DETECTED.
C
      LOGICAL BREAK
      COMMON /BREAK/ BREAK
C
      CALL X:BRK ($100,,)
      BREAK = .FALSE.
      RETURN
C
C BREAK ENTRY POINT
 100  BREAK = .TRUE.
      CALL X:BRKXIT
C
      END
      SUBROUTINE SLINE(S)
          CHARACTER*(*)  S   !tsm line
C
C= Returns the tsm command line without the execution portion
C
      CHARACTER*236  BUFF   !local buffer
      INTEGER      NRESV    !number of reserved words
        PARAMETER (NRESV = 5)
      CHARACTER*8 RWORDS(NRESV)          !reserved pre words
     $   /'RUN', 'EXECUTE ', 'EXEC', 'DEBU', 'DEBUG'/
      CHARACTER*8  R                   !reserved word
      INTEGER   OUT/'OUT'/
      CHARACTER*1  D                   !delimitor
C
C SLINE
C
      CALL TLINE(BUFF)                 !get tsm command line
      CALL LADJ(BUFF)
C
C remove leading '$'
C
      IF (BUFF(1:1) .EQ. '$') THEN
        BUFF = BUFF(2:)
      END IF
      CALL EXTR(R, D, BUFF)               !possible task name/reserved
C
C get rid of leading reserved words
C
      DO 20,I=1, NRESV
        IF (R .EQ. RWORDS(I)) THEN
          CALL EXTR(R, D, BUFF)         !get task path
          LEAVE 20
        END IF
 20   END DO
C
C check for dsc name
C
      IF (R(1:1) .EQ. '@' .OR. R(1:1) .EQ. '^' .OR. D .EQ. '(') THEN
        CALL EXTR(R, D, BUFF)          !extract directory
        CALL EXTR(R, D, BUFF)          !task name
      END IF
C
C return remander without task name
C
      S = BUFF
      RETURN
      END
      SUBROUTINE EXTR(R, D, S)
           CHARACTER*(*) R             !extracted word
           CHARACTER*1   D             !delimitor
           CHARACTER*(*) S             !word to extract from
C
C= Extracts the next word based on TSM's delimitors
C
      CHARACTER*9 DELIM /' ,()=;$!%'/  !delimitors
      CHARACTER*2 QUOTES /'''""'/      !quotes
      INTEGER      NS                  !length of S
      INTEGER      I
      LOGICAL      QUOTE           !in quote
      CHARACTER*1  QUOTECH         !character used in quote
C
C functions
C
      INTEGER      NOFIND              !look until not found
C
C extr
C
      QUOTE = .FALSE.
      NS = LEN(S)
      I = 1
      DO 20, WHILE (I .LE. NS)
        IF (QUOTE) THEN
          IF (S(I:I) .EQ. QUOTECH) THEN
             QUOTE = .FALSE.
          ENDIF
        ELSE
          IF (INDEX(QUOTES, S(I:I)) .GT. 0) THEN
            QUOTECH = S(I:I)
            QUOTE = .TRUE.
          ELSE IF (INDEX(DELIM, S(I:I)) .GT. 0) THEN
            LEAVE 20
          ENDIF
        END IF
        I = I + 1
 20   END DO
C
C returned field
C
      IF (I .GT. NS) THEN
        R = S
      ELSE IF (I .EQ. 1) THEN
        R = ' '
      ELSE
        R = S(:I-1)
      END IF
C
C delimitor
C
      IF (I .GT. NS) THEN
        D = ' '
      ELSE
        D = S(I:I)
      END IF
C
C new buffer
C
      IF (I .GT. NS) THEN
        S = ' '
      ELSE IF (I .EQ. NS) THEN
        S = ' '
      ELSE
        S = S(I+1:)
      END IF
C
C remove trailing blanks
C
      I = NOFIND(S, ' ')
      IF (I .GT. 0) S = S(I:)
      RETURN
      END
      LOGICAL FUNCTION ISFILE(PATHNAME)
           IMPLICIT NONE
           CHARACTER*(*)PATHNAME            !PATH TO CHECK
C
C= Tests to determine if file specified in path exists
C
      INTEGER*4    RDBUFFER(8)         !RESOURCE DESCR. BUFFER
      INTEGER*4    ERRSTAT             !ERROR STATUS
C
C
      CALL X_RID(PATHNAME,RDBUFFER,ERRSTAT)
      ISFILE = ERRSTAT .EQ. 0
      RETURN
      END
      INTEGER FUNCTION XTOI(S)
           IMPLICIT NONE
           CHARACTER*(*)   S           !hex number in ascii
C          return          integer value
C
C= Converts an ascii hex string to integer number
C
      INTEGER      N                   !length of string
      INTEGER      I                   !string pointer
      INTEGER      C                   !ascii value
      INTEGER      ZERO/X'30'/         !ascii zero
      INTEGER      NINE/X'39'/
      INTEGER      A   /X'41'/
      INTEGER      F   /X'46'/
C
C functions
C
      INTEGER      ICHAR               !char to integer value
      INTEGER      LEN                 !length of string
C
C xtoi
C
      N = LEN(S)
      I = 1
      XTOI = 0
      DO WHILE (I .LT. N .AND. S(I:I) .EQ. ' ')
        I = I + 1
      END DO
      DO 20 WHILE (I .LE. N)
        C = ICHAR(S(I:I))
        IF (C .GE. ZERO .AND. C .LE. NINE) THEN
          C = C - ZERO
        ELSE IF (C .GE. A .AND. C  .LE. F) THEN
          C = C - A + 10
        ELSE
          LEAVE 20
        END IF
        INLINE
          LW     6,XTOI     !get previous value
          LW     7,C        !get current value to add
          SLL    7,28       !left justify
          SLLD   6,4        !move into xtoi
          STW    6,XTOI      !done
        ENDI
        I = I + 1
 20   END DO
      RETURN
      END
      CHARACTER*(*) FUNCTION ITOX (X)
           IMPLICIT NONE
           INTEGER       X   !hex value
C
C= Convert integer to hex ascii string
C  forces a leading numeric character
C
      CHARACTER*9  T                   !temporary string
      INTEGER      I                   !sting pointer
      INTEGER      J                   !local value to convert
      INTEGER      C                   !convertion value
      INTEGER      A/X'41'/
      INTEGER      F/X'46'/
      INTEGER      ZERO/X'30'/
      INTEGER      NINE/X'39'/
C
C functions
C
      CHARACTER*1  CHAR                !integer to character function
C
C ITOX
C
      J = X
      T = ' '
      I = 9
      DO UNTIL (J .EQ. 0)
        INLINE
          LW       6,J                 !get current value
          SRLD     6,4                 !get first hex value
          SRL      7,28                !right justify
          STW      7,C                 !convert
          STW      6,J                 !new value
        ENDI
        IF (C .GE. 10) THEN
          C = C - 10 + A
        ELSE
          C = C + ZERO
        END IF
        T(I:I) = CHAR(C)
        I = I - 1
      END DO
      IF (T(I+1:I+1) .GT. 'A') THEN
        T(I:I) = CHAR(ZERO)
      END IF
      CALL LADJ(T)
      ITOX = T
      RETURN
      END
      CHARACTER*(*) FUNCTION ITOA (I)
           IMPLICIT NONE
           INTEGER       I             !integer to output
C
C= Converts an integer number to an ascii string
C
      CHARACTER*20   BUF               !local buffer
      INTEGER        J                 !local integer value
C
C format
C
 1000 FORMAT (I20)
C
C itoa
C
      J = I
      WRITE (BUF, 1000, ERR=10) J
      CALL LADJ(BUF)
      ITOA = BUF
      RETURN
 10   CONTINUE
      ITOA = '0'
      RETURN
      END
      SUBROUTINE GETEMSG(STRNG)
           IMPLICIT NONE
           INTEGER  STRNG(200)
C
C= Produce an error message string for the current error
CLT 2.3 THIS ROUTINE TRW'D TO PRODUCE CORRECT ERROR MESSAGES
C
      INCLUDE      'KDEF.INS'
      INCLUDE      'KPROT.COM'
C
      INTEGER      I
C
      I = 1
      IF (ABORTYP(SENDING)) THEN
        CALL DPC2AS('SENDING',STRNG(I), 7)
        I = I + 7
      ELSE
        CALL DPC2AS('RECEIVING',STRNG(I),9)
        I = I + 9
      ENDIF
      IF (ABORTYP(INITERR)) THEN
        CALL DPC2AS(' INIT',STRNG(I),5)
        I = I + 5
      ELSE IF (ABORTYP(FILERR)) THEN
        CALL DPC2AS(' FILE NAME',STRNG(I),10)
        I = I + 10
      ELSE IF (ABORTYP(DATAERR)) THEN
        CALL DPC2AS(' DATA',STRNG(I),5)
        I = I + 5
      ELSE IF (ABORTYP(EOFERR)) THEN
        CALL DPC2AS(' EOF',STRNG(I),4)
        I = I + 4
      ELSE
        CALL DPC2AS(' BREAK',STRNG(I),6)
        I = I + 6
      ENDIF
      CALL DPC2AS(' PACKET,',STRNG(I),7)
      I = I + 7
      IF (ABORTYP(TOOMANY)) THEN
        CALL DPC2AS(' TOO MANY RETRIES',STRNG(I),17)
        I = I + 17
      ELSE IF (ABORTYP(INVALID)) THEN
        CALL DPC2AS(' RECV. INVALID PACKET',STRNG(I),20)
        I = I + 20
      ELSE IF (ABORTYP(SEQERR)) THEN
        CALL DPC2AS(' RECV. OUT OF SEQ. PACKET',STRNG(I),25)
        I = I + 25
      ELSE IF (ABORTYP(LCLFILE)) THEN
        CALL DPC2AS(' FAILED TO OPEN FILE',STRNG(I), 21)
        I = I + 21
      ELSE
        CALL DPC2AS(' UNANTICIPATED ERROR',STRNG(I),20)
        I = I + 20
      ENDIF
      STRNG(I) = 0
      I = I+1
      RETURN
      END
      BLOCK DATA BDFILECO
           IMPLICIT NONE
C
C= Initialize the filecom common
C
      INCLUDE      'KFILE.COM'
C
      DATA FMODE/MAXFILE*CLOSED/   !close all units
      DATA FCHPTR /MAXFILE*0/
      DATA FCHCNT /MAXFILE*0/
      DATA FEOF /MAXFILE*.FALSE./
      DATA CTDEV /MAXFILE*.FALSE./
      DATA FREQ /MAXFILE*0/
      DATA IOPEND /MAXFILE*NOIO/
      DATA NOWAIT /MAXFILE*.FALSE./
      DATA BINARY /MAXFILE*.FALSE./
      DATA FTIMOUT/MAXFILE* 0/
      END
      INTEGER FUNCTION OPEN(FN, MODE)
           IMPLICIT NONE
           CHARACTER*(*) FN        !file name
           CHARACTER*(*) MODE      !mode of file ('R','W')
C
C= o Opens a file as specified, returns file index
      INCLUDE      'KFILE.COM'
C
      INTEGER      I               !indexing
      CHARACTER*8  FILESTAT        !file status for open
      INTEGER      IOS             !status of open
      INTEGER      IMODE           !translated mode code
      INTEGER      ALTLFC          !altlfc to assign to
      CHARACTER*4  CALTLFC         !character form of alt lfc
        EQUIVALENCE (CALTLFC, ALTLFC)
      CHARACTER*1  OPENMODE        !access mode
C
      INTEGER      ICHAR           !character to integer
C
      IF (MODE .EQ. 'R') THEN
        IMODE = RD
      ELSE IF (MODE .EQ. 'W' .OR. MODE .EQ. 'C') THEN
        IMODE = WR
      ELSE
        CALL PRTMSG('OPEN - invalid mode',ICHAR(MODE))
        OPEN = ERROR
        RETURN
      ENDIF
      DO I=1, MAXFILE              !handle duplicates
C
C handle duplicate entries
C
        IF (FMODE(I) .NE. CLOSED) THEN     !if open
          IF (FNAME(I) .EQ. FN) THEN     !if duplicate
            IF (FMODE(I) .EQ. IMODE) THEN   !if same mode, ignore
              IF (CTDEV(I)) THEN            !if device, flush, ready
                CALL FLUSH(I)
                OPEN = I
                RETURN
              ELSE                         !if file, rewind
                CALL FLUSH(I)
                CALL CLOSE(I)
              ENDIF
            ELSE                       !if mode different, reopen
              IF (CTDEV(I)) THEN       !if device, not really dupl.
                CONTINUE
              ELSE                     !if file, close so can reopen
                CALL FLUSH(I)
                CALL CLOSE(I)
              ENDIF
            ENDIF
          ENDIF
        ENDIF
      ENDDO
C
C find slot
C
      OPEN = 1
      DO WHILE (OPEN .LT. MAXFILE .AND. FMODE(OPEN) .NE. CLOSED)
        OPEN = OPEN + 1
      ENDDO
      IF (FMODE(OPEN) .NE. CLOSED) THEN
        OPEN = ERROR
        CALL PRTMSG('OPEN - Exceed allowed number of files',MAXFILE)
        RETURN
      ENDIF
C
C open
C
      FNAME(OPEN) = FN
      FCHPTR(OPEN) = 1
      FCHCNT(OPEN) = 0
      FMODE(OPEN) = IMODE
      FEOF(OPEN) = .FALSE.
      CTDEV(OPEN) = .FALSE.
      FREQ(OPEN) = MAXCH
      IOPEND(OPEN) = NOIO
      NOWAIT(OPEN) = .FALSE.
      FTIMOUT(OPEN) = 0
      BINARY(OPEN) = .FALSE.
      DO I=1, 4
        FBLK(I, OPEN) = 0
      ENDDO
      DO I=1, MAXCH
        FCHBUF(I, OPEN) = 0
      ENDDO
C
C if standard i/o, connect to user terminal
C
      IF (FNAME(OPEN) .EQ. 'STDIN' .OR. FNAME(OPEN) .EQ. 'STDOUT') THEN
        OPEN (UNIT=OPEN, ALTUNIT='UT', IOSTAT=IOS, ERR=910)
        CTDEV(OPEN) = .TRUE.
        FREQ(OPEN) = 133
C
C if terminal - all terminals begin with @
C
      ELSE IF (FNAME(OPEN)(1:1) .EQ. '@') THEN
        FNAME(OPEN) = FNAME(OPEN)(2:)
        OPEN (UNIT=OPEN, DEVICE=FNAME(OPEN),
     $        WAIT=.FALSE.,
     $        IOSTAT=IOS, ERR=910)
        CTDEV(OPEN) = .TRUE.
        FREQ(OPEN) = 133
C
C must be file
C
      ELSE
        IF (FMODE(OPEN) .EQ. RD) THEN
          FILESTAT='OLD'
          OPENMODE = 'R'
        ELSE
          FILESTAT='UNKNOWN'
          OPENMODE = 'U'
        ENDIF
        OPEN(UNIT=OPEN, FILE=FNAME(OPEN),
     $         BLOCKED=.TRUE., FORM='FORMATTED',
     $         WAIT=.FALSE.,STATUS=FILESTAT,
     $         OPENMODE = OPENMODE,
     $         IOSTAT=IOS, ERR=910)
      ENDIF
      CALL BLKINIT(OPEN)
      RETURN
C
C open error
C
 910  CONTINUE
      FMODE(OPEN) = CLOSED
      OPEN = -IOS
      RETURN
      END
      SUBROUTINE BLKINIT(FD)
           IMPLICIT NONE
           INTEGER    FD           !file descriptor
C
C= Calls fcbinit with proper function code for current flags
C
      INCLUDE      'KFILE.COM'
C
      INTEGER      FUNC            !function code
      INTEGER      NOWAITW/X'80000000'/  !nowait operation
      INTEGER      DFI    /X'20000000'/  !use io spec we specify
      INTEGER      XXWORD /X'00100000'/  !xon/xoff protocol
      INTEGER      EXP    /X'02000000'/  !expanded fcb
      INTEGER      NOERR  /X'40000000'/  !no error branch
      INTEGER      CONTROL/X'00800000'/  !control character detect
      INTEGER      NOECHO /X'00400000'/  !do not echo down port
      INTEGER      NOUPPER/X'00200000'/  !do not convert to upper case
      INTEGER      SPCHRW /X'00100000'/  !special character detect
      INTEGER      PURGEW /X'00080000'/  !purge type ahead buffer
C
      IF (CTDEV(FD)) THEN
        IF (FMODE(FD) .EQ. RD) THEN
          IF (BINARY(FD)) THEN
            FUNC = NOERR + EXP + DFI + CONTROL + NOECHO + NOUPPER
          ELSE
            FUNC = NOERR + EXP
          ENDIF
        ELSE       !write
          FUNC = NOERR + EXP + DFI
        ENDIF
      ELSE         !disk read/write
        FUNC = NOERR + EXP
      ENDIF
      IF (NOWAIT(FD)) FUNC = FUNC + NOWAITW
      CALL FCBINIT(FD, FBLK(1, FD), FUNC, FREQ(FD))
      RETURN
      END
      SUBROUTINE CLOSE(FD)
           IMPLICIT NONE
           INTEGER    FD           !file descriptor
C
C= Closes an opened file.
C
      INCLUDE      'KFILE.COM'
C
      IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
        CONTINUE                   !ignore errors
      ELSE IF (FMODE(FD) .EQ. CLOSED) THEN
        CONTINUE                   !already closed
      ELSE
        CALL FLUSH(FD)
        CLOSE(UNIT=FD)
        FMODE(FD) = CLOSED
      ENDIF
      RETURN
      END
      SUBROUTINE FLUSH(FD)
           IMPLICIT NONE
           INTEGER   FD            !file descriptor
C
C= forces output of buffer
C
      INCLUDE      'KFILE.COM'
C
      INTEGER*1    LBUF(MAXCH,  MAXFILE)  !local buffers for nowait
      INTEGER      I
C
      IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
        RETURN
      ELSE IF (FMODE(FD) .EQ. CLOSED) THEN
        RETURN
      ELSE
        IF (FMODE(FD) .EQ. WR .AND. FCHCNT(FD) .GT. 0) THEN
          IF (IOPEND(FD) .EQ. NOIO) THEN
            IF (NOWAIT(FD)) THEN
              IOPEND(FD) = IOSTART
              DO I=1, FCHCNT(FD)
                LBUF(I, FD) = FCHBUF(I, FD)
              ENDDO
              GOTO (10,20,30,40,50,60,70,80,90,100) FD
 10           CONTINUE
              CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
     $           *801, *801)
              GOTO 150
 20           CONTINUE
              CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
     $           *802, *802)
              GOTO 150
 30           CONTINUE
              CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
     $           *803, *803)
              GOTO 150
 40           CONTINUE
              CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
     $           *804, *804)
              GOTO 150
 50           CONTINUE
              CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
     $           *805, *805)
              GOTO 150
 60           CONTINUE
              CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
     $           *806, *806)
              GOTO 150
 70           CONTINUE
              CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
     $           *807, *807)
              GOTO 150
 80           CONTINUE
              CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
     $           *808, *808)
              GOTO 150
 90           CONTINUE
              CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
     $           *809, *809)
              GOTO 150
 100           CONTINUE
              CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
     $           *810, *810)
              GOTO 150
 150          CONTINUE
            ELSE
              IOPEND(FD) = NOIO
              CALL DPWRITE(FBLK(1, FD), FCHBUF(1, FD), FCHCNT(FD), 0)
            ENDIF
          ENDIF
        ELSE IF (FMODE(FD) .EQ. RD .AND. IOPEND(FD) .EQ. IOSTART) THEN
          CALL HIO(FD)
CLT       DO I=1, MAXFILE
CLT         IF (FMODE(I) .EQ. WR .AND. IOPEND(I) .EQ. IOSTART)
CLT  $        CALL X:EAWAIT(0,,)
CLT         IF (IOPEND(I) .EQ. IOSTART) IOPEND(I) = NOIO
CLT       ENDDO
CLT       CALL HIOALL              !this is going to hurt somewhere
        ENDIF
        FCHPTR(FD) = 1
        FCHCNT(FD) = 0
      ENDIF
      RETURN
C
C end action
C
 801  IOPEND( 1) = NOIO; CALL X:XNWIO
 802  IOPEND( 2) = NOIO; CALL X:XNWIO
 803  IOPEND( 3) = NOIO; CALL X:XNWIO
 804  IOPEND( 4) = NOIO; CALL X:XNWIO
 805  IOPEND( 5) = NOIO; CALL X:XNWIO
 806  IOPEND( 6) = NOIO; CALL X:XNWIO
 807  IOPEND( 7) = NOIO; CALL X:XNWIO
 808  IOPEND( 8) = NOIO; CALL X:XNWIO
 809  IOPEND( 9) = NOIO; CALL X:XNWIO
 810  IOPEND(10) = NOIO; CALL X:XNWIO
      END
      SUBROUTINE PUTC(FD, TCH)
           IMPLICIT NONE
           INTEGER    FD     !file descriptor
           INTEGER    TCH    !character to output
C
C= outputs a character
C
C **** NOTE: tricky stuff, no difference between terminal
C      outputs in binary or ascii, but in binary NEL's are
C      not interpreted.  So don't put term in binary unless
C      you really mean it.
C
C
      INCLUDE      'KFILE.COM'
C
      INTEGER      CH
      INTEGER      I
C
      IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
        CONTINUE
      ELSE IF (FMODE(FD) .EQ. WR) THEN
        CH = TCH
        IF (.NOT. BINARY(FD) .AND. TCH .EQ. NEL) THEN
          CH = CR
          IF (.NOT. CTDEV(FD)) GOTO 20
        ENDIF
 10     CONTINUE
        IF (FCHCNT(FD) .GE. FREQ(FD)) CALL FLUSH(FD)
        IF (FCHCNT(FD) .LT. MAXCH) THEN
          FCHCNT(FD) = FCHCNT(FD) + 1
          FCHBUF(FCHCNT(FD), FD) = CH
        ENDIF
        IF (FCHCNT(FD) .GE. FREQ(FD)) CALL FLUSH(FD)
        IF (TCH .EQ. NEL .AND. CH .EQ. CR) THEN
          CH = LF
          GOTO 10
        ENDIF
 20     CONTINUE
C
C end of line processing
C
        IF (.NOT. BINARY(FD) .AND. TCH .EQ. NEL) THEN
C
C if text file, strip trailing blanks, cr, lf
C
          IF (.NOT. CTDEV(FD)) THEN
            I = FCHCNT(FD)
            DO WHILE (I .GT. 0)
              IF (FCHBUF(I, FD) .EQ. BLANK .OR. FCHBUF(I, FD) .EQ.
     $            CR .OR. FCHBUF(I, FD) .EQ. LF) THEN
                I = I - 1
              ELSE
                LEAVE
              ENDIF
            ENDDO
            IF (I .LE. 0) THEN
              I = I + 1
              FCHBUF(I, FD) = BLANK
            ENDIF
            FCHCNT(FD) = I
          ENDIF
          CALL FLUSH(FD)                   !force out
        ENDIF
      ENDIF
      RETURN
      END
      INTEGER FUNCTION GETC(FD, CH)
           IMPLICIT NONE
           INTEGER    FD           !file descriptor
           INTEGER    CH           !character read in
C
C= Reads a character from input buffer, reads if necessary
C
      INCLUDE      'KFILE.COM'
C
      IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
        CH = ERROR
      ELSE IF (FMODE(FD) .EQ. RD) THEN
        IF (FCHPTR(FD) .GT. FCHCNT(FD)) CALL FILL(FD)
        IF (FEOF(FD)) THEN
          CH = EOF
        ELSE IF (FCHPTR(FD) .GT. FCHCNT(FD)) THEN
          CH = ERROR
        ELSE
          CH = FCHBUF(FCHPTR(FD), FD)
          FCHPTR(FD) = FCHPTR(FD) + 1
        ENDIF
      ELSE
        CH = ERROR
      ENDIF
      GETC = CH
      RETURN
      END
      SUBROUTINE FILL(FD)
           IMPLICIT NONE
           INTEGER    FD   !file descriptor
C
C= Fills the respective fd's buffer
C
      INCLUDE      'KFILE.COM'
C
      INTEGER      STATUS          !status of io done
      INTEGER      I               !temp count
C
      INTEGER      DPCOUNT         !retreive count of transfer
      INTEGER      DERROR          !error code
C
      IF (IOPEND(FD) .EQ. NOIO) THEN
        IF (NOWAIT(FD)) THEN
          IOPEND(FD) = IOSTART
          GOTO (10, 20, 30, 40, 50, 60, 70, 80, 90, 100) FD
 10       CONTINUE
            CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*801,*801)
            GOTO 150
 20      CONTINUE
            CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*802,*802)
            GOTO 150
 30       CONTINUE
            CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*803,*803)
            GOTO 150
 40      CONTINUE
            CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*804,*804)
            GOTO 150
 50      CONTINUE
            CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*805,*805)
            GOTO 150
 60       CONTINUE
            CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*806,*806)
            GOTO 150
 70      CONTINUE
            CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*807,*807)
            GOTO 150
 80      CONTINUE
            CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*808,*808)
            GOTO 150
 90       CONTINUE
            CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*809,*809)
            GOTO 150
 100     CONTINUE
            CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*810,*810)
            GOTO 150
 150      CONTINUE
          IF (FTIMOUT(FD) .GT. 0) THEN
            CALL X:EAWAIT(-FTIMOUT(FD)*20,,)
            IF (IOPEND(FD) .EQ. IOSTART) THEN
              CALL HIO(FD)
              CALL X:EAWAIT(-FTIMOUT(FD)*20,,)
            ENDIF
          ENDIF
        ELSE
          CALL DPREAD(FBLK(1, FD), FCHBUF(1, FD), FREQ(FD), 0)
          IOPEND(FD) = IOCOMP
        ENDIF
      ENDIF
      IF (IOPEND(FD) .EQ. IOCOMP) THEN
        IOPEND(FD) = NOIO
        FCHPTR(FD) =1
        FCHCNT(FD) = DPCOUNT(FBLK(1, FD))
        IF (.NOT. BINARY(FD)) THEN
          IF (CTDEV(FD)) THEN
            FCHCNT(FD) = FCHCNT(FD) + 1
            FCHBUF(FCHCNT(FD), FD) = NEL
          ELSE
            I = FCHCNT(FD)
            DO WHILE (I .GT. 0)
              IF (FCHBUF(I,FD) .EQ. BLANK) THEN
                I = I - 1
              ELSE
                LEAVE
              ENDIF
            ENDDO
            I = I + 1
            FCHBUF(I, FD) = NEL
            FCHCNT(FD) = I
          ENDIF
        ENDIF
        STATUS = DERROR(FBLK(1, FD))
        IF (STATUS .EQ. 3 .OR. STATUS .EQ. 4) FEOF(FD) = .TRUE.
      ENDIF
      RETURN
C
C end action
C
 801  IOPEND(1) = IOCOMP; CALL X:XNWIO
 802  IOPEND(2) = IOCOMP; CALL X:XNWIO
 803  IOPEND(3) = IOCOMP; CALL X:XNWIO
 804  IOPEND(4) = IOCOMP; CALL X:XNWIO
 805  IOPEND(5) = IOCOMP; CALL X:XNWIO
 806  IOPEND(6) = IOCOMP; CALL X:XNWIO
 807  IOPEND(7) = IOCOMP; CALL X:XNWIO
 808  IOPEND(8) = IOCOMP; CALL X:XNWIO
 809  IOPEND(9) = IOCOMP; CALL X:XNWIO
 810  IOPEND(10)= IOCOMP; CALL X:XNWIO
      END
      SUBROUTINE STTY(FD, FIELD, VALUE)
           IMPLICIT NONE
           INTEGER    FD    !port to set
           CHARACTER*(*) FIELD    !field to set
           INTEGER       VALUE     !value to set to
C
C= Sets the specified field to the value
C
      INCLUDE      'KVER.INS'
      INCLUDE      'KFILE.COM'
      LOGICAL*1    TTYECHO(MAXFILE)  !local memory for echo
C
      LOGICAL      TUDT            !test user device table
C
C
      IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
        CONTINUE
      ELSE IF (FMODE(FD)  .EQ. CLOSED) THEN
        CONTINUE
C
C binary mode
C
      ELSE IF (FIELD .EQ. 'BINARY') THEN
        BINARY(FD) = VALUE .EQ. 1
        CALL BLKINIT(FD)
C
C TIMEOUT
C
      ELSE IF (FIELD .EQ. 'TIMEOUT') THEN
        FTIMOUT(FD) = VALUE
C
C nowait
C
      ELSE IF (FIELD .EQ. 'NOWAIT') THEN
        NOWAIT(FD) = VALUE .EQ. 1
        CALL BLKINIT(FD)
        IF (FMODE(FD) .EQ. RD) THEN
C
C This section is used to enable timeouts since
C gould doesn't support a timeout on a normal read.
C You must be privileged to do this stuff
C
          IF (LOCALON) THEN
            IF (NOWAIT(FD)) THEN
C
CLT 2.3 CORRECTED TURNING ECHO ON AND OFF
C In this section (which incidentially must be called first) we
C memorize the previous condition of the udt so we can restore
C it to correct mode.  This is part of rev. 2.3.  This feature
C is particularly important for those using a network for file
C transmittal since they don't have echo on any way.
C
              TTYECHO(FD) = TUDT(FBLK(1, FD), 'ECHO')
              IF (TTYECHO(FD)) THEN
                CALL SUDT(FBLK(1, FD), 'NOEC')    !make sure
              ENDIF
              CALL SUDT(FBLK(1, FD), 'DUAL')
            ELSE
              CALL SUDT(FBLK(1, FD), 'SING')
              IF (TTYECHO(FD)) THEN
                CALL SUDT(FBLK(1, FD), 'ECHO')    !may be right
              ENDIF
            ENDIF
          ENDIF
        ENDIF
C
C readsize
C
      ELSE IF (FIELD .EQ. 'SIZE') THEN
        IF (VALUE .GT. 0) THEN
          FREQ(FD) = VALUE
        ELSE
          FREQ(FD) = MAXCH
        ENDIF
        IF (FREQ(FD) .GT. MAXCH) FREQ(FD) = MAXCH
        CALL BLKINIT(FD)
C
C unrecognized field
C
      ELSE
        CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE UNGETC(FD, CH)
           IMPLICIT NONE
           INTEGER   FD            !file descriptor
           INTEGER   CH            !character put back
C
C= Try to put a character back into the input stream
C
C  Ungetc can only put back characters as far as the beginning
C  of the buffer.  Hopefully, this is ok, since only getword
C  does this with an nel which should be well into the buffer.
C
      INCLUDE      'KFILE.COM'
C
      IF (FCHPTR(FD) .GT. 1) THEN
        FCHPTR(FD) = FCHPTR(FD) - 1
        FCHBUF(FCHPTR(FD), FD) = CH
      ENDIF
      RETURN
      END
      INTEGER FUNCTION GETWORD(FD, STR, MAXLEN)
           IMPLICIT NONE
           INTEGER    FD   !file descriptor
           INTEGER    STR(*)  !string to read to
           INTEGER    MAXLEN !max size of string
C
C= get a word from an input stream
C
C  Getword considers a word to be delimited by blanks.
C  It will return the length of the word as its value.
C
      INCLUDE      'KFILE.COM'
C
      INTEGER      LEN             !length of string
      INTEGER      CH              !character
C
      INTEGER      GETC            !get character
C
      LEN = 0
C
C skip leading white space
C
 10   CONTINUE
      IF (GETC(FD, CH) .EQ. EOF) THEN
        GETWORD = EOF
        RETURN
      ELSE IF (CH .EQ. NEL) THEN
        GETWORD = 0
        RETURN
      ENDIF
      IF (CH .EQ. BLANK .OR. CH .EQ. TAB) GOTO 10
C
C found first character, so keep going
C
      DO WHILE (.NOT. (CH .EQ. EOF .OR. CH .EQ. BLANK .OR.
     $                 CH .EQ. TAB .OR. CH .EQ. NEL) .AND.
     $                 LEN .LT. MAXLEN)
        LEN = LEN + 1
        STR(LEN) = CH
        CH = GETC(FD, CH)
      ENDDO
C
C save eols for next getword
C
      IF (CH .EQ. NEL) CALL UNGETC(FD, CH)
      STR(LEN+1) = 0
      GETWORD = LEN
      RETURN
      END
      SUBROUTINE PUTSTR(FD, STR)
           IMPLICIT NONE
           INTEGER   FD
           INTEGER  STR(*)   !string to read
C
C= Output a string to an output stream
C
      INCLUDE      'KFILE.COM'
C
      INTEGER      I
C
      IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
      ELSE IF (FMODE(FD) .EQ. WR) THEN
        I = 1
        DO WHILE (STR(I) .NE. 0)
          CALL PUTC(FD, STR(I))
          I = I + 1
        ENDDO
      ENDIF
      RETURN
      END
      SUBROUTINE PUTINT (FD, INT, MINWID)
           IMPLICIT NONE
           INTEGER    FD
           INTEGER    INT
           INTEGER    MINWID       !minimum width
C
C= Output an integer
C
      INCLUDE      'KDEF.INS'
C
      INTEGER      WIDTH
      INTEGER      VAL
      INTEGER      ASCIIO
      INTEGER      NCH             !number of characters
      INTEGER      STRING(21)
C
      INTEGER      ICHAR
      INTEGER      IABS
      INTEGER      MOD
C
      WIDTH = 0
      IF (INT .LT. 0) THEN
        CALL PUTC(FD, ICHAR('-'))
        WIDTH = 1
      ENDIF
      VAL = IABS(INT)
      ASCIIO = ICHAR('0')
      NCH = 0
      DO UNTIL (VAL .EQ. 0 .OR. NCH .GE. 20)
        NCH = NCH + 1
        STRING(NCH) = MOD(VAL, 10) + ASCIIO
        VAL = VAL/10
      ENDDO
      WIDTH = WIDTH + NCH
C
C now output the digits
C
      DO UNTIL (NCH .LE. 0)
        CALL PUTC(FD, STRING(NCH))
        NCH = NCH - 1
      ENDDO
      DO WHILE (WIDTH .LT. MINWID)
        CALL PUTC(FD, BLANK)
        WIDTH = WIDTH + 1
      ENDDO
      RETURN
      END
      SUBROUTINE PUTDAY(FD, MM, DD, YY)
           IMPLICIT NONE
           INTEGER   FD
           INTEGER   MM, DD, YY
C
C= Output day of week
C
      INTEGER      IZLR
      INTEGER      IMN
      INTEGER      IYR
      INTEGER      IDY
      INTEGER      WKDAY
C
C day of week function!
C
      IZLR (IYR, IMN, IDY) = MOD((13*(IMN+10-(IMN+10)/13*12)-1)/5+
     $    IDY+77+5*(IYR+(IMN-14)/12-(IYR+(IMN-14)/12)/100*100)/4+
     $    (IYR+(IMN-14)/12)/400-(IYR+(IMN-14)/12)/100*2,7)+1
C
      WKDAY = IZLR(YY, MM, DD)
      IF (WKDAY .EQ. 1) THEN
        CALL PRINT(FD, 'Sunday')
      ELSE IF (WKDAY .EQ. 2) THEN
        CALL PRINT(FD, 'Monday')
      ELSE IF (WKDAY .EQ. 3) THEN
        CALL PRINT(FD, 'Tuesday')
      ELSE IF (WKDAY .EQ. 4) THEN
        CALL PRINT(FD, 'Wednesday')
      ELSE IF (WKDAY .EQ. 5) THEN
        CALL PRINT(FD, 'Thursday')
      ELSE IF (WKDAY .EQ. 6) THEN
        CALL PRINT(FD, 'Friday')
      ELSE
        CALL PRINT(FD, 'Saturday')
      ENDIF
      RETURN
      END
      SUBROUTINE PUTMNTH(FD, MM)
           IMPLICIT NONE
           INTEGER   FD
           INTEGER   MM
C
C= Output the month name.
C
      IF (MM .EQ. 1) THEN
        CALL PRINT(FD, 'January')
      ELSE IF (MM .EQ. 2) THEN
        CALL PRINT(FD, 'Feburary')
      ELSE IF (MM .EQ. 3) THEN
        CALL PRINT(FD, 'March')
      ELSE IF (MM .EQ. 4) THEN
        CALL PRINT(FD, 'April')
      ELSE IF (MM .EQ. 5) THEN
        CALL PRINT(FD, 'May')
      ELSE IF (MM .EQ. 6) THEN
        CALL PRINT(FD, 'June')
      ELSE IF (MM .EQ. 7) THEN
        CALL PRINT(FD, 'July')
      ELSE IF (MM .EQ. 8) THEN
        CALL PRINT(FD, 'August')
      ELSE IF (MM .EQ. 9) THEN
        CALL PRINT(FD, 'September')
      ELSE IF (MM .EQ. 10) THEN
        CALL PRINT(FD, 'October')
      ELSE IF (MM .EQ. 11) THEN
        CALL PRINT(FD, 'November')
      ELSE IF (MM .EQ. 12) THEN
        CALL PRINT(FD, 'December')
      ELSE
        CALL PRINT(FD, 'No such month')
      ENDIF
      RETURN
      END
      SUBROUTINE PRINT (FD, STR)
           IMPLICIT NONE
           INTEGER   FD
           CHARACTER*(*)  STR
C
C= Output character string
C
      INTEGER      I
C
      INTEGER      LEN
      INTEGER      ICHAR
C
      DO I=1, LEN(STR)
        CALL PUTC(FD, ICHAR(STR(I:I)))
      ENDDO
      RETURN
      END
      SUBROUTINE PRINTL(FD, STR)
           IMPLICIT NONE
           INTEGER    FD
           CHARACTER*(*) STR
C
C= Output a string with cr/lf at end
C
      INCLUDE      'KDEF.INS'
C
      CALL PUTC(FD, NEL)
      CALL PRINT(FD, STR)
      CALL FLUSH(FD)
      RETURN
      END
      SUBROUTINE SENDBRK(FD)
           IMPLICIT NONE
           INTEGER  FD             !file to break
C
C Sends break to attached port
C
      INCLUDE      'KFILE.COM'
C
      INTEGER      BLK(4)          !local block
      INTEGER      BRK             !function that turns on break
     $       /X'62800000'/
      INTEGER      NOBRK           !turn off break
     $       /X'62000000'/         !break turned off
C
      IF (FD .LE. 0 .AND. FD .GE. MAXFILE) THEN
      ELSE IF (.NOT. CTDEV(FD)) THEN
      ELSE IF (FMODE(FD) .NE. WR) THEN
      ELSE
        CALL FLUSH(FD)
        CALL FCBINIT(FD, BLK, BRK, 0)
        CALL DPWRITE(BLK, 0, 0)

        CALL DELAY(60)
        CALL FCBINIT(FD, BLK, NOBRK, 0)
        CALL DPWRITE(BLK, 0, 0)
        CALL BLKINIT(FD)
      ENDIF
      RETURN
      END
      SUBROUTINE IOWAIT (MSEC)
           IMPLICIT NONE
           INTEGER  MSEC           !msec to wait for io to complete
C
C= Delays the specified time if io is pending
C
      INTEGER      IOS
C
      INTEGER      MIN
C
C
      CALL X:EAWAIT(MIN(-1,-MSEC/50), IOS, *10)
 10   CONTINUE
      RETURN
      END
