C                 S E R V E R   O N L Y   K E R M I T
C
C     written in January, 1986 by Skip Russell using Harris Fortran 77
C
C
C         This program implements the "server" portion of the "Kermit"
C     protocol, as described in version 3 of the protocol manual (see
C     reference below).  It is intended to facilitate the tranfer
C     of files between a Harris computer and other machines.  It
C     incorporates mechanisms to maintain the integrity of data, even
C     over noisy phone lines, etc.  Only the basic server functions
C     have been implemented in this initial version, i.e. send and
C     receive of text (7 bit ascii) files, and the "Finish" command.
C     Other functions/enhancements may be added to future versions
C     and will be documented under "revision history" below.
C
C         I wrote this program especially for use on Harris computers
C     which are configured with a "MUX" as opposed to the more recent
C     CNP or DMACP I/O processors.  As such, I have not taken advantage
C     of many of the special features offered by those devices (notably
C     timeouts and buffered I/O via "hot read"), but have opted instead
C     for simpler, albeit less efficient, modes of communication.  In
C     any case, this program should work properly on a Harris machine
C     in any configuration.
C
C         This program was written using Harris Fortran on a Harris
C     H100-1 computer (VOS 4.1.1 operating system).  It was tested
C     at up to 9600 baud against Columbia University's "MSKERMIT"
C     version 2.27 (see below) on an IBM PC/AT running DOS 3.0.
C
C
C                          -- REFERENCES --
C
C     For a complete discussion of the Kermit design philosophy and
C     detailed descriptions of Kermit commands, see the "KERMIT USER'S
C     GUIDE" by Frank da Cruz, Daphne Tzoar, and Bill Catchings.
C
C     For a detailed description of the Kermit protocol, see the
C     "KERMIT PROTOCOL MANUAL" by Frank da Cruz and Bill Catchings.
C
C     These two documents, as well as general information about Kermit,
C     MSKERMIT and other implementations of Kermit, are available for
C     the cost of distribution, from:
C
C           KERMIT Distribution
C           Columbia University Center for Computing Activities
C           612 West 115th Street
C           7th Floor
C           New York, NY  10025
C
C     or send electronic mail to: Info-Kermit-Request@CU20B.ARPA
C
C
C     Address questions, fixes, comments about this implementation to:
C
C           Skip Russell
C           Washington University School of Medicine
C           Division of Biostatistics
C           Box 8087, 660 South Euclid Avenue
C           St. Louis, Missouri  63110
C
C           electronic mail address: c04689sr@WUVMD.BITNET
C
C
C                       -- REVISION HISTORY --
C
C   (change version number and date in header line if changes are made)
C
C   version 1.00  Jan, 1986, by S.R. : initial release
C
C   version 1.01  Feb, 1986, by S.R. :
C     brought up to version 5 of the protocol manual (dated April 1984)
C     and tested using MSKERMIT version 2.28; also implemented the
C     following remote commands:
C     -- HELP command to issue summary of available remote commands
C     -- LOGOUT ("bye") command to log off the Harris job
C     -- DIRECTORY command to issue information about a single disk
C        area (for now; plan to add wildcard match in future)
C
C   version 1.02  Sept, 1986, by S.R. :
C     -- implemented full DIRECTORY command (wildcard character "?")
C     -- tested using MSKERMIT version 2.29 (dated 26 May 86)
C     -- moved to non-SAU Fortran 77 compiler for portablity
C
C   version 1.03  Nov, 1986, by S.R. :
C     -- brought up to VOS 5.1.0 (required changes in interpretation of
C        file access bits in "REMOTE DIRECTORY" command handler)
C     -- fixed logic in RECVSW to correctly respond to error packets
C
C   version 1.04  April, 1987, by S.R. :
C     -- added code to allow GETs of file groups using the "?" wildcard
C        character.
C
C   version 1.05  May, 1987, by S.R. :
C     -- Corrected error in SWOPEN.  GETs of file groups failed in
C        cases where the qualifier contained trailing blanks.  The fix
C        consisted of enclosing the file name in quotes.
C
C   version 1.06  June, 1987, by S.R. :
C     -- Added code in RDISK to distinguish between EOF and EOT.  Harris
C        disk areas containing embedded EOFs can now be sent without
C        truncating trailing records.  The EOF is sent as a record
C        containing the string "<EOF>".
C
C
C ---------------------------------------------------------------------

C     COMMON BLOCKS USED:

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG
      INTEGER           MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
      COMMON /SNDCOM/   MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
      INTEGER           MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
      COMMON /RCVCOM/   MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME

      INTEGER           MXDATA
      PARAMETER (MXDATA=89)
      INTEGER           DATA(MXDATA),NDATA,NSEQ,ISTAT,MAXTRY
      CHARACTER         TYPE*1

      WRITE (3,*) 'HARRIS KERMIT SERVER  --  version 1.06 (June 87) SR'
      WRITE (3,*)

C     DEFINE DEFAULT SEND AND RECEIVE SPECS

      CALL KSTART

      MAXTRY = 10

C     WAIT FOR A PACKET TO COME IN, THEN RESPOND

100   CALL RCVPKT(MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT)

C     WE GOT GARBAGE, NAK IT AND TRY AGAIN
      IF (ISTAT .NE. 0) THEN
         NDATA = 0
         CALL SNDNAK(NSEQ)

C     WE GOT INIT IN ADVANCE OF SOME FUTURE COMMAND, JUST EXCHANGE INFO
      ELSE IF (TYPE .EQ. 'I') THEN
         CALL INIT(MXDATA,DATA,NDATA,NSEQ)

C     LOCAL "SEND" COMMAND (THEY WANT TO SEND A FILE TO US)
      ELSE IF (TYPE .EQ. 'S') THEN
         CALL RECVSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)

C     LOCAL "GET" COMMAND (THEY WANT A FILE FROM US)
      ELSE IF (TYPE .EQ. 'R') THEN
         CALL SENDSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)

C     'GENERIC' COMMAND (THEY WANT US TO LOG OFF OR SOMETHING)
      ELSE IF (TYPE .EQ. 'G') THEN
         CALL COMMND(MXDATA,DATA,NDATA,NSEQ,MAXTRY,ISTAT)
         IF (ISTAT .NE. 0) GO TO 999

C     WE GOT AN ERROR PACKET, JUST ACKNOWLEDGE IT
      ELSE IF (TYPE .EQ. 'E') THEN
         NDATA = 0
         CALL SNDACK(DATA,NDATA,NSEQ)

C     ANYTHING ELSE IS AN ERROR, AS FAR AS WE'RE CONCERNED
      ELSE
         CALL SNDERR('server command not implemented',MXDATA,DATA,NSEQ)
      END IF
      GO TO 100

999   CALL KFINSH
      END

      SUBROUTINE KSTART
C---
C--- DEFINE DEFAULT SEND AND RECEIVE SPECS
C---
      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG
      INTEGER           MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
      COMMON /SNDCOM/   MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
      INTEGER           MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
      COMMON /RCVCOM/   MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME

      INTEGER           IOPT

C     HANDLE DEBUG MODE (SPECIFIED USING "KERMIT.D")

      CALL OPTION(IOPT)

      IF ((IOPT.AND.2**3) .GT. 0) THEN         ! OPTION "D" SPECIFIED
         DEBUG = .TRUE.
         IOPT  = IOPT .XOR. 2**3
      ELSE                                     ! NOT SPECIFIED
         DEBUG = .FALSE.
      END IF

      IF (IOPT.NE.0) STOP "*ERROR* valid option is 'D' for debug mode"

      IF (DEBUG) THEN
         WRITE (3,*) '[writing packet contents to LO for debugging]'
      ELSE
         WRITE (3,*) '[logging names of send/receive files to LO]'
      END IF
      WRITE (3,*)

C     DEFAULT SEND SPECS

      MSPSIZ = 94                   ! BIGGEST PACKET THEY CAN RECEIVE
      NSTIME = 0                    ! WHEN THEY WANT TIMEOUT
      NSPAD  = 0                    ! HOW MUCH PADDING TO SEND THEM
      NSPCHR = 0                    ! PAD CHARACTER TO USE
      NSEOL  = 13                   ! EOL TO SEND THEM (CR)
      NSQUOT = ICHAR('#')           ! INCOMING DATA QUOTE CHARACTER

C     DEFAULT RECEIVE SPECS

      MRPSIZ = 78                   ! BIGGEST PACKET I CAN RECEIVE
      MYTIME = 13                   ! WHEN I WANT TIMEOUT
      MYPAD  = 0                    ! HOW MUCH PADDING TO SEND ME
      MYPCHR = 10                   ! PAD CHARACTER TO USE (LINEFEED)
      MYEOL  = 13                   ! EOL TO SEND ME (CR)
      MYQUOT = ICHAR('#')           ! QUOTE CHARACTER I WILL SEND THEM

CCCC     WARN ABOUT XON/XOFF IF CONTROL/S IS AN ABORT CHAR ON THIS
CCCC     MACHINE
CCC
CCC      WRITE (3,*) 'DO NOT USE XON/XOFF (SET FLOW NONE)'

      WRITE (3,*)
      WRITE (3,*) 'SERVER MODE ENABLED -- type the appropriate key'
      WRITE (3,*) 'sequence to escape back to your local Kermit...'
      END

      SUBROUTINE KFINSH
C---
C--- CLOSE UP
C---
      INTEGER           MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
      COMMON /SNDCOM/   MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME

      CALL PUT1CW(NSEOL,1)

      CLOSE (UNIT=6)
      CLOSE (UNIT=7)
      CLOSE (UNIT=50)
      END

      SUBROUTINE INIT(MXDATA,DATA,NDATA,NSEQ)
C---
C--- HANDLE INITIAL PACKET, RESPOND WITH ACK AND OUR PARAMETERS
C---
      INTEGER           MXDATA,DATA(*),NDATA,NSEQ

C     READ THEIR PACKET

      CALL RPAR(DATA,NDATA)

C     ACK WITH OUR INIT PACKET

      CALL SPAR(MXDATA,DATA,NDATA)
      CALL SNDACK(DATA,NDATA,NSEQ)
      END
C TRANSMIT SUBROUTINES
C
C     SENDSW   -- STATE TABLE SWITCHER FOR SENDING FILES
C     SOPEN    -- OPENS FILE TO SEND TO RECEIVING KERMIT
C     SINIT    -- EXCHANGE SEND/RECEIVE INFO WITH RECEIVING KERMIT
C     SFILE    -- SENDS FILE NAME TO RECEIVING KERMIT
C     SDATA    -- SENDS FILE CONTENTS TO RECEIVING KERMIT
C     SEOF     -- SENDS "END-OF-FILE" PACKET TO RECEIVING KERMIT
C     SBREAK   -- SENDS "BREAK" PACKET TO RECEIVING KERMIT
C     RDISK    -- READS A SINGLE CHARACTER FROM A DISK FILE
C     SWINIT   -- EXPANDS LIST OF WILDCARD FILE NAMES
C     SWOPEN   -- OPENS THE NEXT FILE IN A LIST OF WILDCARD FILENAMES
C     SWCLOS   -- CLOSES THE LIST OF WILDCARD FILE NAMES
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE SENDSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)
C---
C--- THIS IS THE STATE TABLE SWITCHER FOR SENDING FILES.
C--- IT LOOPS UNTIL EITHER IT IS FINISHED OR A FAULT IS ENCOUNTERED.
C---
      INTEGER           MXDATA,DATA(*),NDATA,NSEQ,MAXTRY

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG

      CHARACTER         STATE*1
      INTEGER           NUMTRY,ISTAT

C     ASSIGN THE FILE

      CALL SOPEN(MXDATA,DATA,NDATA,NSEQ,ISTAT)
      IF (ISTAT .NE. 0) GO TO 800

      STATE = 'S'
      NSEQ = 0

100   CONTINUE

      FOR NUMTRY=1,MAXTRY
         IF      (STATE .EQ. 'S') THEN       ! SEND INIT PACKET
            CALL SINIT(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)

         ELSE IF (STATE .EQ. 'F') THEN       ! SEND FILE-HEADER PACKET
            CALL SFILE(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)

         ELSE IF (STATE .EQ. 'D') THEN       ! SEND FILE-DATA PACKET
            CALL SDATA(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)

         ELSE IF (STATE .EQ. 'Z') THEN       ! SEND EOF PACKET
            CALL SEOF(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)

         ELSE IF (STATE .EQ. 'B') THEN       ! SEND BREAK (EOT) PACKET
            CALL SBREAK(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)

         ELSE IF (STATE .EQ. 'C') THEN       ! COMPLETE
            GO TO 900

         ELSE IF (STATE .EQ. 'A') THEN       ! ABORT
            GO TO 800

         ELSE
            WRITE (*,*) 'FATAL ERROR: INVALID STATE IN "SENDSW"'
            STOP
         END IF
         IF (ISTAT .EQ. 0) GO TO 500
      END FOR
      CALL SNDERR('too many retries',MXDATA,DATA,NSEQ)
      GO TO 800

500   NSEQ = MOD( NSEQ+1, 64 )
      GO TO 100

800   IF (DEBUG) WRITE (*,*) '--- ABORT ---'
      RETURN

900   IF (DEBUG) WRITE (*,*) '=== SEND COMPLETE ==='
      RETURN
      END

      SUBROUTINE SOPEN(MXDATA,DATA,NDATA,NSEQ,ISTAT)
C---
C--- OPEN FILE TO SEND THEM
C---
      INTEGER           MXDATA,DATA(*),NDATA,NSEQ,ISTAT

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG

      CHARACTER         FILNAM*19
      LOGICAL           QMARK
      INTEGER           I

      FILNAM = ' '
      QMARK = .FALSE.

      FOR I=1,MIN( NDATA, LEN(FILNAM) )
         FILNAM(I:I) = CHAR( DATA(I) )
         IF ( DATA(I) .EQ. ICHAR('?') ) QMARK = .TRUE.
      END FOR

C     CHECK FOR VALID WILDCARD FILE NAME AND OPEN THE FIRST FILE

      IF (QMARK) THEN
         CALL SWINIT(FILNAM,MXDATA,DATA,NDATA,NSEQ,ISTAT)

      ELSE
         CALL SWCLOS()

C     CHECK FOR VALID FILE NAME AND OPEN THE FILE

         WRITE (*,*) 'OPENING ', FILNAM(1:NDATA), ' FOR SEND'

         OPEN (UNIT=50, FILE=FILNAM, STATUS='OLD', IOSTAT=ISTAT)

         IF (ISTAT .NE. 0) THEN
            CALL SNDERR('can''t find specified file',MXDATA,DATA,NSEQ)
         END IF

      END IF
      END

      SUBROUTINE SINIT(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
C---
C--- SEND INIT PACKET AND GET THEIRS IN RESPONSE
C---
      CHARACTER         STATE*1
      INTEGER           NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT

      INTEGER           NDATA,RSEQ

C     SEND OUR INIT PACKET

      CALL SPAR(MXDATA,DATA,NDATA)

      CALL SNDPKT(DATA,NDATA,NSEQ,'S')

C     GET THEIR INIT PACKET IN RESPONSE

      CALL RCVACK(MXDATA,DATA,NDATA,NSEQ,ISTAT)
      IF (ISTAT .LT. 0) GO TO 800   ! RECEIVED ERR
      IF (ISTAT .NE. 0) GO TO 810   ! RECEIVED NAK

100   CALL RPAR(DATA,NDATA)
      GO TO 900

800   ISTAT = -1  ! ABORT
      STATE = 'A'
      RETURN

810   ISTAT = 1   ! UNSUCCESSFUL
      RETURN

900   ISTAT = 0   ! SUCCESSFUL
      STATE = 'F'
      RETURN
      END

      SUBROUTINE SFILE(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
C---
C--- SEND FILE HEADER PACKET
C---
      CHARACTER         STATE*1
      INTEGER           NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG

      CHARACTER         FILNAM*17
      LOGICAL           OPENED,NAMED
      INTEGER           NDATA,MXRCV,C,I

C     SEND FILE NAME

      IF (NUMTRY .EQ. 1) THEN
         INQUIRE (UNIT=50, OPENED=OPENED, NAMED=NAMED, NAME=FILNAM)
         IF (.NOT. (OPENED .AND. NAMED) ) THEN
            CALL SNDERR('read file error',MXDATA,DATA,NSEQ)
            GO TO 800
         END IF

         NDATA = 0
         FOR I=9,16  ! AREANAME
            C = ICHAR( FILNAM(I:I) )
            DATA(I-8) = C
            IF (C .NE. ICHAR(' ')) NDATA = I-8
         END FOR
CCC
CCC THE FOLLOWING LINES ARE COMMENTED OUT.  THEY CAN BE RESTORED
CCC IF ONE DESIRES TO USE THE FIRST THREE ALPHABETIC CHARACTERS
CCC OF THE QUALIFIER AS THE FILENAME EXTENSION, E.G. FOR DOS MACHINES.
CCC
CCC         NDATA = NDATA + 1
CCC         DATA(NDATA) = ICHAR('.')
CCC         FOR I=5,7   ! PART OF QUALIFIER
CCC            C = ICHAR( FILNAM(I:I) )
CCC            IF (C .NE. ICHAR(' ')) THEN
CCC               NDATA = NDATA + 1
CCC               DATA(NDATA) = C
CCC            END IF
CCC         END FOR

         CALL SNDPKT(DATA,NDATA,NSEQ,'F')
      ELSE
         CALL RESEND
      END IF

C     GET THEIR RESPONSE

      MXRCV = 0
      CALL RCVACK(MXRCV,DATA,NDATA,NSEQ,ISTAT)
      IF (ISTAT .LT. 0) GO TO 800   ! RECEIVED ERR
      IF (ISTAT .NE. 0) GO TO 810   ! RECEIVED NAK

C     PREPARE TO READ FILE

      CALL RDINIT(ISTAT)
      IF (ISTAT .NE. 0) GO TO 910
      GO TO 900

800   ISTAT = -1  ! ABORT
      STATE = 'A'
      RETURN

810   ISTAT = 1   ! UNSUCCESSFUL
      RETURN

900   ISTAT = 0   ! SUCCESSFUL
      STATE = 'D'
      RETURN

910   ISTAT = 0   ! SUCCESSFUL BUT EMPTY FILE
      STATE = 'Z'
      RETURN
      END

      SUBROUTINE SDATA(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
C---
C--- SEND FILE DATA PACKET
C---
      CHARACTER         STATE*1
      INTEGER           NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT

      INTEGER           MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
      COMMON /RCVCOM/   MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME

      LOGICAL           ISCTRL
      INTEGER           CTL
      LOGICAL           EOF
      INTEGER           NDATA,NEWCHR,MXRCV

C     GET NEXT PACKETFULL OF DATA AND SEND IT

      IF (NUMTRY .EQ. 1) THEN
         NDATA = 0
         EOF = .FALSE.

C        GET NEXT CHARACTER FROM THE DISK FILE
100      IF (EOF .OR. NDATA+2 .GT. MXDATA) GO TO 200

         CALL RDISK(NEWCHR,ISTAT)
         IF (ISTAT .NE. 0) EOF = .TRUE.

C        QUOTE IF SPECIAL CHARACTER, THEN COPY TO THE PACKET BUFFER
         IF ( ISCTRL(NEWCHR) .OR. (NEWCHR .EQ. MYQUOT) ) THEN
            NDATA = NDATA + 1
            DATA(NDATA) = MYQUOT
            IF ( NEWCHR .NE. MYQUOT ) NEWCHR = CTL(NEWCHR)              SR 9/86
         END IF

         NDATA = NDATA + 1
         DATA(NDATA) = NEWCHR
         GO TO 100

200      CALL SNDPKT(DATA,NDATA,NSEQ,'D')
      ELSE
         CALL RESEND
      END IF

C     GET THEIR RESPONSE

      MXRCV = 0
      CALL RCVACK(MXRCV,DATA,NDATA,NSEQ,ISTAT)
      IF (ISTAT .LT. 0) GO TO 800   ! RECEIVED ERR
      IF (ISTAT .NE. 0) GO TO 810   ! RECEIVED NAK
      IF (EOF) GO TO 910
      GO TO 900

800   ISTAT = -1  ! ABORT
      STATE = 'A'
      RETURN

810   ISTAT = 1   ! UNSUCCESSFUL
      RETURN

900   ISTAT = 0   ! SUCCESSFUL
      RETURN

910   ISTAT = 0   ! SUCCESSFUL AND AT END-OF-FILE
      STATE = 'Z'
      RETURN
      END

      SUBROUTINE SEOF(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
C---
C--- SEND END-OF-FILE PACKET
C---
      CHARACTER         STATE*1
      INTEGER           NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT

      LOGICAL           WLDSND
      COMMON /SWCOM/    WLDSND

      INTEGER           NDATA

C     CLOSE FILE AND SEND EMPTY "Z" PACKET

      IF (NUMTRY .EQ. 1) THEN
         CALL RDCLOS
         NDATA = 0
         CALL SNDPKT(DATA,NDATA,NSEQ,'Z')
      ELSE
         CALL RESEND
      END IF

C     GET THEIR RESPONSE

      CALL RCVACK(MXDATA,DATA,NDATA,NSEQ,ISTAT)
      IF (ISTAT .LT. 0) GO TO 800   ! RECEIVED ERR
      IF (ISTAT .NE. 0) GO TO 810   ! RECEIVED NAK
      WRITE (*,*) '=SEND OF CURRENT FILE COMPLETE='

C     IF THERE ARE MORE FILES TO SEND, OPEN THE NEXT FILE
      IF (WLDSND) THEN
         CALL SWOPEN(ISTAT)
         IF (ISTAT .LT. 0) THEN
            CALL SNDERR('can''t find specified file',MXDATA,DATA,NSEQ)
            GO TO 800
         END IF
      END IF
      GO TO 900

800   ISTAT = -1  ! ABORT
      STATE = 'A'
      RETURN

810   ISTAT = 1   ! UNSUCCESSFUL
      RETURN

900   ISTAT = 0   ! SUCCESSFUL
      IF (WLDSND) THEN
         STATE = 'F'
      ELSE
         STATE = 'B'
      END IF
      RETURN
      END

      SUBROUTINE SBREAK(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
C---
C--- SEND END-OF-FILE PACKET
C---
      CHARACTER         STATE*1
      INTEGER           NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT

      INTEGER           NDATA

C     SEND EMPTY "B" PACKET

      NDATA = 0
      CALL SNDPKT(DATA,NDATA,NSEQ,'B')

C     GET THEIR RESPONSE

      CALL RCVACK(MXDATA,DATA,NDATA,NSEQ,ISTAT)
      IF (ISTAT .LT. 0) GO TO 800   ! RECEIVED ERR
      IF (ISTAT .NE. 0) GO TO 810   ! RECEIVED NAK
      GO TO 900

800   ISTAT = -1  ! ABORT
      STATE = 'A'
      RETURN

810   ISTAT = 1   ! UNSUCCESSFUL
      RETURN

900   ISTAT = 0   ! SUCCESSFUL
      STATE = 'C'
      RETURN
      END

      SUBROUTINE RDISK(NEWCHR,ISTAT)
C---
C--- READS A SINGLE CHARACTER FROM A DISK FILE
C---
C--- ENTRY POINT "RDINIT" INITIALIZES
C--- ENTRY POINT "RDCLOS" FINISHES
C---
      INTEGER           NEWCHR,ISTAT

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG

      INTEGER    MAXW,MAXC
      PARAMETER (MAXW=100, MAXC=3*MAXW)
      INTEGER           BUFW(MAXW)
      INTEGER*1         BUFC(MAXC+9)
      EQUIVALENCE (BUFW,BUFC)

      LOGICAL           EOF
      INTEGER           IBUF,NBUF,NBUFW,CR,LF,I
      SAVE              EOF,BUFW,IBUF,NBUF

      DATA EOF /.TRUE./
      DATA CR, LF /13, 10/

      IF (EOF) THEN
         IF (DEBUG) WRITE (*,*) '*FATAL ERROR*  RDISK NOT INITIALIZED'
         STOP
      END IF

C     GET NEXT CHARACTER FROM BUFFER
      IBUF = IBUF + 1
      NEWCHR = BUFC(IBUF)

C     SEE IF WE HAVE JUST EMPTIED THE BUFFER
100   IF (IBUF .GE. NBUF) THEN
         IBUF = 0
         NBUF = 0

C        READ NEXT RECORD FROM DISK
         BUFFER IN(50,BUFW,S,MAXW,ISTAT,NBUFW)
         CALL STATUS(50)
         IF (ISTAT .NE. 2 .AND. ISTAT .NE. 3) THEN
            IF (DEBUG .AND. ISTAT .NE. 4)
     +         WRITE (*,*) 'RDISK: DISK READ ERROR ON BUFFER IN', ISTAT
            EOF = .TRUE.
            GO TO 800
         END IF

C        FIND LENGTH TO LAST NON-BLANK
         FOR I=NBUFW*3,1,-1
            IF (BUFC(I) .NE. ICHAR(' ')) THEN
               NBUF = I
               EXIT FOR
            END IF
         END FOR

C        APPEND "<EOF>" IF AN EMBEDDED EOF WAS FOUND
         IF (ISTAT .EQ. 3) THEN
            IF (DEBUG) WRITE (*,*) '(FOUND EMBEDDED EOF)'
            IF (NBUF .GT. 0) THEN
               NBUF = NBUF + 1
               BUFC(NBUF) = CR
               NBUF = NBUF + 1
               BUFC(NBUF) = LF
            END IF
            NBUF = NBUF + 1
            BUFC(NBUF) = '<'
            NBUF = NBUF + 1
            BUFC(NBUF) = 'E'
            NBUF = NBUF + 1
            BUFC(NBUF) = 'O'
            NBUF = NBUF + 1
            BUFC(NBUF) = 'F'
            NBUF = NBUF + 1
            BUFC(NBUF) = '>'
         END IF

C        APPEND CR/LF
         NBUF = NBUF + 1
         BUFC(NBUF) = CR
         NBUF = NBUF + 1
         BUFC(NBUF) = LF

      END IF
      GO TO 900

800   ISTAT = 1   ! EOF OR ERROR (CURRENT CHARACTER IS THE LAST ONE)
      RETURN

900   ISTAT = 0   ! SUCCESSFUL
      RETURN

C---
C--- INITIALIZE AND READ FIRST RECORD
C---
      ENTRY RDINIT(ISTAT)

      IBUF = 0
      NBUF = 0
      EOF = .FALSE.
      GO TO 100

C---
C--- CLOSE FILE
C---
      ENTRY RDCLOS

      IF (.NOT. EOF) THEN
         IF (DEBUG) WRITE (*,*) '*WARNING* SENT INCOMPLETE FILE'
         NBUF = 0
      END IF
      CLOSE (UNIT=50)
      RETURN
      END

      SUBROUTINE SWINIT(AREANM,MXDATA,DATA,NDATA,NSEQ,ISTAT)
C---
C--- ASSEMBLE A LIST OF NAMES OF FILES TO SEND IN RESPONSE TO A
C--- "GET" COMMAND CONTAINING WILDCARD CHARACTERS
C---
      CHARACTER         AREANM*(*)
      INTEGER           MXDATA,DATA(*),NDATA,NSEQ,ISTAT

      CHARACTER         DIRFIL*17, ERRMSG*80
      LOGICAL           SIZEORD
      INTEGER           LFN,NARGC,NEWCHR,I

      DATA DIRFIL /'W1'/
      DATA LFN /99/

C     CONVERT THE FILE NAME TO UPPER CASE

      NARGC = MIN( NDATA, LEN(AREANM) )
      FOR I=1,NARGC
         NEWCHR = ICHAR( AREANM(I:I) )
         IF (NEWCHR .GT. ICHAR('a') .AND. NEWCHR .LT. ICHAR('z') ) THEN
            NEWCHR = NEWCHR - ICHAR('a') + ICHAR('A')
            AREANM(I:I) = CHAR( NEWCHR )
         END IF
      END FOR

C     OPEN A DIRECTORY WORKFILE

      OPEN (UNIT=LFN, FILE=DIRFIL, STATUS='OLD', IOSTAT=ISTAT)
      IF (ISTAT .NE. 0) GO TO 810

      REWIND (UNIT=LFN)

C     WRITE DIRECTORY INFORMATION TO THE WORKFILE

      SIZEORD  = .FALSE.

      CALL DIR(LFN,AREANM,NARGC,SIZEORD,ERRMSG,ISTAT)
      IF (ISTAT .NE. 0) GO TO 800

C     PREPARE TO SEND THE FIRST FILE
      REWIND (UNIT=LFN)

      CALL SWOPEN(ISTAT)
      IF (ISTAT .NE. 0) GO TO 820
      GO TO 900

800   CALL SNDERR(ERRMSG,MXDATA,DATA,NSEQ)
      CLOSE (UNIT=LFN)
      RETURN

810   CALL SNDERR('directory workfile inaccessable',MXDATA,DATA,NSEQ)
      RETURN

820   CALL SNDERR('file not accessible',MXDATA,DATA,NSEQ)
      RETURN

900   RETURN
      END

      SUBROUTINE SWOPEN(ISTAT)
C---
C--- OPEN THE NEXT FILE IN A LIST OF FILES TO SEND
C---
      INTEGER           ISTAT

      CHARACTER         FILNAM*19, BUF*80
      INTEGER           LFN

      LOGICAL           WLDSND
      COMMON /SWCOM/    WLDSND

      DATA LFN /99/

C     READ NEXT ENTRY FROM THE FILE NAME LIST
      DO
         READ (LFN, '(A)', END=800) BUF
      UNTIL ( BUF(9:9) .EQ. '*' .OR. BUF(16:16) .EQ. '*' )

      IF ( BUF(9:9) .EQ. '*' ) THEN
         FILNAM = '"' // BUF(1:17) // '"'
      ELSE
         FILNAM = '"' // BUF(8:24) // '"'
      END IF

      WRITE (*,*) 'OPENING ', FILNAM, ' FOR SEND'

      OPEN (UNIT=50, FILE=FILNAM, STATUS='OLD', IOSTAT=ISTAT)
      IF (ISTAT .NE. 0) GO TO 810
      GO TO 900

800   ISTAT = 1   ! NO MORE FILE NAMES IN LIST
      CALL SWCLOS()
      WLDSND = .FALSE.
      RETURN

810   ISTAT = -1  ! FILE OPEN UNSUCCESFUL
      WLDSND = .FALSE.
      RETURN

900   ISTAT = 0   ! FILE OPEN SUCCESFUL
      WLDSND = .TRUE.
      END

      SUBROUTINE SWCLOS()
C---
C--- CLOSE THE FILE CONTAINING THE LIST OF FILES TO SEND
C---
      INTEGER           LFN

      LOGICAL           WLDSND
      COMMON /SWCOM/    WLDSND

      DATA LFN /99/

C     IF THE FILE IS OPEN, CLOSE IT
      IF (WLDSND) THEN
         CLOSE (UNIT=LFN)
         WLDSND = .FALSE.
      END IF
      END
C RECEIVE SUBROUTINES
C
C     RECVSW   -- PACKET TYPE SWITCHER FOR RECEIVING FILES
C     RINIT    -- EXCHANGE SEND/RECEIVE INFO WITH SENDING KERMIT
C     RFILE    -- RECIEVES FILE NAME AND CREATES RECEIVE FILE
C     RDATA    -- RECEIVES FILE CONTENTS FROM SENDING KERMIT
C     REOF     -- RECEIVES "END-OF-FILE" PACKET FROM SENDING KERMIT
C     RBREAK   -- RECEIVES "BREAK" PACKET FROM SENDING KERMIT
C     WDISK    -- WRITES A SINGLE CHARACTER TO A DISK FILE
C     ENPAD    -- PADS OUTPUT RECORD TO A WORD BOUNDARY
C     DELFIL   -- DELETES A FILE PARTIALLY RECEIVED
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE RECVSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)
C---
C--- THIS IS THE PACKET TYPE SWITCHER FOR RECEIVING FILES.
C--- IT LOOPS UNTIL EITHER IT IS FINISHED OR A FAULT IS ENCOUNTERED.
C---
      INTEGER           MXDATA,DATA(*),NDATA,NSEQ,MAXTRY

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG

      LOGICAL           FILOPN
      INTEGER           NUMTRY,OLDSEQ,ISTAT
      CHARACTER         STATE*1,TYPE*1

      STATE = 'I'
      TYPE = 'I'
      FILOPN = .FALSE.
      OLDSEQ = NSEQ

100   IF      (TYPE .EQ. 'I') THEN           ! GOT INIT PACKET
         CALL RINIT(STATE,MXDATA,DATA,NDATA,NSEQ)

      ELSE IF (TYPE .EQ. 'F') THEN           ! GOT FILE-HEADER PACKET
         CALL RFILE(STATE,MXDATA,DATA,NDATA,NSEQ,ISTAT)
         IF (ISTAT .EQ. 0) FILOPN = .TRUE.

      ELSE IF (TYPE .EQ. 'D') THEN           ! GOT FILE-DATA PACKET
         CALL RDATA(STATE,MXDATA,DATA,NDATA,NSEQ)

      ELSE IF (TYPE .EQ. 'Z') THEN           ! GOT EOF PACKET
         CALL REOF(STATE,MXDATA,DATA,NDATA,NSEQ,ISTAT)
         IF (ISTAT .EQ. 0) FILOPN = .FALSE.

      ELSE IF (TYPE .EQ. 'B') THEN           ! GOT BREAK PACKET
         CALL RBREAK(STATE,MXDATA,DATA,NDATA,NSEQ)

      ELSE IF (TYPE .EQ. 'E') THEN           ! GOT ERROR PACKET
         NDATA = 0
         CALL SNDACK(DATA,NDATA,NSEQ)
         STATE = 'A'

      ELSE
         IF (DEBUG) WRITE (*,*) 'INVALID PACKET TYPE'
         STATE = 'A'
      END IF

      IF (STATE .EQ. 'A') GO TO 800          ! ABORT

      IF (STATE .EQ. 'C') GO TO 900          ! COMPLETE

C     RECEIVE A NEW PACKET
      FOR NUMTRY=1,MAXTRY

         CALL RCVPKT(MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT)
         IF (ISTAT .EQ. 0) THEN

C           GOT THE RIGHT PACKET?
CCC            IF (NSEQ .EQ. MOD( OLDSEQ+1, 64 ) ) THEN                 SR11/86
            IF (NSEQ .EQ. MOD( OLDSEQ+1, 64 ) .OR. TYPE .EQ. 'E') THEN  SR11/86
               OLDSEQ = NSEQ
               GO TO 100

C           NO. GOT PREVIOUS PACKET AGAIN BY MISTAKE?
            ELSE IF (NSEQ .EQ. OLDSEQ) THEN
               IF (NUMTRY .LT. MAXTRY) CALL RESEND
               GO TO 200
            END IF
         END IF

C        NO. NAK IT AND TRY AGAIN UP TO MAXTRY TIMES
         IF (NUMTRY .LT. MAXTRY) CALL SNDNAK(NSEQ)

200      CONTINUE
      END FOR
      CALL SNDERR('too many retries',MXDATA,DATA,NSEQ)
      GO TO 800

800   IF (DEBUG) WRITE (*,*) '--- ABORT ---'
      IF (FILOPN) CALL DELFIL                ! ERASE PARTIAL FILE
      RETURN

900   IF (DEBUG) WRITE (*,*) '=== RECEIVE COMPLETE ==='
      RETURN
      END

      SUBROUTINE RINIT(STATE,MXDATA,DATA,NDATA,NSEQ)
C---
C--- GOT RECEIVE-INIT PACKET, RESPOND WITH ACK AND OUR PARAMETERS
C---
      CHARACTER         STATE*1
      INTEGER           MXDATA,DATA(*),NDATA,NSEQ

      CALL INIT(MXDATA,DATA,NDATA,NSEQ)

      STATE = 'F'
      END

      SUBROUTINE RFILE(STATE,MXDATA,DATA,NDATA,NSEQ,ISTAT)
C---
C--- GOT FILE HEADER PACKET, CREATE THE SPECIFED FILE
C---
      CHARACTER         STATE*1
      INTEGER           MXDATA,DATA(*),NDATA,NSEQ,ISTAT

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG

      LOGICAL           WRKFIL
      CHARACTER         FILNAM*40
      INTEGER           IDOT,IAST,I

      IF (STATE .NE. 'F') THEN
         CALL SNDERR('not expecting F packet',MXDATA,DATA,NSEQ)
         GO TO 800
      END IF

C     ASSEMBLE HARRIS FILE NAME

      FILNAM = ' '
      IDOT = 0
      IAST = 0
      NDATA = MIN( NDATA, MXDATA, LEN(FILNAM) )

      FOR I=1,NDATA
         FILNAM(I:I) = CHAR( DATA(I) )
         IF (FILNAM(I:I) .EQ. '.') IDOT = I
         IF (FILNAM(I:I) .EQ. '*') IAST = I
      END FOR

      IF (IDOT .GT. 0 .AND. IAST .EQ. 0) THEN
C        TRANSLATE IBM-PC STYLE FILENAME
         IF (IDOT .EQ. NDATA) THEN
            NDATA = MIN( 8, IDOT-1 )
         ELSE IF (NDATA .GT. 8) THEN
            NDATA = 8
            IF (IDOT .GT. 7) FILNAM(7:8) = '.' // CHAR( DATA(IDOT+1) )
         END IF
      END IF

C     MAKE SURE THE FILE NAME IS VALID AND RESPOND

      WRITE (*,*) 'OPENING FILE ', FILNAM(1:NDATA), ' FOR RECEIVE'
      OPEN(UNIT=50, FILE=FILNAM(1:NDATA), STATUS='OLD', IOSTAT=ISTAT)

      IF (ISTAT .EQ. 0) THEN
         IF (WRKFIL(50)) GO TO 200
         CLOSE (UNIT=50)
         CALL SNDERR( FILNAM(1:NDATA) // ' exists', MXDATA,DATA,NSEQ)
         GO TO 800
      END IF

      OPEN(UNIT=50, FILE=FILNAM(1:NDATA), STATUS='NEW', IOSTAT=ISTAT)

      IF (ISTAT .NE. 0) THEN
C        CAN'T CREATE FILE
         CALL SNDERR( 'filename ' // FILNAM(1:NDATA) // ' is invalid',
     +      MXDATA,DATA,NSEQ)
         GO TO 800
      END IF

200   CALL WDINIT

      NDATA = 0
      CALL SNDACK(DATA,NDATA,NSEQ)
      GO TO 900

800   ISTAT = -1
      STATE = 'A'
      RETURN

900   ISTAT = 0
      STATE = 'D'
      RETURN
      END

      SUBROUTINE RDATA(STATE,MXDATA,DATA,NDATA,NSEQ)
C---
C--- GOT DATA PACKET, WRITE TO FILE
C---
      CHARACTER         STATE*1
      INTEGER           MXDATA,DATA(*),NDATA,NSEQ

      INTEGER           MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
      COMMON /SNDCOM/   MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME

      INTEGER           CTL
      INTEGER           IDATA,NEWCHR

      IF (STATE .NE. 'D') THEN
         CALL SNDERR('not expecting D packet',MXDATA,DATA,NSEQ)
         GO TO 800
      END IF

C     UNPACK DATA AND WRITE TO FILE

      IDATA = 0

C     EXTRACT NEXT CHARACTER OF DATA FROM PACKET
100   IF (IDATA .GE. NDATA) GO TO 200
      IDATA = IDATA + 1
      NEWCHR = DATA(IDATA)

      IF (NEWCHR .EQ. NSQUOT) THEN  ! UNCONTROLLIFY QUOTED CHARACTER
         IF (IDATA .LT. NDATA) THEN
            IDATA = IDATA + 1
            NEWCHR = DATA(IDATA)
            IF (NEWCHR .NE. NSQUOT) NEWCHR = CTL( NEWCHR )
         END IF
      END IF

C     TRANSFER IT TO THE DISK FILE
      CALL WDISK(NEWCHR)
      GO TO 100

200   NDATA = 0
      CALL SNDACK(DATA,NDATA,NSEQ)
      GO TO 900

800   STATE = 'A'
      RETURN

900   STATE = 'D'
      RETURN
      END

      SUBROUTINE REOF(STATE,MXDATA,DATA,NDATA,NSEQ,ISTAT)
C---
C--- GOT EOF PACKET, CLOSE FILE
C---
      CHARACTER         STATE*1
      INTEGER           MXDATA,DATA(*),NDATA,NSEQ,ISTAT

      IF (STATE .EQ. 'F') GO TO 100
      IF (STATE .NE. 'D') THEN
         CALL SNDERR('not expecting Z packet',MXDATA,DATA,NSEQ)
         GO TO 800
      END IF

C     HANDLE SPECIAL Z PACKET INSTRUCTING US TO DISCARD CURRENT FILE
      IF (NDATA .EQ. 1 .AND. DATA(1) .EQ. ICHAR('D') ) THEN
         CALL DELFIL

      ELSE
         CALL WDCLOS
         WRITE (*,*) '=RECEIVE OF CURRENT FILE COMPLETE='
      END IF

100   NDATA = 0
      CALL SNDACK(DATA,NDATA,NSEQ)
      GO TO 900

800   ISTAT = -1
      STATE = 'A'
      RETURN

900   ISTAT = 0
      STATE = 'F'
      RETURN
      END

      SUBROUTINE RBREAK(STATE,MXDATA,DATA,NDATA,NSEQ)
C---
C--- GOT BREAK PACKET, WE'RE DONE
C---
      CHARACTER         STATE*1
      INTEGER           MXDATA,DATA(*),NDATA,NSEQ

      IF (STATE .NE. 'F') THEN
         CALL SNDERR('not expecting B packet',MXDATA,DATA,NSEQ)
         GO TO 800
      END IF

      NDATA = 0
      CALL SNDACK(DATA,NDATA,NSEQ)
      GO TO 900

800   STATE = 'A'
      RETURN

900   STATE = 'C'
      RETURN
      END

      SUBROUTINE WDISK(NEWCHR)
C---
C--- WRITES A CHARACTER TO A DISK FILE
C---
C--- ENTRY POINT "WDINIT" INITIALIZES
C--- ENTRY POINT "WDCLOS" FINISHES
C---
      INTEGER           NEWCHR

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG

      INTEGER    MAXW,MAXC
      PARAMETER (MAXW=100, MAXC=3*MAXW)
      INTEGER           BUFW(MAXW)
      INTEGER*1         BUFC(MAXC)
      EQUIVALENCE (BUFW,BUFC)

      INTEGER           NBUF,CR,LF,I
      SAVE              BUFW,NBUF

      DATA CR, LF /13, 10/

      IF (NEWCHR .EQ. CR) THEN
C        WRITE COMPLETED RECORD
         CALL ENPAD(BUFC,NBUF)
         WRITE (50,'(100A3)') (BUFW(I), I=1,NBUF/3)
         NBUF = 0

      ELSE IF (NEWCHR .EQ. LF .AND. NBUF .EQ. 0) THEN
C        IGNORE LINEFEED FROM A CR/LF PAIR

      ELSE
C        ADD CHARACTER TO RECORD BUFFER
         NBUF = NBUF + 1
         BUFC(NBUF) = NEWCHR
      END IF
      RETURN

C---
C--- INITIALIZE CHARACTER COUNT
C---
      ENTRY WDINIT()

      NBUF = 0
      RETURN

C---
C--- WRITE LAST RECORD IF INCOMPLETE AND CLOSE FILE
C---
      ENTRY WDCLOS()

      IF (NBUF .GT. 0) THEN
         IF (DEBUG) WRITE (*,*) '*WARNING* NO EOL FOUND ON LAST RECORD'
         CALL ENPAD(BUFC,NBUF)
         WRITE (50,'(100A3)') (BUFW(I), I=1,NBUF/3)
         NBUF = 0
      END IF
      CLOSE (UNIT=50)
      RETURN
      END

      SUBROUTINE ENPAD(BUFC,NBUF)
C---
C--- PAD OUTPUT RECORD TO WORD BOUNDARY WITH BLANKS
C---
      INTEGER*1         BUFC(*)
      INTEGER           NBUF

      INTEGER           I

      FOR I=MOD(NBUF+2,3),1
         NBUF = NBUF + 1
         BUFC(NBUF) = ICHAR(' ')
      END FOR
      END

      SUBROUTINE DELFIL
C---
C--- ERASE PARTIAL FILE ---NOT IMPLEMENTED YET---
C---
      WRITE (*,*) '-CURRENT RECEIVE CANCELLED-'
      CLOSE (UNIT=50)
      END
C REMOTE COMMAND SUBROUTINES
C
C     COMMND   -- REMOTE COMMAND HANDLER, CALLS THE FOLLOWING:
C     HELP     -- SENDS USAGE INFORMATION TO RECEIVING KERMIT
C     LOGOUT   -- PREPARES TO SIGN THE CURRENT USER OFF THE SYSTEM
C     FINISH   -- PREPARES TO EXIT KERMIT SERVER
C     DIRECT   -- SENDS DIRECTORY INFORMATION TO RECEIVING KERMIT
C     CMDARG   -- EXTRACT A COMMAND ARGUMENT FROM PACKET
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE COMMND(MXDATA,DATA,NDATA,NSEQ,MAXTRY,ISTAT)
C---
C--- MAIN ROUTINE HANDLING REMOTE COMMANDS
C---
      INTEGER           MXDATA,DATA(*),NDATA,NSEQ,MAXTRY,ISTAT

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG

      CHARACTER*1       CMD

C     GET THE COMMAND

      IF (NDATA .LE. 0) GO TO 900
      CMD = CHAR( DATA(1) )

      IF      (CMD .EQ. 'H') THEN            ! HELP
         CALL HELP(MAXTRY,MXDATA,DATA)

      ELSE IF (CMD .EQ. 'L') THEN            ! LOGOUT
         CALL LOGOUT(MAXTRY,MXDATA,DATA)
         GO TO 800

      ELSE IF (CMD .EQ. 'F') THEN            ! FINISH
         CALL FINISH(MAXTRY,MXDATA,DATA)
         GO TO 800

      ELSE IF (CMD .EQ. 'D') THEN            ! DIRECTORY
         CALL DIRECT(MAXTRY,MXDATA,DATA,NDATA)

      ELSE
         CALL SNDERR('remote command not implemented',MXDATA,DATA,NSEQ)
      END IF
      GO TO 900

800   ISTAT = 1   ! RETURN THEN EXIT PROGRAM
      RETURN

900   ISTAT = 0   ! NORMAL RETURN
      RETURN
      END

      SUBROUTINE HELP(MAXTRY,MXDATA,DATA)
C---
C--- SEND FILE CONTAINING USAGE INFORMATION
C---
      INTEGER           MAXTRY,MXDATA,DATA(*)

      CHARACTER         HLPFIL*17
      INTEGER           NDATA,NSEQ,PREFIX

      DATA HLPFIL /'2000KERM*HARRIS'/

      PREFIX = 0
      CALL PUTDAT(HLPFIL,PREFIX,MXDATA,DATA,NDATA)

      NSEQ = 0
      CALL SENDSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)

      RETURN
      END

      SUBROUTINE LOGOUT(MAXTRY,MXDATA,DATA)
C---
C--- SEND CONFIRMATION MESSAGE AND DO A JOBCNTRL $OFF
C---
      INTEGER           MAXTRY,MXDATA,DATA(*)

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG

      INTEGER           NWORDS
      PARAMETER (NWORDS=2)
      INTEGER           VOSCMD(NWORDS)

      CHARACTER         MSG*80
      INTEGER           NSEQ,USER(4),PREFIX,NDATA,ISTAT

      NSEQ = 0

C     PUT JOBCNTRL $OFF COMMAND IN LFN 0 BUFFER

      VOSCMD(1) = 3H$OF
      VOSCMD(2) = 3HF

      CALL BKSTOR(0,VOSCMD,NWORDS,ISTAT)
      IF (ISTAT .NE. 0) THEN
         CALL SNDERR('unable to sign off',MXDATA,DATA,NSEQ)
         RETURN
      END IF

      BACKSPACE (UNIT=0)

C     COPY LOGOUT MESSAGE INTO DATA ARRAY

      CALL USERNO( USER )
      WRITE (MSG,1000) USER
 1000 FORMAT ('SEE YOU LATER, ',4A3)

      PREFIX = 1
      CALL PUTDAT(MSG,PREFIX,MXDATA,DATA,NDATA)

C     ACK WITH OUR CONFIRMATION MESSAGE
      CALL SNDACK(DATA,NDATA,NSEQ)
      END

      SUBROUTINE FINISH(MAXTRY,MXDATA,DATA)
C---
C--- SEND CONFIRMATION MESSAGE AND EXIT PROGRAM
C---
      INTEGER           MAXTRY,MXDATA,DATA(*)

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG

      INTEGER           NSEQ,PREFIX,NDATA

C     COPY EXIT MESSAGE INTO DATA ARRAY
      PREFIX = 1
      CALL PUTDAT('returning to JOBCNTRL',PREFIX,MXDATA,DATA,NDATA)

C     ACK WITH OUR CONFIRMATION MESSAGE
      NSEQ = 0
      CALL SNDACK(DATA,NDATA,NSEQ)
      END

      SUBROUTINE DIRECT(MAXTRY,MXDATA,DATA,NDATA)
C---
C--- SEND DIRECTORY INFORMATION ABOUT A SINGLE DISK AREA
C---
      INTEGER           MAXTRY,MXDATA,DATA(*),NDATA

      CHARACTER         DIRFIL*17, AREANM*19, ERRMSG*80
      LOGICAL           SIZEORD
      INTEGER           LFN,NSEQ,ICOL,NARGC,PREFIX,ISTAT,I

      DATA DIRFIL /'W1'/
      DATA LFN /99/

C     GET FILE NAME, OPTIONALLY CONTAINING WILDCARD CHARACTERS

      IF (NDATA .EQ. 1) THEN
         NARGC = 0
      ELSE
         ICOL = 2
         CALL CMDARG(ICOL, DATA,NDATA, DATA,NARGC, ISTAT)
         IF (ISTAT .NE. 0) GO TO 820
      END IF

      NARGC = MIN( NARGC, LEN(AREANM) )

      AREANM = ' '
      FOR I=1,NARGC
         AREANM(I:I) = CHAR( DATA(I) )
      END FOR

C     OPEN A DIRECTORY WORKFILE

      OPEN (UNIT=LFN, FILE=DIRFIL, STATUS='OLD', IOSTAT=ISTAT)
      IF (ISTAT .NE. 0) GO TO 810

      REWIND (UNIT=LFN)

C     WRITE DIRECTORY INFORMATION TO THE WORKFILE

      SIZEORD  = .FALSE.

      CALL DIR(LFN,AREANM,NARGC,SIZEORD,ERRMSG,ISTAT)
      IF (ISTAT .NE. 0) GO TO 800

      CLOSE (UNIT=LFN)

C     INVOKE THE SEND SWITCHER TO SEND THE WORKFILE

      PREFIX = 0
      CALL PUTDAT(DIRFIL,PREFIX,MXDATA,DATA,NDATA)

      NSEQ = 0
      CALL SENDSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)
      GO TO 900

800   CALL SNDERR(ERRMSG,MXDATA,DATA,NSEQ)
      RETURN

810   CALL SNDERR('directory workfile inaccessable',MXDATA,DATA,NSEQ)
      RETURN

820   CALL SNDERR('invalid command format',MXDATA,DATA,NSEQ)
      RETURN

900   RETURN
      END

      SUBROUTINE CMDARG(ICOL, DATA,NDATA, ARG,NARGC, ISTAT)
C---
C--- EXTRACT A LENGTH-ENCODED ARGUMENT FROM DATA FIELD
C---
      INTEGER           ICOL,DATA(*),NDATA,ARG(*),NARGC,ISTAT

      INTEGER           MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
      COMMON /SNDCOM/   MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME

      INTEGER           CTL,UNCHAR
      INTEGER           IDATA,IARGC,NEWCHR

C     READ STARTING AT CHARACTER POSITION <ICOL> IN ARRAY <DATA>

      NARGC = 0
      IDATA = ICOL

C     GET NEXT CHARACTER FROM <DATA>, UNCONTROLLIFYING AS NECESSARY

100   IF (IDATA .GT. NDATA) GO TO 800

      NEWCHR = DATA(IDATA)
      IDATA = IDATA + 1

      IF (NEWCHR .EQ. NSQUOT) THEN
         IF (IDATA .GT. NDATA) GO TO 800
         NEWCHR = DATA(IDATA)
         IDATA = IDATA + 1
         IF (NEWCHR .NE. NSQUOT) NEWCHR = CTL( NEWCHR )
      END IF

C     CONVERT TO UPPER CASE

      IF (NEWCHR .GT. ICHAR('a') .AND. NEWCHR .LT. ICHAR('z') ) THEN
         NEWCHR = NEWCHR - ICHAR('a') + ICHAR('A')
      END IF

C     FIRST CHARACTER IS LENGTH CODE

      IF (NARGC .EQ. 0) THEN
         IARGC = 0
         NARGC = UNCHAR( NEWCHR )

C     COPY SUBSEQUENT CHARACTERS TO <ARG>

      ELSE
         IARGC = IARGC + 1
         ARG(IARGC) = NEWCHR
      END IF

C     RETURN THE RESULT OF LENGTH <NARGC> IN ARRAY <ARG>

      IF (IARGC .GE. NARGC) THEN
         IF (IDATA .GT. NDATA) GO TO 900
         GO TO 810
      END IF

      GO TO 100

800   ISTAT = -1  ! CAN'T DECODE ARGUMENT (INVALID LENGTH CODE)
      RETURN

810   ISTAT = 1   ! SUCCESSFUL RETURN, MORE ARGUMENTS REMAIN
      RETURN

900   ISTAT = 0   ! SUCCESSFUL RETURN, THIS IS LAST ARGUMENT
      RETURN
      END
      SUBROUTINE DIR(LFN,AREANM,NC,SIZEORD,ERRMSG,ISTAT)
C
C CHECKS ALL AREANAMES AGAINST MATCH STRING, SAVING NECESSARY INFO
C ON THOSE WHICH MATCH IN COMMON.  WRITES RESULTS TO SPECIFIED LFN.
C
C ARGUMENTS:
C     LFN     -- LOGICAL UNIT TO WRITE RESULTS
C     AREANM  -- INPUT AREANAME, OPTIONALLY CONTAINING WILDCARDS
C     NC      -- NUMBER OF CHARACTERS IN AREANM
C     SIZEORD -- LOGICAL VARIABLE INDICATING ORDER BY SIZE IF TRUE
C     ERRMSG  -- TEXT STRING IDENTIFYING ERROR IF ISTAT NON-ZERO
C     ISTAT   -- ZERO=SUCCESSFUL COMPLETION; NON-ZERO=ERROR
C
      INTEGER     LFN, NC, ISTAT
      CHARACTER   AREANM*(*), ERRMSG*(*)
      LOGICAL     SIZEORD
C
      INTEGER     MXMAP
      PARAMETER (MXMAP=999)
      CHARACTER   NAME*17, TYPE*3, RWXD*11, OWNER*12
      INTEGER     SIZE, GRAN, NLINK, NFILES, IFIRST
      INTEGER     MAXS, EL(6),GE(6),LA(6),LW(6)
      COMMON /MAPDAT/ NAME(MXMAP), TYPE(MXMAP), RWXD(MXMAP),
     +  OWNER(MXMAP), SIZE(MXMAP), NLINK(MXMAP), NFILES, IFIRST
C
      INTEGER     NTOT, IPREV, INEXT
      INTEGER     NCHARS, ISTAR, IWILD, I
      REAL        KBYTES
C
C INITIALIZE FILE LIST
C
      NFILES = 0
      IFIRST = 0

      NTOT = 0
C
C PARSE MATCH STRING TO DETERMINE IF MORE THAN ONE AREANAME IS INVOLVED
C
      NCHARS = 0
      ISTAR = 0
      IWILD = 0

      FOR I=1,NC                       ! FIND SPECIAL CHARACTERS
         IF (AREANM(I:I) .NE. ' ') THEN
            NCHARS = I
            IF (AREANM(I:I) .EQ. '*') ISTAR = I
            IF (IWILD .EQ. 0 .AND.
     +          AREANM(I:I) .EQ. '?') IWILD = I
         END IF
      END FOR

      IF (ISTAR .EQ. NCHARS) THEN      ! DEFAULT AREANAME IS ?
         NCHARS = NCHARS + 1
         AREANM(NCHARS:NCHARS) = '?'
         IF (IWILD .EQ. 0) IWILD = I
      END IF
C
C IF ONLY A SINGLE AREANAME IS INDICATED, DO IT NOW
C
      IF (IWILD .EQ. 0) THEN

         CALL MAP(AREANM,
     +         NAME(1),TYPE(1),RWXD(1),SIZE(1),GRAN,MAXS,OWNER(1),
     +         EL,GE,LA,LW, ISTAT)
         IF (ISTAT .EQ. 0) THEN
            KBYTES = SIZE(1) * 336.0 / 1024.0
            WRITE (LFN,1100) NAME(1),OWNER(1),TYPE(1),RWXD(1),KBYTES,
     +                       GE,LW,LA
 1100 FORMAT (7X,A, T40,'OWNER: ',A,
     +       /'TYPE: ',A, 7X,'ACCESS: 'A, T40,'SIZE (KBYTES):',F7.1,
     +       /'CREATED:        ', 6A3,
     +       /'LAST UPDATED:   ', 6A3,
     +       /'LAST ACCESSED:  ', 6A3)
            GO TO 900
         ELSE
            ERRMSG = '*disc area not found*'
            GO TO 800
         END IF
      END IF
C
C MAKE SURE THEY DIDN'T WILDCARD ONLY PART OF THE QUALIFIER
C
      IF (IWILD .LT. ISTAR .AND. ISTAR .NE. 2) THEN
         ERRMSG =
     +      '*error* invalid qualifier, use "?*" for all qualifiers'
         GO TO 800
      END IF
C
C INITIALIZE THE CALL TO MAPWILD
C
      CALL MAPINIT(AREANM(1:NCHARS),ISTAT)
      IF (ISTAT .NE. 0) THEN
         ERRMSG = '*error* invalid qualifier or areaname'
         GO TO 800
      END IF
C
C LOOP THROUGH ALL FILES
C
      NTOT = 0

      LOOP

         I = NFILES + 1
         CALL MAPWILD(
     +         NAME(I),TYPE(I),RWXD(I),SIZE(I),GRAN,MAXS,OWNER(I),
     +         EL,GE,LA,LW, ISTAT)

         IF (ISTAT .LT. 0) THEN
            EXIT LOOP IF (ISTAT .EQ. -2)
            WRITE (LFN,*) '*error*  disc I/O error mapping file'
            GO TO 300
         END IF
C
C IF IT MATCHED, LINK INTO THE LIST IN SORTED ORDER
C
         NTOT = NTOT + 1
         IF (ISTAT .NE. 0) GO TO 200

         NFILES = I

         IPREV = 0
         INEXT = IFIRST
         WHILE (INEXT .GT. 0)
            IF (SIZEORD) THEN          ! ORDER BY SIZE
               EXIT WHILE IF ( SIZE(INEXT) .GT. SIZE(NFILES) )
               EXIT WHILE IF ( SIZE(INEXT) .EQ. SIZE(NFILES)
     +                   .AND. NAME(INEXT) .GE. NAME(NFILES) )
            ELSE                       ! ORDER BY NAME
               EXIT WHILE IF (NAME(INEXT) .GE. NAME(NFILES))
            END IF
            IPREV = INEXT
            INEXT = NLINK(INEXT)
         END WHILE

C        WE FOUND WHERE IT GOES, NOW LINK IT IN
         IF (IPREV .LE. 0) THEN        ! INSERT AT ROOT OF LIST
            NLINK(NFILES) = IFIRST
            IFIRST = NFILES
         ELSE                          ! INSERT INTO LIST
            NLINK(NFILES) = INEXT
            NLINK(IPREV) = NFILES
         END IF

200      CONTINUE

300   END LOOP
C
C WRITE SORTED RESULTS TO SPECIFIED UNIT
C
      IF (NFILES .LT. 1) THEN
         ERRMSG = '*disc area not found*'
         GO TO 800
      END IF

      WRITE (LFN,1500)

      I = IFIRST
      WHILE (I .GT. 0)
         KBYTES = SIZE(I) * 336.0 / 1024.0
         WRITE (LFN,1510) NAME(I),TYPE(I),RWXD(I),KBYTES,OWNER(I)
         I = NLINK(I)
      END WHILE

      IF (NTOT .GT. NFILES) WRITE (LFN,1520) NFILES, NTOT

 1500 FORMAT (4X,'AREANAME', 7X,'TYPE', 4X,'ACCESS',
     +        6X,'KBYTES', 4X,'OWNER')
 1510 FORMAT (A, 2X,A, 3X,A, F8.1, 5X,A)
 1520 FORMAT (/I4, ' files matched of', I5)
      GO TO 900

800   ISTAT = -1
      RETURN

900   ISTAT = 0
      RETURN
      END

      INTEGER FUNCTION ICOMP(MATCH,NM,STRING,NS)
C
C COMPARES A MATCH STRING, CONTAINING WILDCARD CHARACTERS, WITH AN
C OBJECT STRING.  RETURNS 0 IF MATCH SUCCEDED, 1 OTHERWISE
C
      CHARACTER      MATCH, STRING     ! MATCH AND COMPARE STRINGS
      INTEGER        NM, NS            ! LENGTHS OF ABOVE
C
      CHARACTER      C*1               ! CURRENT MATCH CHARACTER
      LOGICAL        AT                ! SET IF LAST CHARACTER WAS ?
      INTEGER        M                 ! MATCH STRING POINTER
      INTEGER        S                 ! COMPARE STRING POINTER
      INTEGER        LM                ! POINTER TO LAST ? PROCESSED
      INTEGER        LS                ! S AFTER LAST ?
      INTEGER        J
C
C INITIALIZE
C
      ICOMP = 1                        ! ASSUME NO MATCH

      M  = 1
      S  = 1
      LM = 0
      LS = 0
      AT = .FALSE.
C
C LOOP THROUGH MATCH CHARACTERS
C
10    WHILE (M .LE. NM)
         C = MATCH(M:M)                ! GET CURRENT MATCH CHARACTER
C
C       HANDLE ? CHARACTER
C
         IF (C .EQ. '?') THEN
            AT = .TRUE.
            LM = M
C
C       HANDLE OTHER CHARACTERS
C
         ELSE
            IF (S .GT. NS) RETURN      ! NO MORE CHARS IN SUBSTRING
            IF (AT) THEN               ! SKIP UNKNOWN CHARACTERS
               J = INDEX(STRING(S:NS),C)
               IF (J .EQ. 0) RETURN
               S = S + J
               LS = S
               AT = .FALSE.
            ELSE                       ! CHECK FOR EXACT MATCH
               IF (C .EQ. STRING(S:S)) THEN
                  S = S + 1
               ELSE                    ! NO MATCH
                  IF (LS .GT. 0) THEN
                     M = LM
                     S = LS
                     GO TO 10          ! BACK UP TO ?+1 AND TRY AGAIN
                  ELSE
                     RETURN
                  END IF
               END IF
            END IF
         END IF
         M = M + 1
      END WHILE
C
C MAKE SURE ANY REMAINING CHARACTERS IN STRING ARE TRAILING BLANKS
C
      IF (.NOT. AT) THEN
         IF (S .LE. NS) THEN
            IF (STRING(S:NS) .NE. ' ') THEN
               M = LM
               S = LS
               GO TO 10                ! BACK UP TO ?+1 AND TRY AGAIN
            END IF
         END IF
      END IF

      ICOMP = 0                        ! SUCCESSFUL MATCH

      END

      SUBROUTINE MAPINIT(AREANM,ISTAT),
     +           MAPWILD(NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER,
     +                   ELDATE,GEDATE,LADATE,LWDATE,ISTAT)
C
C     MAPWILD                                    FORTRAN 77 / ASSEMBLER
C     WRITTEN BY SKIP RUSSELL                          APRIL, 1983
C
C     SUBROUTINE TO RETURN INFORMATION ABOUT ALL DISK AREAS WHICH
C     SUCCESSFULLY MATCH A "WILDCARD" AREANAME STRING.
C
C     THE QUALIFIER OF THE MATCH STRING, IF SPECIFIED, DETERMINES
C     THE MAPPING OPERATION TO PERFORM AS FOLLOWS:
C
C     NO QUALIFIER SPECIFIED -- SEARCH FILES UNDER CURRENT QUALIFIER
C     VALID QUALIFIER        -- SEARCH FILES UNDER SPECIFIED QUALIFIER
C     QUALIFIER = "?"        -- SEARCH ALL FILES OWNED BY CURRENT USER
C
C
C MAPINIT: (INITIALIZATION FOR MAPWILD)
C     INPUT ARGUMENTS:
C        AREANM -- AREA NAME TO MATCH CONTAINING WILDCARD CHARACTERS
C        ISTAT  -- STATUS INDICATOR, AS FOLLOWS:
C                     0 = SUCCESSFUL
C                    -1 = INVALID NAME
C
C MAPWILD:
C     OUTPUT ARGUMENTS:
C        NAME   -- QUAL*AREA                        (CHARACTER*17)
C        TYPE   -- PROGRAM TYPE                     (CHARACTER*3)
C        RWXD   -- READ/WRITE/EXECUTE/DELETE ACCESS (CHARACTER*11)
C        SIZE   -- CURRENT SIZE IN SECTORS          (INTEGER)
C        GRAN   -- GRANULE SIZE IN SECTORS          (INTEGER)
C        MAXS   -- MAXIMUM SIZE IN SECTORS          (INTEGER)
C        OWNER  -- USER NAME OF THE OWNER           (CHARACTER*12)
C        ELDATE -- ELIMINATE DATE/TIME              (6 INTEGER ARRAY)
C        GEDATE -- GENERATE DATE/TIME               (6 INTEGER ARRAY)
C        LADATE -- LAST ACCESS DATE/TIME            (6 INTEGER ARRAY)
C        LWDATE -- LAST WRITE DATE/TIME             (6 INTEGER ARRAY)
C        ISTAT  -- STATUS INDICATOR, AS FOLLOWS:
C                     0 = MAP INFORMATION RETURNED AS REQUESTED
C                    +1 = FILE NAME DOES NOT MATCH GIVEN MATCH STRING
C                    -1 = ERROR (E.G. READ ERROR OR UNRESOURCED PACK)
C                    -2 = NO MORE FILES
C
C ---------------------------------------------------------------------

      CHARACTER   AREANM*(*)      ! AREANAME MATCH STRING
C
      CHARACTER   NAME*17         ! AREANAME
      CHARACTER   TYPE*3          ! FILE TYPE
      CHARACTER   RWXD*11         ! ACCESS CODE
      INTEGER     SIZE            ! CURRENT SIZE
      INTEGER     GRAN            ! GRANULE SIZE
      INTEGER     MAXS            ! MAXIMUM SIZE
      CHARACTER   OWNER*12        ! OWNER'S NAME
      INTEGER     ELDATE(6)       ! PURGE DATE/TIME
      INTEGER     GEDATE(6)       ! GENERATION D/T
      INTEGER     LADATE(6)       ! LAST REFERENCE D/T
      INTEGER     LWDATE(6)       ! LAST WRITE D/T
      INTEGER     ISTAT           ! MAP STATUS RETURNED
C
      INTEGER     PARLST(5)       ! PARAMETER LIST FOR $DASAVE
      INTEGER     DAIB(24,9)      ! DISC AREA INFORMATION BLOCK
      EQUIVALENCE (PARLST(5),DAIB)
C
      CHARACTER   NAMTMP*19       ! TEMPORARY AREANAME
      INTEGER     NAMEQV(7)       ! HOLLERITH FORM OF AREANAME
      EQUIVALENCE (NAMTMP,NAMEQV)
C
      CHARACTER   MATCH*15        ! AREANAME PORTION OF MATCH STRING
      INTEGER     NCHARS,ISTAR    ! CHARACTER POINTERS
      INTEGER     NMATCH,I        ! CHARACTER POINTERS
      INTEGER     MODE            ! SEARCH FUNCTION TO PERFORM
      INTEGER     NWORDS, FILENO  ! BUFFER POINTERS
      INTEGER     ICOMP, JCOMP    ! COMPARISON FUNCTION, RESULT
      DATA FILENO / -1 /
C
C GET QUALIFIER IN TRUNCATED ASCII, IF REQUIRED
C
      ISTAR = 0
      FOR I=1,LEN(AREANM)
C        FIND QUALIFIER DELIMITER
         IF (AREANM(I:I) .EQ. '*') THEN
            ISTAR = I
            EXIT FOR
         END IF
      END FOR

C     HANDLE A WILDCARD QUALIFIER
      IF (ISTAR .EQ. 2 .AND. AREANM(1:1) .EQ. '?') THEN
         MODE = 2

      ELSE
         MODE = 1
C        ASSEMBLE A DUMMY AREANAME USING THE SPECIFED QUALIFIER
         IF (ISTAR .LE. 0) THEN
            NAMTMP = 'TEMPNAME'
         ELSE
            NAMTMP = AREANM(1:ISTAR) // 'TEMPNAME'
         END IF

         CALL FILNAM(NAMTMP,PARLST,ISTAT)
         IF (ISTAT .LE. 0) GO TO 800
      END IF
C
C MAKE  A COPY OF THE MATCH STRING
C
      MATCH = AREANM(ISTAR+1:)
      NMATCH = LEN(AREANM) - ISTAR
C
C PERFORM INITIAL CALL TO $DASAVE
C
      IF (MODE .EQ. 1) THEN            ! SINGLE QUALIFIER
:ASSEM
        REEN                 MAKE THE ROUTINE RE-ENTRANT
*
        TLO   PARLST         DEFINE PARAMETER LIST
        BLU   $DASAVE        GET THE DISK INFO
        DATA  2              FUNCTION CODE FOR GET ALL FILES FROM QUAL
        CZA                  ERROR?
        BNZ   $800           YES, EXIT
        TEM   NWORDS         NO, GET WORD COUNT
:END
      ELSE                             ! ALL QUALIFIERS
:ASSEM
        TLO   PARLST         DEFINE PARAMETER LIST
        BLU   $DASAVE        GET THE DISK INFO
        DATA  8              FUNCTION CODE FOR GET ALL USER FILES
        CZA                  ERROR?
        BNZ   $800           YES, EXIT
        TEM   NWORDS         NO, GET WORD COUNT
:END
      END IF

      FILENO = 1                       ! INDICATE FIRST FILE
      GO TO 900
C
C ---------------------------------------------------------------------
C
      ENTRY MAPWILD

      IF (FILENO .LE. 0) STOP '*error* MAPWILD not initialized'
      IF (NWORDS .LE. 0) GO TO 810     ! NO MORE FILES
C
C MAKE SURE THE CURRENT FILE MATCHES BEFORE WE PROCESS IT
C
      CALL TATOA(DAIB(13,FILENO),NAMEQV(1),8)  ! QUALIFIER
      CALL TATOA(DAIB( 1,FILENO),NAMEQV(4),8)  ! AREANAME
      NAMTMP(9:9) = '*'
      NAME = NAMTMP

      JCOMP = ICOMP( MATCH,NMATCH, NAME(10:17),8 )
      IF (JCOMP .EQ. 0) THEN
         CALL MAPIFY( DAIB(1,FILENO),
     +         NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER,
     +         ELDATE,GEDATE,LADATE,LWDATE )
      END IF
C
C INCREMENT THE BUFFER POINTER
C
      FILENO = FILENO + 1
      NWORDS = NWORDS - 24
C
C IF THE CURRENT BUFFER IS EMPTY, GET INFORMATION ON UP TO 9 MORE FILES
C
      IF (NWORDS .EQ. 0) THEN
:ASSEM
        TLO   PARLST         DEFINE PARAMETER LIST
        BLU   $DASAVE        GET THE DISK INFO
        DATA  0              FUNCTION CODE FOR GET INFO
        CZA                  ERROR?
        BNZ   $800           YES, EXIT
        TEM   NWORDS         NO, GET NEW WORD COUNT
:END
         FILENO = 1                    ! INDICATE FIRST FILE
      END IF

      IF (JCOMP .NE. 0) GO TO 820
      GO TO 900
C
C ERROR
C
800   ISTAT = -1
      RETURN
C
C NO MORE FILES
C
810   ISTAT = -2
      RETURN
C
C COMPARISON WITH MATCH STRING FAILED (ONLY QUAL*NAME RETURNED)
C
820   ISTAT = 1
      RETURN
C
C SUCCESSFUL RETURN
C
900   ISTAT = 0
      RETURN
      END

      SUBROUTINE MAP(AREANM, NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER,
     +                       ELDATE,GEDATE,LADATE,LWDATE,ISTAT)
C
C     MAPFILE                                    FORTRAN 77 / ASSEMBLER
C     WRITTEN BY SKIP RUSSELL                          APRIL, 1983
C
C     SUBROUTINE TO RETURN DIRECTORY INFORMATION ON A SINGLE DISK AREA
C
C
C     INPUT ARGUMENTS:
C        AREANM -- AREA NAME TO MATCH               (CHARACTER STRING)
C
C     OUTPUT ARGUMENTS:
C        NAME   -- QUAL*AREA                        (CHARACTER*17)
C        TYPE   -- PROGRAM TYPE                     (CHARACTER*3)
C        RWXD   -- READ/WRITE/EXECUTE/DELETE ACCESS (CHARACTER*11)
C        SIZE   -- CURRENT SIZE IN SECTORS          (INTEGER)
C        GRAN   -- GRANULE SIZE IN SECTORS          (INTEGER)
C        MAXS   -- MAXIMUM SIZE IN SECTORS          (INTEGER)
C        OWNER  -- USER NAME OF THE OWNER           (CHARACTER*12)
C        ELDATE -- ELIMINATE DATE/TIME              (6 INTEGER ARRAY)
C        GEDATE -- GENERATE DATE/TIME               (6 INTEGER ARRAY)
C        LADATE -- LAST ACCESS DATE/TIME            (6 INTEGER ARRAY)
C        LWDATE -- LAST WRITE DATE/TIME             (6 INTEGER ARRAY)
C        ISTAT  -- STATUS INDICATOR, AS FOLLOWS:
C                    +1 = FILE NOT FOUND
C                     0 = MAP INFORMATION RETURNED (SUCCESSFUL)
C                    -1 = INVALID NAME SPECIFIED
C
C ---------------------------------------------------------------------

      CHARACTER   AREANM*(*)      ! AREANAME MATCH STRING
C
      CHARACTER   NAME*17         ! AREANAME
      CHARACTER   TYPE*3          ! FILE TYPE
      CHARACTER   RWXD*11         ! ACCESS CODE
      INTEGER     SIZE            ! CURRENT SIZE
      INTEGER     GRAN            ! GRANULE SIZE
      INTEGER     MAXS            ! MAXIMUM SIZE
      CHARACTER   OWNER*12        ! OWNER'S NAME
      INTEGER     ELDATE(6)       ! PURGE DATE/TIME
      INTEGER     GEDATE(6)       ! GENERATION D/T
      INTEGER     LADATE(6)       ! LAST REFERENCE D/T
      INTEGER     LWDATE(6)       ! LAST WRITE D/T
      INTEGER     ISTAT           ! MAP STATUS RETURNED
C
      INTEGER     PARLST(5)       ! PARAMETER LIST FOR $DASAVE
      INTEGER     DAIB(24)        ! DISC AREA INFORMATION BLOCK
      EQUIVALENCE (PARLST(5),DAIB)
C
C GET FILE NAME IN TRUNCATED ASCII
C
      CALL FILNAM(AREANM,PARLST,ISTAT)
      IF (ISTAT .LE. 0) GO TO 800
C
C CALL $DASAVE SYSTEM SERVICE
C
:ASSEM
        REEN                 MAKE THE ROUTINE RE-ENTRANT
*
        TLO   PARLST         DEFINE PARAMETER LIST
        BLU   $DASAVE        GET THE DISK INFO
        DATA  7              FUNCTION CODE FOR GET INFO ON ONE FILE
        CZA                  ERROR?
        BNZ   $810           YES, EXIT
:END
C
C PROCESS OUTPUT AND RETURN
C
      CALL MAPIFY(DAIB, NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER,
     +                  ELDATE,GEDATE,LADATE,LWDATE)
      GO TO 900
C
C INVALID FILE NAME
C
800   ISTAT = -1
      RETURN
C
C FILE NOT FOUND
C
810   ISTAT = 1
      RETURN
C
C SUCCESSFUL RETURN
C
900   ISTAT = 0
      RETURN
      END

      SUBROUTINE MAPIFY(DAIB, NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER,
     +                        ELDATE,GEDATE,LADATE,LWDATE)
C
C     SUBROUTINE TO DECODE A DISK AREA INFORMATION BLOCK
C
C     INPUT ARGUMENT:
C        DAIB   -- 24 WORD DAIB AS RETURNED BY THE $DASAVE SERVICE
C
C     OUTPUT ARGUMENTS:
C        NAME   -- QUAL*AREA                        (CHARACTER*17)
C        TYPE   -- PROGRAM TYPE                     (CHARACTER*3)
C        RWXD   -- READ/WRITE/EXECUTE/DELETE ACCESS (CHARACTER*11)
C        SIZE   -- CURRENT SIZE IN SECTORS          (INTEGER)
C        GRAN   -- GRANULE SIZE IN SECTORS          (INTEGER)
C        MAXS   -- MAXIMUM SIZE IN SECTORS          (INTEGER)
C        OWNER  -- USER NAME OF THE OWNER           (CHARACTER*12)
C        ELDATE -- ELIMINATE DATE/TIME              (6 INTEGER ARRAY)
C        GEDATE -- GENERATE DATE/TIME               (6 INTEGER ARRAY)
C        LADATE -- LAST ACCESS DATE/TIME            (6 INTEGER ARRAY)
C        LWDATE -- LAST WRITE DATE/TIME             (6 INTEGER ARRAY)
C
C ---------------------------------------------------------------------

      INTEGER     DAIB(24)        ! DISC AREA INFORMATION BLOCK
C
      CHARACTER   NAME*17         ! AREANAME
      CHARACTER   TYPE*3          ! FILE TYPE
      CHARACTER   RWXD*11         ! ACCESS CODE
      INTEGER     SIZE            ! CURRENT SIZE
      INTEGER     GRAN            ! GRANULE SIZE
      INTEGER     MAXS            ! MAXIMUM SIZE
      CHARACTER   OWNER*12        ! OWNER'S NAME
      INTEGER     ELDATE(6)       ! PURGE DATE/TIME
      INTEGER     GEDATE(6)       ! GENERATION D/T
      INTEGER     LADATE(6)       ! LAST REFERENCE D/T
      INTEGER     LWDATE(6)       ! LAST WRITE D/T
C
      CHARACTER   OWNTMP*12       ! TEMPORARY OWNER NAME
      INTEGER     PARLS2(10)      ! PARAMETER LIST FOR $USERNO
      EQUIVALENCE (OWNTMP,PARLS2(5))
C
      CHARACTER   NAMTMP*18       ! TEMPORARY AREANAME
      INTEGER     NAMEQV(6)       ! HOLLERITH FORM OF AREANAME
      EQUIVALENCE (NAMTMP,NAMEQV)
C
      CHARACTER   PREFIX*1        ! PUBLIC/ACCOUNT FLAG
      INTEGER     I
C
C     AREANAME
C
      CALL TATOA(DAIB(13),NAMEQV(1),8)  ! QUALIFIER
      CALL TATOA(DAIB( 1),NAMEQV(4),8)  ! AREANAME
      NAMTMP(9:9) = "*"
      NAME = NAMTMP
C
C     TYPE
C
      I = DAIB(8)
      IF      ((I.AND.'40000000) .NE. 0) THEN
         TYPE = 'INT'
      ELSE IF ((I.AND.'10000000) .NE. 0) THEN
         TYPE = 'BLK'
      ELSE IF ((I.AND.'04000000) .NE. 0) THEN
         TYPE = 'RAN'
      ELSE
         TYPE = 'UNB'
      END IF
C
C     CURRENT & GRANULE & MAXIMUM SIZES
C
      SIZE = DAIB(15)
      GRAN = DAIB( 4)
      MAXS = DAIB(16)
C
C     ACCESS
C
      I = DAIB(7) / 2**12
      IF ((I.AND.'100) .NE. 0) THEN
         PREFIX = "P"
      ELSE
         PREFIX = "A"
      END IF

      RWXD = "-----------"
      IF ((I.AND.'2000) .NE. 0) THEN                                    SR11/86
         IF ((I.AND.'0001) .NE. 0) RWXD(10:11) = "OD"                   SR11/86
         IF ((I.AND.'0002) .NE. 0) RWXD(04:05) = "OW"                   SR11/86
         IF ((I.AND.'0004) .NE. 0) RWXD(10:11) = 'AD'                   SR11/86
         IF ((I.AND.'0010) .NE. 0) RWXD(07:08) = 'AX'                   SR11/86
         IF ((I.AND.'0020) .NE. 0) RWXD(04:05) = 'AW'                   SR11/86
         IF ((I.AND.'0040) .NE. 0) RWXD(01:02) = 'AR'                   SR11/86
         IF ((I.AND.'0100) .NE. 0) RWXD(10:11) = 'PD'                   SR11/86
         IF ((I.AND.'0200) .NE. 0) RWXD(07:08) = 'PX'                   SR11/86
         IF ((I.AND.'0400) .NE. 0) RWXD(04:05) = 'PW'                   SR11/86
         IF ((I.AND.'1000) .NE. 0) RWXD(01:02) = 'PR'                   SR11/86
      ELSE                                                              SR11/86
         IF ((I.AND.'01) .NE. 0) RWXD(10:11) = "OD"
         IF ((I.AND.'02) .NE. 0) RWXD(04:05) = "OW"
         IF ((I.AND.'04) .NE. 0) RWXD(10:11) = PREFIX // 'D'
         IF ((I.AND.'10) .NE. 0) RWXD(07:08) = PREFIX // 'X'
         IF ((I.AND.'20) .NE. 0) RWXD(04:05) = PREFIX // 'W'
         IF ((I.AND.'40) .NE. 0) RWXD(01:02) = PREFIX // 'R'
      END IF                                                            SR11/86
C
C     OWNER
C
      IF (PARLS2(1) .NE. DAIB(5) .OR. PARLS2(2) .NE. DAIB(6)) THEN
         PARLS2(1) = DAIB(5)
         PARLS2(2) = DAIB(6)
         PARLS2(3) = 0
         PARLS2(4) = 0
         OWNTMP = ' '
:ASSEM
        REEN                 MAKE THE ROUTINE RE-ENTRANT
*
        TLO   PARLS2         DEFINE PARAMETER LIST
        NSK
        BLU   $USERNO        GET USER NAME
:END
      END IF
      OWNER = OWNTMP
C
C     DATES AND TIMES
C
      ELDATE(1) = DAIB(17)
      ELDATE(2) = DAIB(18)
      GEDATE(1) = DAIB(19)
      GEDATE(2) = DAIB(20)
      LADATE(1) = DAIB(21)
      LADATE(2) = DAIB(22)
      LWDATE(1) = DAIB(23)
      LWDATE(2) = DAIB(24)

:ASSEM
      TMK    ELDATE
      NSK
      BLU    $DATE
*
      TMK    GEDATE
      NSK
      BLU    $DATE
*
      TMK    LADATE
      NSK
      BLU    $DATE
*
      TMK    LWDATE
      NSK
      BLU    $DATE
:END

      IF (DAIB(17).EQ.'37777777) THEN
         ELDATE(1) = '   '
         ELDATE(2) = '   '
         ELDATE(3) = '   '
         ELDATE(4) = '   '
         ELDATE(5) = '   '
         ELDATE(6) = '   '
      END IF

      END

      SUBROUTINE FILNAM(AREANM,TASCII,ISTAT)
C
C CHECK A DISC AREANAME TO INSURE THAT IS CORRECTLY FORMED,
C AND SET UP THE TRUNCATED ASCII REPRESENTATION WHICH IS USED
C BY SEVERAL HARRIS SYSTEM SERVICES
C
C INPUT:
C     AREANM -- CHARACTER STRING CONTAINING THE AREANAME TO SCAN
C
C OUTPUT:
C     TASCII -- 4 WORD ARRAY CONTAINING THE COMPLETE AREANAME IN
C               TRUNCATED ASCII
C
C     ISTAT  -- STATUS FLAG RETURNED:
C                    NEGATIVE IF AREANAME IS MALFORMED
C                    LENGTH OF INPUT STRING IF SUCCESSFUL
C
C WRITTEN 4/83 BY SR
C
C ---------------------------------------------------------------------

      CHARACTER   AREANM*(*)           ! INPUT AREANAME
      INTEGER     TASCII(4)            ! OUTPUT AREANAME
      INTEGER     ISTAT                ! STATUS CODE

      CHARACTER   NAMTMP*18
      INTEGER     NAMEQV(6)
      EQUIVALENCE (NAMTMP,NAMEQV)

      NAMTMP = AREANM                  ! CONVERT AREANAME TO HOLLERITH

:ASSEM
        REEN                 MAKE THE ROUTINE RE-ENTRANT
*
        TLO   PARLST         INITIALIZE THE SCANNER
        BLU   $SCINIT
*
        TMK   TASCII         IDENTIFY THE OUTPUT BUFFER
        BLU   $AREANM        CALL AREANAME SERVICE
        TAM*  ISTAT          GET STATUS RETURNED
*
        PORG  *     DATA
PARLST  DATA  6              INPUT BUFFER LENGTH
        LAC   NAMTMP         INPUT BUFFER ADDRESS
:END
      RETURN
      END
C KERMIT PRIMITIVES
C
C     SNDPKT   -- SEND PACKET
C     RESEND   -- RE-SEND PREVIOUS PACKET
C     SNDACK   -- SEND "ACK" PACKET
C     SNDNAK   -- SEND "NAK" PACKET
C     SNDERR   -- SEND ERROR PACKET
C     RCVPKT   -- RECEIVE PACKET
C     RCVACK   -- RECEIVE ACK/NAK PACKET
C     UNPACK   -- DECODE AN INCOMING PACKET
C     SPAR     -- ENCODE MY SEND/RECEIVE PARAMETERS
C     RPAR     -- DECODE THE OTHER KERMIT'S SEND/RECEIVE PARAMETERS
C     PUTDAT   -- FILL PACKET DATA WITH A STRING OF TEXT
C     ICHKFN   -- COMPUTE PACKET CHECKSUM (INTEGER FUNCTION)
C     MAKEC    -- MAKE A NUMBER PRINTABLE (INTEGER FUNCTION)
C     UNCHAR   -- RESTORE A NUMBER FROM PRINTABLE (INTEGER FUNCTION)
C     ISCTRL   -- IS THIS A CONTROL CHARACTER? (LOGICAL FUNCTION)
C     CTL      -- CONTROL CHAR TO/FROM PRINTABLE (INTEGER FUNCTION)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C PACKET DESCRIPTION:
C
C BYTE 1    -- MARK   : SOH CHARACTER
C BYTE 2    -- COUNT  : # OF BYTES FOLLOWING THIS FIELD
C BYTE 3    -- SEQ    : SEQUENCE NUMBER MODULO 64
C BYTE 4    -- PTYPE  : PACKET TYPE = {D,Y,N,S,B,F,Z,E,...}
C BYTE 5-   -- DATA   : THE ACTUAL DATA (N BYTES)
C BYTE N+5  -- CHKSUM : CHECKSUM OF BYTES 2 THROUGH N+4
C APPENDED: -- EOL    : (NOT CONSIDERED PART OF PACKET PROPER)

      SUBROUTINE SNDPKT(DATA,NDATA,NSEQ,TYPE)
C---
C--- BUILDS AND SENDS PACKET
C---
      INTEGER           DATA(*),NDATA,NSEQ
      CHARACTER         TYPE*1

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG
      INTEGER           MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
      COMMON /SNDCOM/   MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME

      INTEGER           ICHKFN,MAKEC
      INTEGER           PACK(94),NPACK,SOH,I
      SAVE              PACK,NPACK

      DATA SOH /1/

      NPACK = NDATA + 5          ! TOTAL CHARACTERS IN PACKET

      PACK(1) = SOH              ! MARK (START OF PACKET CHARACTER)
      PACK(2) = MAKEC(NDATA+3)   ! COUNT = SEQ+PTYPE+DATA+CHKSUM
      PACK(3) = MAKEC(NSEQ)      ! SEQUENCE NUMBER
      PACK(4) = ICHAR(TYPE)      ! PACKET TYPE
      FOR I=1,NDATA
         PACK(I+4) = DATA(I)     ! DATA
      END FOR
      PACK(NDATA+5) = ICHKFN(PACK,NPACK)     ! CHECKSUM

      IF (DEBUG) THEN
         IF (NDATA .LE. 0) THEN
            WRITE (*,1100) NSEQ, TYPE, NPACK, NDATA
         ELSE
            WRITE (*,1100) NSEQ, TYPE, NPACK, NDATA,
     +         ICHAR('<'), (DATA(I), I=1,NDATA), ICHAR('>')
         END IF
 1100    FORMAT (' SENT',I3,') TYPE=',A,' SIZE=',I3,' NDATA=',I3,
     +      :,2X,R1,89R1,R1)
      END IF
      GO TO 100

C---
C--- RE-SENDS PREVIOUS PACKET
C---
      ENTRY RESEND()

      IF (DEBUG) WRITE (*,*) 'RE-SENDING LAST PACKET'

C     SEND PADDING IF THEY REQUESTED IT
100   FOR I=1,NSPAD
         CALL PUT1CW(NSPCHR,1)
      END FOR

C     SEND PACKET
      CALL PUT1CW(PACK,NPACK)
      END

      SUBROUTINE SNDACK(DATA,NDATA,NSEQ)
C---
C--- SEND ACK PACKET
C---
      INTEGER           DATA(*),NDATA,NSEQ

      CALL SNDPKT(DATA,NDATA,NSEQ,'Y')
      END

      SUBROUTINE SNDNAK(NSEQ)
C---
C--- SEND NAK PACKET
C---
      INTEGER           NSEQ
      INTEGER           DATA(1),NDATA

      NDATA = 0
      CALL SNDPKT(DATA,NDATA,NSEQ,'N')
      END

      SUBROUTINE SNDERR(MSG,MXDATA,DATA,NSEQ)
C---
C--- SEND ERROR PACKET
C---
      CHARACTER         MSG*(*)
      INTEGER           MXDATA,DATA(*),NSEQ

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG

      INTEGER           NDATA,PREFIX

      IF (DEBUG) WRITE (*,*) MSG

C     COPY MESSAGE INTO DATA ARRAY
      PREFIX = 1
      CALL PUTDAT(MSG,PREFIX,MXDATA,DATA,NDATA)

C     SEND "E" PACKET
      CALL SNDPKT(DATA,NDATA,NSEQ,'E')
      END

      SUBROUTINE RCVPKT(MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT)
C---
C--- RECEIVES PACKET
C---
      INTEGER           MXDATA,DATA(*),NDATA,NSEQ,ISTAT
      CHARACTER         TYPE*1

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG
      INTEGER           MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
      COMMON /SNDCOM/   MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME

      INTEGER           MXBUF
      PARAMETER (MXBUF=80)
      INTEGER           PACK(MXBUF)

      INTEGER           I

C     READ PACKET

      CALL PUT1CW(NSEOL,1)

      READ (3,'(100R1)',IOSTAT=ISTAT) PACK
      IF (ISTAT .NE. 0) THEN
         IF (DEBUG) WRITE (*,*) 'I/O ERROR ON READ, IOSTAT=', ISTAT
         GO TO 800
      END IF

C     CHECK

      CALL UNPACK(PACK,MXBUF,MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT)
      IF (ISTAT .NE. 0) THEN
         IF (DEBUG) WRITE (*,*) 'INVALID PACKET RECEIVED'
         GO TO 800
      END IF
      GO TO 900

800   ISTAT = -1  ! UNSUCCESSFUL
      RETURN

900   ISTAT = 0   ! SUCCESSFUL
      RETURN
      END

      SUBROUTINE RCVACK(MXDATA,DATA,NDATA,NSEQ,ISTAT)
C---
C--- RECEIVE "ACK" PACKET AND CHECK VALIDITY
C---
      INTEGER           MXDATA,DATA(*),NDATA,NSEQ,ISTAT

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG

      INTEGER           RSEQ
      CHARACTER         TYPE*1

      CALL RCVPKT(MXDATA,DATA,NDATA,RSEQ,TYPE,ISTAT)
      IF (ISTAT .NE. 0) GO TO 810

      IF (TYPE .EQ. 'Y' .AND. NSEQ .EQ. RSEQ) GO TO 900
      IF (TYPE .EQ. 'N') THEN
         IF (MOD(NSEQ+1,64) .EQ. RSEQ) THEN
            IF (DEBUG) WRITE (*,*) '(EQUIVALENT TO ACK)'
            GO TO 900
         END IF
         GO TO 810
      END IF

CCC      IF (TYPE .EQ. 'E') GO TO 800
CCC      GO TO 810

800   ISTAT = -1  ! ERROR PACKET
      RETURN

810   ISTAT = 1   ! UNSUCCESSFUL
      IF (DEBUG) WRITE (*,*) 'RECEIVED NAK OR EQUIVALENT'
      RETURN

900   ISTAT = 0   ! SUCCESSFUL
      RETURN
      END

      SUBROUTINE UNPACK(PACK,MXBUF,MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT)
C---
C--- UNPACK AND VALIDATE PACKET (CALLED BY RCVPKT)
C---
      INTEGER           PACK(*),MXBUF
      INTEGER           MXDATA,DATA(*),NDATA,NSEQ,ISTAT
      CHARACTER         TYPE*1

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG

      INTEGER           UNCHAR,ICHKFN
      INTEGER           NPACK,IPACK,NSOH,CHKSUM,CHKSU2,NCHARS,SOH,I

      DATA SOH /1/

C     INITIALIZE

      NSOH   = 0
      TYPE  = '?'

C     MARK FIELD : SOH CHARACTER

      IPACK = 0
      FOR I=1,MXBUF-3
         IPACK = IPACK + 1
         IF (PACK(IPACK) .EQ. SOH) GO TO 100
      END FOR
      IF (DEBUG) WRITE (*,*) 'UNPACK: SOH NOT FOUND'
      GO TO 800

100   NSOH = IPACK
      IF (DEBUG .AND. NSOH .NE. 1) WRITE (*,*) 'SOH FOUND AT', NSOH

C     COUNT FIELD : # OF BYTES FOLLOWING THIS FIELD

      IPACK = IPACK + 1
      NPACK = UNCHAR( PACK(IPACK) )
      IF (NPACK .LT. 3 .OR. NPACK+2 .GT. MXBUF) THEN
         IF (DEBUG) WRITE (*,*) 'UNPACK: INVALID COUNT FIELD', NPACK
         GO TO 800
      ELSE IF (NPACK+NSOH+1 .GT. MXBUF) THEN
         IF (DEBUG) WRITE (*,*) 'UNPACK: BUFFER OVERRUN', NPACK+NSOH+1
         GO TO 800
      END IF
      NPACK = NPACK + 2

C     SEQ FIELD : SEQUENCE NUMBER MODULO 64

      IPACK = IPACK + 1
      NSEQ = UNCHAR( PACK(IPACK) )
      IF (NSEQ .LT. 0 .OR. NSEQ .GT. 63) THEN
         IF (DEBUG) WRITE (*,*) 'UNPACK: INVALID SEQ FIELD', NSEQ
         GO TO 800
      END IF

C     PTYPE FIELD : PACKET TYPE = {D,Y,N,S,B,F,Z,E,...}

      IPACK = IPACK + 1
      TYPE = CHAR( PACK(IPACK) )
      IF (TYPE .LT. 'A' .OR. TYPE .GT. 'Z') THEN
         IF (DEBUG) WRITE (*,*) 'UNPACK: INVALID PACKET TYPE ', TYPE
         GO TO 800
      END IF

C     DATA FIELD : COPY INTO DATA ARRAY

      NDATA = NPACK-5
      IF (NDATA .GT. MXDATA) THEN
         IF (DEBUG) WRITE (*,*) 'UNPACK: MORE DATA RECEIVED THAN',
     +      ' EXPECTED (N=', NDATA, ' MAX=', MXDATA, ')'
         NDATA = MXDATA
      END IF
      FOR I=1,NDATA
         DATA(I) = PACK(I+NSOH+3)
      END FOR

C     CHKSUM FIELD : CHECKSUM OF BYTES 2 THROUGH N-4

      CHKSUM = PACK(NPACK+NSOH-1)
      CHKSU2 = ICHKFN( PACK(NSOH), NPACK )
      IF (CHKSUM .NE. CHKSU2) THEN
         IF (DEBUG) WRITE (*,*) 'UNPACK: CHECKSUMS=', CHKSUM,CHKSU2
         GO TO 800
      END IF

C     LOG ERROR MESSAGES

      IF (TYPE .EQ. 'E') THEN
         IF (DEBUG) THEN
            WRITE (*,*) 'ERROR PACKET RECEIVED:'
            WRITE (*,*) '***', (CHAR(PACK(I)), I=NSOH+4,NPACK-1), '***'
         END IF
      END IF
      GO TO 900

800   ISTAT = -1  ! UNSUCCESSFUL
      IF (DEBUG) THEN
         NCHARS = 0
         FOR I=MXBUF,1,-1
            IF (PACK(I) .NE. ICHAR(' ') ) THEN
               NCHARS = I
               EXIT FOR
            END IF
         END FOR
         WRITE (*,*) 'DUMP OF PACKET CONTENTS:'
         WRITE (*,'(26(2X,R1))') (MAX(ICHAR(' '),PACK(I)), I=1,NCHARS)
         WRITE (*,'(1X,26I3)') (PACK(I), I=1,NCHARS)
      END IF
      RETURN

900   ISTAT = 0 ! SUCCESSFUL
      IF (DEBUG) THEN
         IF (NDATA .LE. 0) THEN
            WRITE (*,1900) NSEQ, TYPE, NPACK, NDATA
         ELSE
            WRITE (*,1900) NSEQ, TYPE, NPACK, NDATA,
     +         ICHAR('<'), (DATA(I), I=1,NDATA), ICHAR('>')
         END IF
 1900    FORMAT (' RCVD',I3,') TYPE=',A,' SIZE=',I3,' NDATA=',I3,
     +      :,2X,93R1)
      END IF
      END

      SUBROUTINE SPAR(MXDATA,DATA,NDATA)
C---
C--- FILL THE DATA ARRAY WITH MY SEND-INIT PARAMETERS
C---
      INTEGER           MXDATA,DATA(*),NDATA

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG
      INTEGER           MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
      COMMON /RCVCOM/   MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME

      INTEGER           MAKEC,CTL
      LOGICAL           FIRST

      DATA FIRST /.TRUE./

      NDATA = 6
      IF (MXDATA .LT. NDATA) THEN
         WRITE (*,*) 'FATAL ERROR: DATA ARRAY < MIN SIZE IN "SPAR"'
         STOP
      END IF

      DATA(1) = MAKEC( MRPSIZ )     ! BIGGEST PACKET I CAN RECEIVE
      DATA(2) = MAKEC( MYTIME )     ! WHEN I WANT TIMEOUT
      DATA(3) = MAKEC( MYPAD )      ! HOW MUCH PADDING TO SEND ME
      DATA(4) = CTL( MYPCHR )       ! PAD CHARACTER TO USE
      DATA(5) = MAKEC( MYEOL )      ! EOL TO SEND ME
      DATA(6) = MYQUOT              ! CONTROL QUOTE CHAR I WILL SEND
C     USE DEFAULTS FOR THE FOLLOWING:
C     7. NEITHER OF US WILL DO 8-BIT QUOTING
C     8. BOTH OF US WILL USE A SINGLE CHARACTER CHECKSUM
C     9. NEITHER OF US WILL USE REPEAT PREFIXES

      IF (DEBUG .AND. FIRST) THEN
         FIRST = .FALSE.
         WRITE (*,*)
         WRITE (*,*) 'HARRIS KERMIT REQUESTS THE FOLLOWING FROM LOCAL:'
         WRITE (*,*)
         WRITE (*,*) 'BIGGEST PACKET I CAN RECEIVE IS', MRPSIZ,' CHARS'
         WRITE (*,*) 'SUGGEST THEY TIMEOUT AFTER', MYTIME, ' SECONDS'
         WRITE (*,*) 'PREFIX PACKETS WITH', MYPAD, ' PAD CHARS',
     +      ', USING CHARACTER', MYPCHR
         WRITE (*,*) 'TERMINATE PACKETS WITH CHARACTER', MYEOL
         WRITE (*,*) 'I WILL SEND "', CHAR(MYQUOT),
     +      '" TO QUOTE CONTROL CHARACTERS'
         WRITE (*,*) '(USE DEFAULTS FOR THE REMAINDER)'
         WRITE (*,*)
      END IF
      END

      SUBROUTINE RPAR(DATA,NDATA)
C---
C--- GET THE OTHER HOST'S SEND-INIT PARAMETERS
C---
      INTEGER           DATA(*),NDATA

      LOGICAL           DEBUG
      COMMON /DBGCOM/   DEBUG
      INTEGER           MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
      COMMON /SNDCOM/   MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME

      INTEGER           UNCHAR,CTL
      INTEGER           I
      LOGICAL           FIRST

      DATA FIRST /.TRUE./

C     READ THEIR PACKET

      IF (NDATA .LT. 1) GO TO 200
      I      = UNCHAR( DATA(1) )    ! BIGGEST PACKET THEY CAN RECEIVE
      IF (I .GT. 0 .AND. I .LT. MSPSIZ) MSPSIZ = I

      IF (NDATA .LT. 2) GO TO 200
      NSTIME = UNCHAR( DATA(2) )    ! WHEN THEY WANT TIMEOUT

      IF (NDATA .LT. 3) GO TO 200
      NSPAD  = UNCHAR( DATA(3) )    ! HOW MUCH PADDING TO SEND THEM

      IF (NDATA .LT. 4) GO TO 200
      NSPCHR = CTL( DATA(4) )       ! PAD CHARACTER TO USE

      IF (NDATA .LT. 5) GO TO 200
      I      = UNCHAR( DATA(5) )    ! EOL TO SEND THEM
      IF (I .GT. 0) NSEOL = I

      IF (NDATA .LT. 6) GO TO 200
      I      = DATA(6)              ! INCOMING DATA QUOTE CHARACTER
      IF (I .GT. 0) NSQUOT = I

200   IF (DEBUG .AND. FIRST) THEN
         FIRST = .FALSE.
         WRITE (*,*)
         WRITE (*,*) 'REQUESTED OF HARRIS KERMIT BY LOCAL:'
         WRITE (*,*)
         WRITE (*,*) 'BIGGEST PACKET TO SEND THEM IS', MSPSIZ, ' CHARS'
         WRITE (*,*) 'SUGGEST I TIMEOUT AFTER', NSTIME, ' SECONDS'
         WRITE (*,*) 'PREFIX PACKETS WITH', NSPAD, ' PAD CHARS',
     +      ', USING CHARACTER', NSPCHR
         WRITE (*,*) 'TERMINATE PACKETS WITH CHARACTER', NSEOL
         WRITE (*,*) 'THEY WILL SEND "', CHAR(NSQUOT),
     +      '" TO QUOTE CONTROL CHARACTERS'
         WRITE (*,*) '(USING DEFAULTS FOR THE REMAINDER, REGARDLESS)'
         WRITE (*,*)
      END IF
      END

      SUBROUTINE PUTDAT(MSG,PREFIX,MXDATA,DATA,NDATA)
C---
C--- FILL PACKET DATA WITH SPECIFIED CHARACTER STRING
C---
C--- <PREFIX> NON-ZERO PREFIXES MESSAGE WITH "HARRIS:" IDENTIFIER
C---
      CHARACTER         MSG*(*)
      INTEGER           PREFIX,MXDATA,DATA(*),NDATA

      INTEGER           N,C,I

      CHARACTER         PRE*8
      DATA PRE /'HARRIS: '/

C     COPY PREFIX INTO DATA ARRAY IF REQUESTED
      NDATA = 0
      IF (PREFIX .NE. 0) THEN
         FOR I=1,LEN(PRE)
            EXIT FOR IF (NDATA .GE. MXDATA)
            NDATA = NDATA + 1
            DATA(NDATA) = ICHAR( PRE(I:I) )
         END FOR
      END IF

C     COPY MESSAGE INTO DATA ARRAY, WITHOUT TRAILING BLANKS

      N = NDATA
      FOR I=1,LEN(MSG)
         EXIT FOR IF (N .GE. MXDATA)
         C =  ICHAR( MSG(I:I) )
         N = N + 1
         IF (C .NE. ICHAR(' ') ) NDATA = N
         DATA(N) = C
      END FOR
      END

      INTEGER FUNCTION ICHKFN(PACK,NPACK)
C---
C--- CALCULATE CHECKSUM AND CONVERT TO PRINTABLE FORM
C---
      INTEGER           PACK(*),NPACK

      INTEGER           MAKEC
      INTEGER           S,CHKSUM,I

      S = 0
      FOR I=2,NPACK-1
         S = S + PACK(I)
      END FOR

C     CHECKSUM = LOW ORDER 6 BITS OF THE RESULT OF THE FUNCTION:
C        S(BITS 0:5) + S(BITS 6:7)
C     WHERE S IS THE SUM OF ALL CHARACTERS IN THIS PACKET

      CHKSUM = (S + ((S .AND. '300)/'100)) .AND. '77
      ICHKFN = MAKEC(CHKSUM)
      END

      INTEGER FUNCTION MAKEC(ICHR)
C---
C--- CONVERT A NUMBER TO A PRINTABLE CHARACTER
C---
      INTEGER           ICHR

      MAKEC = ICHR + 32
      END

      INTEGER FUNCTION UNCHAR(ICHR)
C---
C--- RESTORE A NUMBER FROM A CHARACTER (REVERSE OF "MAKEC")
C---
      INTEGER           ICHR

      UNCHAR = ICHR - 32
      END

      LOGICAL FUNCTION ISCTRL(ICHR)
C---
C--- RETURN TRUE IF SPECIFIED CHARACTER A CONTROL CHARACTER
C---
      INTEGER           ICHR

      ISCTRL = (ICHR .LT. 32 .OR. ICHR .EQ. 127)
      END

      INTEGER FUNCTION CTL(ICHR)
C---
C--- TOGGLE A CHARACTER BETWEEN CONTROL AND PRINTABLE REPRESENTATIONS
C---
      INTEGER           ICHR

      CTL = ICHR .XOR. 64
      END
