*COMDECK COMCKER
C$    LIST(S=COMLIS)
 
****  COMCKER - KERMIT SYMBOL DEFINITIONS.
*
 
**    FILE I/O DEFINITIONS.
*
      PARAMETER (STDIN =1)
      PARAMETER (STDOUT=2)
 
**    ASCII CHARACTERS.
*
      PARAMETER (SOH=1)
      PARAMETER (ETX=3)
      PARAMETER (BELL=7)
      PARAMETER (TAB=9)
      PARAMETER (LF=10)
      PARAMETER (CR=13)
      PARAMETER (DC4=20)
      PARAMETER (BLANK=32)
      PARAMETER (MINUS=45)
      PARAMETER (COLON=58)
      PARAMETER (QMARK=63)
      PARAMETER (DEL=127)
      PARAMETER (NEL=O"3777")
      PARAMETER (NULL=O"4000")
 
**    MISCELLANEOUS.
*
      PARAMETER (OK=1)
      PARAMETER (EOF=-1)
      PARAMETER (ERROR=-2)
      PARAMETER (ON=1, OFF=0)
      PARAMETER (YES=1, NO=0)
 
**    DISK FILE CHARACTER SETS.
*
      PARAMETER (CSNONE=0, CSDSP=1, CS812=2, CS612=3, CSBIN=4, CSTXP=5)
 
**    PROTOCOL DEFINITIONS.
*
      PARAMETER (UNKNOWN=0, FULLDUP=1, HALFDUP=2)
      PARAMETER (NORMAL=0, TXP=1)
 
      PARAMETER (MAXINIT=15)
      PARAMETER (MAXTRY=10)
      PARAMETER (IPKSIZE=94)
*     MAX LONG PACKET SIZE.  DON'T RAISE ABOVE 4000.
      PARAMETER (LPKSIZE=1000)
      PARAMETER (ITIMOUT=10)
      PARAMETER (IPADCT=0)
      PARAMETER (IPADCH=0)
      PARAMETER (IEOLCH=13)
      PARAMETER (ICQUOTE=35)
      PARAMETER (I8QUOTE=38)
      PARAMETER (ICHKTYP=49)
      PARAMETER (IRPTPFX=126)
 
*     INIT CAPABILITY BIT MASKS
 
      PARAMETER (CAPAS1 = 32)
      PARAMETER (CAPAS2 = 16)
      PARAMETER (CAPAS3 = 8)
      PARAMETER (CAPAS4 = 4)
      PARAMETER (CAPAS5 = 2)
      PARAMETER (CAPAS6 = 1)
 
**    PACKET TYPES.
*
      PARAMETER (A=65)
      PARAMETER (B=66)
      PARAMETER (C=67)
      PARAMETER (D=68)
      PARAMETER (E=69)
      PARAMETER (F=70)
      PARAMETER (G=71)
      PARAMETER (EYE=73)
      PARAMETER (L=76)
      PARAMETER (N=78)
      PARAMETER (P=80)
      PARAMETER (R=82)
      PARAMETER (S=83)
      PARAMETER (X=88)
      PARAMETER (Y=89)
      PARAMETER (Z=90)
 
**    PACKET ERROR DEFINITIONS.
*
      PARAMETER (TOOMANY=O"1000")
      PARAMETER (INVALID=O"2000")
      PARAMETER (SEQERR=O"4000")
      PARAMETER (LCLFILE=O"10000")
      PARAMETER (NOTLCL=O"20000")
      PARAMETER (INVFN=O"40000")
      PARAMETER (SRVCMD=O"100000")
      PARAMETER (MICERR=O"200000")
      PARAMETER (INTRPT=O"400000")
      PARAMETER (SENDING=O"100")
      PARAMETER (READING=O"200")
      PARAMETER (INITERR=1)
      PARAMETER (FILERR=2)
      PARAMETER (DATAERR=4)
      PARAMETER (EOFERR=O"10")
      PARAMETER (BRKERR=O"20")
 
 
***   KERMIT SAVED COMMON BLOCK HEADER.
*
*     ALL COMMON BLOCKS TO BE SAVED WHEN EXECUTING MONITOR
*     COMMANDS MUST BE PLACED BETWEEN /HEADER/ AND /TRAILER/
*
      COMMON /HEADER/ HEADER
 
 
**    KERMIT COMMAND PROCESSOR COMMON BLOCK.
*
      PARAMETER (BINARY=0, TEXT=1)
      COMMON /CMD/ AUTORET
      COMMON /CMD/ CINDEX
      LOGICAL CMDLOCF
      COMMON /CMD/ CMDFD, CMDLOCF
      CHARACTER CMDLFN*10
      COMMON /CMDC/ CMDLFN
 
**    KERMIT SEND-INIT PACKETS.
*
*     DO NOT ALLOCATE ANY STORAGE BETWEEN SPKSIZE AND DSYNC!
 
*     OUTGOING - WHAT WE WANT
 
      COMMON /PACKET/ SPKSIZE
      COMMON /PACKET/ STIMOUT
      COMMON /PACKET/ SPADCT
      COMMON /PACKET/ SPADCH
      COMMON /PACKET/ SEOLCH
      COMMON /PACKET/ SCQUOTE
      COMMON /PACKET/ S8QUOTE
      COMMON /PACKET/ SCHKTYP
      COMMON /PACKET/ SRPTPFX
      COMMON /PACKET/ SUNUSED(2)
      COMMON /PACKET/ SSYNC
 
*     INCOMING - WHAT THE OTHER KERMIT WANTS  (SET BY OTHER KERMIT)
 
      COMMON /PACKET/ RPKSIZE
      COMMON /PACKET/ RTIMOUT
      COMMON /PACKET/ RPADCT
      COMMON /PACKET/ RPADCH
      COMMON /PACKET/ REOLCH
      COMMON /PACKET/ RCQUOTE
      COMMON /PACKET/ R8QUOTE
      COMMON /PACKET/ RCHKTYP
      COMMON /PACKET/ RRPTPFX
      COMMON /PACKET/ RUNUSED(2)
      COMMON /PACKET/ RSYNC
 
*     INCOMING - WHAT THE OTHER KERMIT WANTS  (DEFAULTS)
 
      COMMON /PACKET/ DPKSIZE
      COMMON /PACKET/ DTIMOUT
      COMMON /PACKET/ DPADCT
      COMMON /PACKET/ DPADCH
      COMMON /PACKET/ DEOLCH
      COMMON /PACKET/ DCQUOTE
      COMMON /PACKET/ D8QUOTE
      COMMON /PACKET/ DCHKTYP
      COMMON /PACKET/ DRPTPFX
      COMMON /PACKET/ DUNUSED(2)
      COMMON /PACKET/ DSYNC
 
 
**    KERMIT PROTOCOL COMMON BLOCK.
*
      COMMON /PROTO/ PACKET(LPKSIZE+10)
      COMMON /PROTO/ RECPACK(LPKSIZE+10)
      COMMON /PROTO/ FILESTR(IPKSIZE)
      COMMON /PROTO/ DELAYFP
      COMMON /PROTO/ DUPLEX
      COMMON /PROTO/ FFD
      COMMON /PROTO/ FILMODE
      COMMON /PROTO/ TXTMODE
      COMMON /PROTO/ INITDUP
      COMMON /PROTO/ MAXRINI
      COMMON /PROTO/ MAXRTRY
      COMMON /PROTO/ NUMTRY
      COMMON /PROTO/ PACKNUM
      COMMON /PROTO/ PSIZE
      COMMON /PROTO/ REPCH
      COMMON /PROTO/ Q8CH
      COMMON /PROTO/ RDELAY
      COMMON /PROTO/ STATE
 
 
**    STORAGE FOR STATISTICS.
*
      COMMON /PROTO/ ABORTYP
      COMMON /PROTO/ ENDTIM
      COMMON /PROTO/ RCHCNT
      COMMON /PROTO/ RCHOVRH
      COMMON /PROTO/ SCHCNT
      COMMON /PROTO/ SCHOVRH
      COMMON /PROTO/ STARTIM
 
 
**    DEBUG COMMON BLOCK.
*
      PARAMETER (DBGOFF=0, DBGSTAT=1, DBGPACK=2, DBGALL=3)
      COMMON /DEBUG/ DEBUG
      COMMON /DEBUG/ DEBUGFD
      COMMON /DEBUG/ DEBUGFN(8)
 
 
**    ASCII STRING MESSAGE.
*
      INTEGER ERRMSG(IPKSIZE), MICMSG(IPKSIZE)
      COMMON /MSG/ ERRMSG, MICMSG
 
 
***   FILE I/O COMMON BLOCK DEFINITIONS.
*
      PARAMETER (MAXFILE=4)
 
**    CIO RELATED PARAMETERS.
*
*     CIOBUFL = CIO BUFFER LENGTH.
*     FETL    = FET LENGTH IN WORDS.
*     MAXWD   = LINE SIZE IN WORDS; MUST BE AN EVEN NUMBER.
 
      PARAMETER (CIOBUFL=LPKSIZE/5+20, FETL=6, MAXWD=LPKSIZE/5+20)
      PARAMETER (CLOSED=0, RD=1, WR=2, CREATE=3)
 
      CHARACTER*10 FNAME(MAXFILE)
      COMMON /FILEIOC/ FNAME
 
      BOOLEAN CIOBUFF(CIOBUFL,MAXFILE)
      BOOLEAN FCHBUF(MAXWD,MAXFILE)
      BOOLEAN FETS(0:FETL-1,MAXFILE)
      INTEGER FCSET(MAXFILE)
      INTEGER FMODE(MAXFILE)
      INTEGER FNWDS(MAXFILE)
      INTEGER FUNGTCH(MAXFILE)
      INTEGER FWPTR(MAXFILE)
      INTEGER FWSHFT(MAXFILE)
      LOGICAL CTDEV(MAXFILE)
      LOGICAL FEOF(MAXFILE)
      LOGICAL LOCFILE
      LOGICAL WAITPAK
 
      COMMON /FILEIO/ CIOBUFF
      COMMON /FILEIO/ CTDEV
      COMMON /FILEIO/ FCHBUF
      COMMON /FILEIO/ FCSET
      COMMON /FILEIO/ FEOF
      COMMON /FILEIO/ FETS
      COMMON /FILEIO/ FMODE
      COMMON /FILEIO/ FNWDS
      COMMON /FILEIO/ FUNGTCH
      COMMON /FILEIO/ FWPTR
      COMMON /FILEIO/ FWSHFT
      COMMON /FILEIO/ LOCFILE
      COMMON /FILEIO/ WAITPAK
 
 
***   KERMIT SAVED COMMON BLOCK TRAILER.
*
      COMMON /TRAILER/ TRAILER
 
 
**    MESSAGE COMMON BLOCK.
*
      CHARACTER*74 HLPASCH
      CHARACTER*37 HLPDBFN
      CHARACTER*42 HLPDLFP
      CHARACTER*29 HLPIPRC
      CHARACTER*34 HLPPADL
      CHARACTER*24 HLPPLEN
      CHARACTER*21 HLPPRTR
      CHARACTER*41 HLPRDEL
      CHARACTER*13 HLPSNFN
      CHARACTER*43 HLPTIMO
      CHARACTER VERSION*47
      INTEGER VERSDAT, VERSSTR(11)
 
      COMMON /MESSAGE/ HLPASCH
      COMMON /MESSAGE/ HLPDBFN
      COMMON /MESSAGE/ HLPDLFP
      COMMON /MESSAGE/ HLPIPRC
      COMMON /MESSAGE/ HLPPADL
      COMMON /MESSAGE/ HLPPLEN
      COMMON /MESSAGE/ HLPPRTR
      COMMON /MESSAGE/ HLPRDEL
      COMMON /MESSAGE/ HLPSNFN
      COMMON /MESSAGE/ HLPTIMO
      COMMON /MESSAGE/ VERSION
      COMMON /BMESAGE/ VERSDAT, VERSSTR
 
 
**    CHARACTER SET CONVERSION TABLES.
*
*     ASC612 = ASCII TO 6/12.
*     DPCTBL = ASCII TO DISPLAY CODE.
*     LASCII = DISPLAY CODE TO LOWER CASE ASCII.
*     SX1274 = 6/12 "74" ESCAPE CHARACTERS TO ASCII.
*     SX1276 = 6/12 "76" ESCAPE CHARACTERS TO ASCII.
*     UASCII = DISPLAY CODE TO UPPER CASE ASCII.
*
*     THE TABLES ARE MODIFIED FOR 63 CHARACTER SET BY ROUTINE 'FIXCTAB'
*     AT INITIALIZATION TIME IF REQUIRED.
*
 
      BOOLEAN ASC612(0:127)
      BOOLEAN DPCTBL(0:127)
      BOOLEAN LASCII(0:63)
      BOOLEAN SX1274(0:63)
      BOOLEAN SX1276(0:63)
      BOOLEAN UASCII(0:63)
 
      COMMON /CHARCOM/ ASC612
      COMMON /CHARCOM/ DPCTBL
      COMMON /CHARCOM/ LASCII
      COMMON /CHARCOM/ SX1274
      COMMON /CHARCOM/ SX1276
      COMMON /CHARCOM/ UASCII
 
C$    LIST(S=1)
*COMDECK COMXKER
C$    LIST(S=1)
 
****  COMXKER - KERMIT STATEMENT FUNCTION DEFINITIONS.
*
 
      UNCHAR(ASCCH) = ASCCH - BLANK
      TOCHAR(ASCCH) = ASCCH + BLANK
      CTL(ASCCH) = XOR(ASCCH,O"100")
 
C$    LIST(S=1)
*DECK KERMIT
          IDENT  KERMIT
*IF -DEF,DEBUG,1
          LCC    OVERLAY(KERMIT,0,0,OV=15)
*IF DEF,DEBUG,1
          LCC    OVERLAY(KERMIT,0,0)
          ENTRY  KERMIT
          LDSET  EPT=KERMIT
          SYSCOM B1
          SST
 KERMIT   TITLE  KERMIT - MICRO COMPUTER FILE EXCHANGE/KERMIT PROTOCOL.
          COMMENT MICRO COMPUTER FILE EXCHANGE/KERMIT PROTOCOL.
 KERMIT   SPACE  4,10
*****     KERMIT - MICRO COMPUTER FILE EXCHANGE/KERMIT PROTOCOL.
*
*         KERMIT IS A FILE SHIPPING PROGRAM USED BY MICRO COMPUTERS TO
*         TRANSFER FILES TO/FROM ANOTHER COMPUTER.
 KERMIT   SPACE  4,10
***       MICRO COMPUTER FILE INTERCHANGE/KERMIT PROTOCOL.
*
*         THIS VERSION IS FOR USE UNDER NOS 2.
 
 KERMIT   SPACE  4,10
**        MAIN PROGRAM.
 
 KERMIT   RJ     =XKERMAIN
 
          END    KERMIT
      SUBROUTINE KERMAIN
 
***   KERMIT - A CYBER FILE TRANSFER PROGRAM USING THE KERMIT PROTOCOL
*
*     THIS PROGRAM MAY NOT BE SOLD FOR PROFIT.
*
*     MODIFICATIONS: 
*
*     3.3   05/19/87  STEPHEN G. ROSEMAN, LEHIGH UNIVERSITY
*
*        1. CHANGE RECEIVE FILE NAMING.  INSTEAD OF FIRST 7 VALID
*           CHARACTERS, TAKE UP TO 3 FROM THE EXTENSION, IF FOUND.  THUS
*           ABCEFGH.BIN > ABCDBIN.
*
*        2. FIX SPOTS WHERE SUBSCRIPT CHECKING FAILED.  DIDN'T CAUSE ANY
*           PROBLEMS, BUT IT WAS ANNOYING WHEN USING FTN5,DB.
*
*        3. BROKE UP SERVER FUNCTIONS TO SECONDARY OVERLAYS TO REDUCE
*           THE SIZE OF THE SERVER.
*
*        4. FIXED ERROR IN SEND COMMAND, YOU COULDN'T PUT P: OR L: ON
*           FRONT OF 6 OR 7 CHARACTER FILENAME.
*
*        5. ADDED 'TAKE' COMMAND AND INITIAL READ FROM THE FILE
*           'KERMINI'.  ALLOWS LOCAL OR PERMANENT TAKE/KERMINI FILES.
*
*        6. BE SURE TO UNLOAD CORRECT FILE IF RECEIVE WAS ABORTED.
*           FIX VARIOUS MINOR PROBLEMS WITH INTERRUPTED TRANSFERS.
*
*        7. ALLOW CTRL/C TO CANCEL THE PROTOCOL IF ENTERED AS THE FIRST
*           CHARACTER OF AN INPUT LINE.
*
*        8. USE TRANSPARENT MODE FOR SEND MODE, AS WELL AS RECEIVE AND
*           SERVER MODES.
*
*     3.2   02/03/87  STEPHEN G. ROSEMAN, LEHIGH UNIVERSITY
*           IMPLEMENTED UNDER NOS 2.5.1, LEVEL 664.  SHOULD WORK AT
*           PREVIOUS NOS LEVELS.
*
*        FEATURE ADDITIONS: 
*
*        1. ADD WAIT-FOR-INPUT CODE, PREVENTING A NEED TO SWAPOUT BEFORE
*           EACH TERMINAL READ IF THE PACKET INPUT ISN'T THERE YET.
*
*        2. ALLOW KERMIT TO TIMEOUT IF PACKET DOESN'T COME FROM THE
*           OTHER SIDE IN TIME.
*
*        3. ALLOW WILDCARD FILE SEND AND SERVER-SEND.  SEARCHES FIRST
*           FOR MATCH IN LOCAL DISK FILES; IF NONE FOUND, IT SEARCHES
*           THE USER'S PERM FILE CATALOG.  L: AND P: ALLOW EXPLICIT
*           SPECIFICATION OF LOCAL OR PERMANENT FILE.  'SEND' DISPLAYS
*           FILE TYPE TO USER (LOCAL OR PERMANENT).
*
*        4. PUT 63 CHARACTER SET SUPPORT BACK IN.  CONVERSION TABLES
*           ARE UPDATED AT EXECUTION TIME, SO THERE ARE NO INSTALLATION
*           OPTIONS TO FORGET.
*
*        5. FIXED TRANSFER STATISTICS TO START TIMING AFTER RECEIVING
*           FIRST PACKET FROM THE MICRO.  WHY LOOK BAD JUST BECAUSE THE
*           USER WAS SLOW AT ENTERING THE COMMANDS ON THE MICRO?
*
*        6. MADE SEVERAL CHANGES TO VERSION DISPLAY LINE.  DISPLAY
*           VERSION LINE WHEN STARTING KERMIT.
*
*        7. ADDED LONG PACKET SUPPORT.  CAN SEND AND RECEIVE PACKETS UP
*           TO 4000 CHARACTERS (RELEASE VALUE = 1000).
*
*        8. MODIFIED 'HELP' COMMAND TO READ TEXT FROM A PERMANENT FILE
*           AND DISPLAY ONLY 22 LINES/PAGE.  UPDATE HELP TEXT FOR NEW
*           FEATURES.
*
*        9. ALLOWED CONTROL/T TO ABORT KERMIT SERVER OR RECEIVE MODE.
*
*        10. FIXED ERROR IN REPEAT-PREFIXED FILENAME RECEPTION.
*
*        11. ADDED DIR COMMAND AND REMOTE DIR SERVER COMMAND SUPPORT.
*
*        12. CHANGE TERMINAL OUTPUT TO 'WRITE', INSTEAD OF 'WRITER'.
*            ENSURE 0 BYTE TERMINATOR WRITTEN ON EACH TERMINAL WRITE.
*
*        13. MAKE AUTO CHARACTER SET RECOGNITION ACTUALLY DO SOMETHING
*            DIFFERENT FOR 6/12 AND DISPLAY CODE SEND.  ADD 'SET
*            TEXT-MODE XXXX' COMMAND TO FORCE PROPER CONVERSIONS FOR
*            TEXT FILE SEND AND RECEIVE.
*
*     3.1 12/18/84  PAUL WELLS, UNIVERSITY OF WASHINGTON.
*        MINOR CHANGES.  PUT RDELAY CODE BACK IN TO TAKE ADVANTAGE OF
*        IAF TYPEAHEAD MODIFICATION.
*
*     3.0 10/15/84  JOERG HALLBAUER CAL STATE UNIVERSITIES
*        MANY CHANGES FOR NOS 2.2.  SOME OF THE MAJOR ONES INCLUDE: 
*
*        1. REMOVED CONDITIONAL CODE SUPPORTING THE UT2D AND NOS/BE
*        OPERATING SYSTEMS (SORRY GUYS, BUT IT WAS JUST TOO HARD TO
*        READ/MAINTAIN THE CODE, AND I HAVE NO WAY OF TESTING MY
*        MODS TO BE SURE THAT I DIDNT BREAK IT FOR THOSE SYSTEMS).
*
*        2. USED OVERLAYS TO REDUCE FIELD LENGTH AND STILL ALLOW THE
*        PROGRAM TO BE INSTALLED ON THE SYSTEM.
*
*        3. ADDED SUPPORT FOR 8/12 DISK FILES AND AUTO CHARACTER
*        SET RECOGNITION.  KERMIT FILE MODES ARE NOW "TEXT" OR
*        "BINARY".
*
*        4. CHANGED NEL CHARACTER TO 3777B TO AVOID CONFUSION WITH
*        EIGHT BIT DATA.
*
*        5. CHANGED CYBER BINARY FILE FORMAT TO PACKED 7.5 BYTES/WORD
*        (60 BIT BINARY) TO ALLOW CYBER BINARY FILES TO BE SENT TO
*        A MICRO, AND TO MAINTAIN COMPATABILITY WITH THE CYBER RMF
*        AND XMODEM UTILITIES.
*
*        6. ADDED #EOR AND #EOF TO PRESERVE THE STRUCTURE OF CYBER
*        TEXT FILES (E.G. CCL PROCFILES).
*
*        7. USED MULTIMESSAGE TRANSPARENT INPUT TO ALLOW RECEPTION
*        OF BINARY FILES WITHOUT EIGHT-BIT QUOTING (ASSUMING THAT
*        THE COMMUNICATION PATH IS EIGHT BITS WIDE).  EIGHT BIT QUOTING
*        IS STILL SUPPORTED IF NEEDED.
*
*        8. REMOVED THE PARITY SETTING CODE IN *PUTC*.  ON A CYBER
*        UNDER NOS, PARITY IS >NOT< THE RESPONSIBILITY OF AN APPLICATION
*        PROGRAM - IT IS SET BY THE OPERATING SYSTEM (I.E. CCP).  IF
*        IT IS INCORRECT THERE, CHANCES ARE YOU WILL NEVER GET FAR
*        ENOUGH TO START THIS PROGRAM.  IF IT IS SET CORRECTLY, THEN
*        THE PROGRAM DOESN*T NEED TO DO IT.  IN ANY CASE, IF THE PARITY
*        IN THE OPERATING SYSTEM IS SET TO ANYTHING OTHER THAN *NONE*,
*        SETTING THE HIGH BIT WHEN WE SEND CHARACTERS IS FUTILE.
*
*        9. ADDED DATA COMPRESSION/REPEAT COUNTS.
*
*        10. FIXED THE ! (MONITOR COMMAND) COMMAND.
*
*        11. KERMIT WILL NOW ATTEMPT TO GET OR ATTACH A FILE TO
*        BE SENT IF IT IS NOT LOCAL.
*
*        12. IMPLEMENTED SERVER *LOGOUT* COMMAND.  IT NOW WILL LOG
*        YOU OUT - SO BE SURE YOU DON*T HAVE ANY LOCAL FILES YOU
*        WANT TO KEEP.  THE SERVER *FINISH* COMMAND WILL STOP THE
*        SERVER WITHOUT LOGGING YOU OUT.
*
*        13. ALL IMPLEMENTED SERVER COMMANDS (SEND, GET, FINISH,
*        AND LOGOUT) WORK AS ADVERTISED.
*
*
*
*     X.X 8/17/84   OLAF PORS, UNIVERSITY OF VIRGINIA
*        KERMIT WAS ADAPTED TO NOS 2.1 (LEVEL 580 AND HOPEFULLY
*        LATER RELEASES).  DISK FILE FORMATS ARE "ASCII" - 6/12
*        DISPLAY CODE (74B AND 76B ESCAPE SEQUENCES), AND
*        "BINARY" - 8-BIT BINARY CHARACTERS IN 12-BIT
*        BYTES.  6/12 ASCII HAS UP TO 66-BIT
*        ZERO LINE TERMINATORS.  8/12 BINARY USES ZERO BYTES
*        AS FILLER (IGNORED), AND 4000B AS A ZERO. INPUT TO
*        THE PROGRAM FROM THE TERMINAL IS DONE IN ASCII MODE,
*        I.E., 6/12 ASCII.  THE MODE THAT THE TERMINAL WAS IN
*        BEFORE KERMIT WAS EXECUTED IS RESTORED ON EXIT,
*        UNLESS THE USER TERMINATES KERMIT WITH THE TERMINAL
*        BREAK 2 SEQUENCE.  JUST BEFORE FILE TRANSMISSION
*        TAKES PLACE, CCP IS TOLD TO TURN ECHOPLEX OFF, SO THAT
*        THE KERMIT ON THE OTHER END WON'T INTERPRET AN
*        ECHOED CARRIAGE RETURN AS A ZERO-LENGTH PACKET
*        FROM THE CYBER.  AT THE END OF FILE TRANSMISSION,
*        ECHOPLEX IS RESTORED TO WHATEVER 'DUPLEX' IS SET TO.
*        OUTPUT TO THE TERMINAL IS DONE USING TRANSPARENT
*        OUTPUT (0007 CONTROL BYTE).
*        IN ORDER TO TRANSFER BINARY FILES ACROSS LOCAL AREA
*        NETWORKS WHICH MAY NOT PRESERVE PARITY BITS,
*        8-BIT QUOTING IS ACCEPTED ON FILE RECEPTION, AND
*        REQUESTED DURING FILE SENDING.
*        NO EFFORT WAS MADE TO GET THE SERVER FUNCTION TO
*        WORK SINCE FEW OF THE KERMITS ON THE OTHER END
*        WOULD BE ABLE TO SEND SERVER COMMAND PACKETS.
*        IN FACT, THE ONLY COMMANDS SUPPORTED/ADVERTISED
*        TO USERS AT UVA ARE "SET FILE-MODE", "SHOW",
*        "SEND" AND "RECEIVE".  THESE ARE ALL THE COMMANDS
*        NEEDED TO ACCOMPLISH FILE TRANSFERS.
*
*     2.0   4/17/84  JIM KNUTSON, UNIVERSITY OF TEXAS AT AUSTIN
*        FIX FILENAME PACKET TO SEND UPPERCASE FILE NAMES ONLY.
*        CLEANUP ERROR PACKET HANDLING (ADDED TO STATE TABLE HANDLERS).
*        FIX RETRY COUNTS TO USE PROPER NUMBER. MODIFY CHARACTER TABLES.
*        MERGE RIC ANDERSON'S NOS/BE CODE.  TRY TO ORGANIZE THE
*        SOURCE A LITTLE BETTER.  ADDED PUSH AND ! COMMANDS.
*        ADD READ DELAY FOR PERFORMANCE TUNING.  CHANGED NEL BACK TO
*        205B.  THE BINARY DATA-MODE IGNORES NEL THOUGH.
*        UT2D REQUIRES THE NEL BE A 205B.  CHANGED CHARACTER TABLES
*        TO USE OCTAL CONSTANTS FOR NON-REPRESENTABLE CHARACTERS.
*
*     1.1   01/21/84  RIC ANDERSON, UNIVERSITY OF ARIZONA AT TUSCON
*        ADD OVCAPS FOR INSTALLATION IN NUCLEUS.  ADD DISPLAY CODE
*        SUPPORT.  REMOVE GOBS AND GOBS OF FIELD LENGTH.  CHANGED
*        NEL TO 4012B TO AVOID CONFUSION WITH DATA BYTE.  UPDATED
*        CHARACTER TABLES FOR 63 AND 64 CHARACTER SETS.  CHANGED
*        PERCENTS IN FPRINTFS TO AT-SIGNS SINCE 63 CHARACTER SET HAS
*        NO PERCENT SIGN.
*
*     1.0   10/14/84  JIM KNUTSON, UNIVERSITY OF TEXAS AT AUSTIN
*        ORIGINAL IMPLEMENTATION.
*
*     JIM KNUTSON
*     COMPUTATION CENTER ROOM 1
*     UNIVERISITY OF TEXAS
*     AUSTIN, TX   78712
*
*     APRPANET ADDRESS:  KNUTSON@UT-NGP
*
*     SPECIAL THANKS TO KING ABLES FOR HIS CONTRIBUTION.
*
*     MODIFIED FOR NOS/BE BY RIC ANDERSON
*     UNIVERSITY OF ARIZONA
*     COMPUTER CENTER
*     TUCSON, ARIZONA 85721
*
*     MODIFIED FOR NOS 2.2 BY JOERG HALLBAUER
*     CALIFORNIA STATE UNIVERSITIES
*     STATE UNIVERSITIY DATA CENTER
*     5670 WILSHIRE BLV. SUITE 2600
*     LOS ANGELES CA.  90036
*
*     FUTURE ENHANCEMENTS: 
*        MOVE HELP TEXT TO INDEXED RANDOM FILE
*        WILD CARD SENDS
*
*
*     BUILD SEQUENCE: 
*
*        FTN5,I,OPT=2,S=NOSTEXT,S=PSSTEXT,B=B1,CS.
*        FTN5,I,OPT=2,S=NOSTEXT,S=PSSTEXT,B=B2,CS.
*        LIBGEN(F=B2,P=KERMLIB)
*        LDSET,LIB=KERMLIB/SRVLIB.
*        LOAD,B1.
*        NOGO,KERMIT.
*
*
*     KERMIT I/O CONSIDERATIONS: 
*
*        KERMIT USES TWO MODES OF TERMINAL INPUT.  WHEN READING COMMANDS
*        AND SENDING FILES (FROM COMMAND RATHER THAN SERVER MODE) IT
*        USES NORMAL CODED (6/12) INPUT.  WHEN RECEIVING FILES, AND IN
*        SERVER MODE, IT USES MULTIMESSAGE TRANSPARENT INPUT IN ORDER
*        TO PROVIDE AN EIGHT BIT DATA PATH.
*
*        TERMINAL OUTPUT IS ALWAYS DONE IN TRANSPARENT MODE.
*
*        DISK I/O MAY BE IN ANY OF FOUR CHARACTER SETS: 
*           1. DISPLAY CODE - 6 BITS/CHARACTER.
*           2. EXTENDED DISPLAY CODE (6/12) - 6 OR 12 BITS/CHARACTER.
*           3. 8/12 ASCII - 8 BITS/CHARACTER IN 12 BIT BYTES.
*           4. BINARY - 60 BITS/WORD (7.5 BYTES/WORD).
*
*        TO SUPPORT CDC*S UNIQUE (READ STRANGE) SYSTEM OF FILE AND
*        RECORD MARKS KERMIT WILL CONVERT EOR*S IN A CYBER TEXT FILE
*        TO A LINE CONTAINING #EOR ON THE MICRO.  LIKEWISE EOF*S ARE
*        CONVERTED TO #EOF.  THUS MULTI-FILE AND MULTI-RECORD TEXT
*        FILES MAY BE STORED (OR CREATED) ON A MICRO AND THEN SENT
*        BACK TO A CYBER WITH THEIR STRUCTURE INTACT.
*
*        THIS CONVENTION IS THE SAME ONE USED BY CDC*S RMF (REMOTE
*        MICRO FACILITY) PRODUCT.
*
*        BINARY FILES WILL NOT HAVE THEIR RECORD STRUCTURE PRESERVED,
*        SO THE ONLY CYBER BINARIES THAT CAN BE SUCCESSFULLY MOVED TO
*        A MICRO AND THEN RESTORED TO THE CYBER ARE THOSE THAT CONSIST
*        OF A SINGLE RECORD (E.G. DATA FILES AND NON-OVERLAYED ABSOLUTE
*        EXECUTABLE PROGRAMS).
 
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      EXTERNAL EXITPGM
 
 
*     INITIALIZE
 
*IF -DEF,DEBUG,1
      CALL OVERLAY('KRM0100',1,0,'RECALL',1)
      IF(CMDFD .LT. 0) CALL OVERLAY('KRM1300', O"13",0,'RECALL',1)
*IF DEF,DEBUG,1
      CALL OVERLAY('KERMIT',1,0,'RECALL')
 
*     TRAP USER BREAKS AND TIME LIMITS
 
      CALL RECOVR(EXITPGM,O"204",0)
 
*     READ AND PARSE USER COMMANDS
 
 5    CALL GETCMD
      GO TO (200, 10, 20, 30, 10, 40, 50, 60, 70, 80, 90, 100, 110),
     +  CINDEX
 
*     - D I R E C T O R Y -
 
 200  CALL OVERLAY('KRM1200',O"12",0,'RECALL',1)
      GO TO 5
 
 
*     - E X I T -
*     - Q U I T -
 
 10   CALL EXITPGM
 
*     - H E L P -
 
*IF -DEF,DEBUG,1
 20   CALL OVERLAY('KRM0300',3,0,'RECALL',1)
*IF DEF,DEBUG,1
 20   CALL OVERLAY('KERMIT',3,0,'RECALL')
      GO TO 5
 
*     - P U S H -
 
 30   AUTORET = NO
*IF -DEF,DEBUG,1
      CALL OVERLAY('KRM0200',2,0,'RECALL',1)
*IF DEF,DEBUG,1
      CALL OVERLAY('KERMIT',2,0,'RECALL')
      GO TO 5
 
*     - R E C E I V E -
 
*IF -DEF,DEBUG,1
 40   CALL OVERLAY('KRM0400',4,0,'RECALL',1)
*IF DEF,DEBUG,1
 40   CALL OVERLAY('KERMIT',4,0,'RECALL')
      GO TO 5
 
*     - S E N D -
 
*IF -DEF,DEBUG,1
 50   CALL OVERLAY('KRM0500',5,0,'RECALL',1)
*IF DEF,DEBUG,1
 50   CALL OVERLAY('KERMIT',5,0,'RECALL')
      GO TO 5
 
*     - S E R V E R -
 
*IF -DEF,DEBUG,1
 60   CALL OVERLAY('KRM1100',O"11",0,'RECALL',1)
*IF DEF,DEBUG,1
 60   CALL OVERLAY('KERMIT',O"11",0,'RECALL')
      GO TO 5
 
*     - S E T -
 
*IF -DEF,DEBUG,1
 70   CALL OVERLAY('KRM0600',6,0,'RECALL',1)
*IF DEF,DEBUG,1
 70   CALL OVERLAY('KERMIT',6,0,'RECALL')
      GO TO 5
 
*     - S H O W -
 
*IF -DEF,DEBUG,1
 80   CALL OVERLAY('KRM0700',7,0,'RECALL',1)
*IF DEF,DEBUG,1
 80   CALL OVERLAY('KERMIT',7,0,'RECALL')
      GO TO 5
 
*     - S T A T U S -
 
*IF -DEF,DEBUG,1
 90   CALL OVERLAY('KRM1000',O"10",0,'RECALL',1)
*IF DEF,DEBUG,1
 90   CALL OVERLAY('KERMIT',O"10",0,'RECALL')
      GO TO 5
 
*     - T A K E -
 
100   CALL OVERLAY('KRM1300', O"13",0,'RECALL',1)
      GOTO 5
 
*     - ! -
 
 110  AUTORET = YES
*IF -DEF,DEBUG,1
      CALL OVERLAY('KRM0200',2,0,'RECALL',1)
*IF DEF,DEBUG,1
      CALL OVERLAY('KERMIT',2,0,'RECALL')
      GO TO 5
 
 
      END
      BLOCK DATA
 
***   BLOCK DATA - INITIALIZE VARIABLES IN COMMON.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 1)
 
*CALL COMCKER
 
      DATA CMDFD            / STDIN          /
      DATA DEBUG  , DEBUGFD / DBGOFF, 0      /
      DATA DUPLEX           / FULLDUP        /
      DATA FFD              / 0              /
      DATA FILMODE          / TEXT           /
      DATA TXTMODE          / CSNONE         /
      DATA FMODE            / MAXFILE*CLOSED /
      DATA FNWDS            / MAXFILE*0      /
      DATA FUNGTCH          / MAXFILE*EOF    /
      DATA FWPTR            / MAXFILE*0      /
      DATA INITDUP          / FULLDUP        /
      DATA MAXRINI          / MAXINIT        /
      DATA MAXRTRY          / MAXTRY         /
      DATA PACKNUM          / 0              /
      DATA RDELAY           / 0              /
      DATA SCHCNT , RCHCNT  / 2*0            /
      DATA SCHOVRH, RCHOVRH / 2*0            /
      DATA STARTIM, ENDTIM  / 2*0            /
      DATA STATE            / C              /
      DATA WAITPAK          / .TRUE.         /
 
      DATA SSYNC  , DSYNC  , RSYNC   / 3*SOH           /
      DATA SPKSIZE, DPKSIZE, RPKSIZE / IPKSIZE, 2*LPKSIZE /
      DATA STIMOUT, DTIMOUT, RTIMOUT / 3*ITIMOUT       /
      DATA SPADCT , DPADCT , RPADCT  / 3*IPADCT        /
      DATA SPADCH , DPADCH , RPADCH  / 3*IPADCH        /
      DATA SEOLCH , DEOLCH , REOLCH  / 3*IEOLCH        /
      DATA SCQUOTE, DCQUOTE, RCQUOTE / 3*ICQUOTE       /
      DATA S8QUOTE, D8QUOTE, R8QUOTE / Y,N,N           /
      DATA SCHKTYP, DCHKTYP, RCHKTYP / 3*ICHKTYP       /
      DATA SRPTPFX, DRPTPFX, RRPTPFX / IRPTPFX,2*BLANK /
 
*     IT IS UGLY TO MAKE THE SUCCESSFUL INITIATION OF FILE
*     TRANSMISSION DEPENDENT ON THE TIMING OF A USER TYPEIN.
*     HOWEVER, SUPPOSE WE TRANSMIT OUR SEND-INIT IMMEDIATELY.
*     THE OTHER KERMIT WON'T BE PREPARED TO RECEIVE IT
*     SINCE THE USER NEEDS TO ENTER SOME COMMANDS TO GET THE
*     OTHER KERMIT GOING, SO THE USER CAN SIMPLY FINISH
*     HIS TYPEINS AT HIS LEISURE, ENDING WITH 'RECEIVE',
*     THEN HIT ANOTHER CARRIAGE RETURN TO CAUSE US TO
*     RETRANSMIT THE SEND-INIT.  THUS, HE NEED FEEL NO
*     TIME PRESSURE.  WITH DELAYFP SET TO ZERO (NO DELAY),
*     THE FIRST SEND-INIT APPEARS AS GARBAGE ON HIS
*     SCREEN.  DELAYFP IS SET TO 2 SECONDS, TO GIVE THE
*     USER A LITTLE TIME TO GET OUT OF 'CONNECT' MODE,
*     SO HE WON'T SEE THE TRASH, BUT 2 SECONDS IS NOT SO
*     LONG THAT HE HAS TO WAIT IMPATIENTLY FOR THE
*     TRANSFER TO START.  2 SECONDS SHOULD ALSO BE SHORT
*     ENOUGH SO THAT HE DOESN'T HAVE TIME ENOUGH TO
*     TYPE 'RECEIVE', SO THAT HE MAY EXPECT CONSISTENTLY
*     TO INITIATE THE TRANSFER WITH A FINAL CARRIAGE RETURN.
 
      DATA DELAYFP          / 2 /
 
      DATA DEBUGFN          / 75, 69, 82, 77, 76, 79, 71, 0 /
*                              K   E   R   M   L   O   G
 
      DATA (ERRMSG(I),I=1,14) / 63, 75, 101, 114, 109, 105, 116, 45, 49,
*                             ?   K    E    R    M    I    T   -   1
     +                       55, 48, 58, 2*32 /
*                             7   0   : 
      DATA (MICMSG(I),I=1, 15) / 40, 76, 111, 99, 97, 108, 32, 75, 101,
*                                 (   L    O   C   A    L       K    E
     +   114, 109, 105, 116, 41, 32/
*          R    M    I    T   )
 
      DATA ABORTYP / 0 /
 
      DATA VERSION / '^CYBER-170/^N^O^S ^K^E^R^M^I^T ^VER 3.3    @S\N' /
      DATA HLPASCH / '^DECIMAL, OCTAL (^B), OR HEXIDECIMAL (^H) CODE FOR
     + ^A^S^C^I^I CHARACTER \N' /
      DATA HLPDLFP / '^NUMBER OF SECONDS TO DELAY FIRST PACKET\N' /
      DATA HLPDBFN / '^DEBUG OUTPUT LOGFILE SPECIFICATION\N' /
      DATA HLPPLEN / '^MAXIMUM PACKET LENGTH\N' /
      DATA HLPPADL / '^NUMBER OF PAD CHARACTERS TO USE\N' /
      DATA HLPIPRC / '^INITIAL PACKET RETRY COUNT\N' /
      DATA HLPPRTR / '^PACKET RETRY COUNT\N' /
      DATA HLPTIMO / '^NUMBER OF SECONDS TO WAIT BEFORE TIMEOUT\N' /
      DATA HLPSNFN / '^FILE ^NAME\N' /
      DATA HLPRDEL / '^MILLISECONDS TO DELAY EACH ^T^T^Y READ\N' /
 
      DATA DPCTBL/R" ",31*R" ",R" ",R"!",R"""",O"60",R"$",O"63",R"&",
* 63  DATA DPCTBL/R" ",31*R" ",R" ",R"!",R"""",O"60",R"$",R" ",R"&",
     +            O"70",R"(",R")",R"*",R"+",R",",R"-",R".",R"/",R"0",
     +            R"1",R"2",R"3",R"4",R"5",R"6",R"7",R"8",R"9",O"0",
* 63 +            R"1",R"2",R"3",R"4",R"5",R"6",R"7",R"8",R"9",O"63",
     +            R";",R"<",R"=",R">",O"71",R"@",R"A",R"B",R"C",R"D",
     +            R"E",R"F",R"G",R"H",R"I",R"J",R"K",R"L",R"M",R"N",
     +            R"O",R"P",R"Q",R"R",R"S",R"T",R"U",R"V",R"W",R"X",
     +            R"Y",R"Z",R"[",O"75",R"]",O"76",O"65",R"@",R"A",
     +            R"B",R"C",R"D",R"E",R"F",R"G",R"H",R"I",R"J",R"K",
     +            R"L",R"M",R"N",R"O",R"P",R"Q",R"R",R"S",R"T",R"U",
     +            R"V",R"W",R"X",R"Y",R"Z",R"[",R"\",R"]",R"^",R" "/
 
        DATA LASCII/58,97,98,99,100,101,102,103,104,105,106,107,108,109,
*                    :  A  B  C   D   E   F   G   H   I   J   K   L   M
* 63    DATA LASCII/32,97,98,99,100,101,102,103,104,105,106,107,108,109,
* 63                    A  B  C   D   E   F   G   H   I   J   K   L   M
     +              110,111,112,113,114,115,116,117,118,119,120,121,122,
*                     N   O   P   Q   R   S   T   U   V   W   X   Y   Z
     +              48,49,50,51,52,53,54,55,56,57,
*                    0  1  2  3  4  5  6  7  8  9
     +              43,45,42,47,40,41,36,61,32,44,46,35,91,93,37,
*                    +  -  *  /  (  )  $  =     ,  .  <  [  ]  <PCT>
* 63 +              43,45,42,47,40,41,36,61,32,44,46,35,91,93,58,
* 63                 +  -  *  /  (  )  $  =     ,  .  <  [  ]  : 
     +              34,95,33,38,39,63,60,62,64,92,94,59/
*                    "  #  !  &  '  ?  <  >  @  \  ^  ;
 
        DATA UASCII/58,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,
*                    :  A  B  C  D  E  F  G  H  I  J  K  L  M  N  O  P
* 63    DATA UASCII/32,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,
* 63                    A  B  C  D  E  F  G  H  I  J  K  L  M  N  O  P
     +              81,82,83,84,85,86,87,88,89,90,48,49,50,51,52,53,54,
*                    Q  R  S  T  U  V  W  X  Y  Z  0  1  2  3  4  5  6
     +              55,56,57,43,45,42,47,40,41,36,61,32,44,46,35,91,93,
*                    7  8  9  +  -  *  /  (  )  $  =     ,  .  <  [  ]
     +              37,34,95,33,38,39,63,60,62,64,92,94,59/
*                <PCT>  "  #  !  &  '  ?  <  >  @  \  ^  ;
* 63 +              58,34,95,33,38,39,63,60,62,64,92,94,59/
* 63                 :  "  #  !  &  '  ?  <  >  @  \  ^  ;
 
 
      DATA SX1274 /
     +  BLANK,O"100",O"136",BLANK,O"72",BLANK,BLANK,O"140",56*BLANK/
* 63 +  BLANK,O"100",O"136",BLANK,O"45",BLANK,BLANK,O"140",56*BLANK/
 
      DATA  SX1276 /
     +  BLANK,O"141",O"142",O"143",O"144",O"145",O"146",O"147",O"150",
     +  O"151",O"152",O"153",O"154",O"155",O"156",O"157",O"160",O"161",
     +  O"162",O"163",O"164",O"165",O"166",O"167",O"170",O"171",O"172",
     +  O"173",O"174",O"175",O"176",O"177",O"4000",O"1",O"2",O"3",O"4",
     +  O"5",O"6",O"7",O"10",O"11",O"12",O"13",O"14",O"15",O"16",
     +  O"17",O"20",O"21",O"22",O"23",O"24",O"25",O"26",O"27",O"30",
     +  O"31",O"32",O"33",O"34",O"35",O"36",O"37"/
 
      DATA  ASC612 /
     +  O"7640",O"7641",O"7642",O"7643",O"7644",O"7645",O"7646",O"7647",
     +  O"7650",O"7651",O"7652",O"7653",O"7654",O"7655",O"7656",O"7657",
     +  O"7660",O"7661",O"7662",O"7663",O"7664",O"7665",O"7666",O"7667",
     +  O"7670",O"7671",O"7672",O"7673",O"7674",O"7675",O"7676",O"7677",
     +  O"55",O"66",O"64",O"60",O"53",O"63",O"67",O"70",O"51",O"52",
* 63 +  O"55",O"66",O"64",O"60",O"53",O"7404",O"67",O"70",O"51",O"52",
     +  O"47",O"45",O"56",O"46",O"57",O"50",O"33",O"34",O"35",O"36",
     +  O"37",O"40",O"41",O"42",O"43",O"44",O"7404",O"77",O"72",O"54",
* 63 +  O"37",O"40",O"41",O"42",O"43",O"44",O"63",O"77",O"72",O"54",
     +  O"73",O"71",O"7401",O"1",O"2",O"3",O"4",O"5",O"6",O"7",O"10",
     +  O"11",O"12",O"13",O"14",O"15",O"16",O"17",O"20",O"21",O"22",
     +  O"23",O"24",O"25",O"26",O"27",O"30",O"31",O"32",O"61",O"75",
     +  O"62",O"7402",O"65",O"7407",O"7601",O"7602",O"7603",O"7604",
     +  O"7605",O"7606",O"7607",O"7610",O"7611",O"7612",O"7613",O"7614",
     +  O"7615",O"7616",O"7617",O"7620",O"7621",O"7622",O"7623",O"7624",
     +  O"7625",O"7626",O"7627",O"7630",O"7631",O"7632",O"7633",O"7634",
     +  O"7635",O"7636",O"7637"/
 
 
      END
      SUBROUTINE GETCMD
 
***   GETCMD - READ AND PARSE A COMMAND
*
*     PROMPT THE USER FOR A COMMAND AND RETURN AN INTEGER
*     INDEX CORRESPONDING TO THE COMMAND.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      PARAMETER (TSIZE = 13)
      CHARACTER*10 CMD(TSIZE)
 
      DATA CMD / 'DIRECTORY', 'EXIT', 'HELP', 'PUSH', 'QUIT', 'RECEIVE',
     +  'SEND', 'SERVER', 'SET', 'SHOW', 'STATUS', 'TAKE', '!' /
 
 
10    CONTINUE
      IF(CMDFD .EQ. STDIN) THEN
         CALL FPRINTF(STDOUT,'^KERMIT-170>')
         CALL FFLUSH(STDOUT)
         CALL FFLUSH(STDIN)
      ENDIF
      CINDEX = MATCH(CMD,TSIZE,.TRUE.)
      IF (CINDEX .EQ. EOF) THEN
         IF(CMDFD .NE. STDIN) THEN
            CALL FCLOSE(CMDFD)
            IF(.NOT.CMDLOCF) CALL RETFILE(CMDLFN)
         ENDIF
         CMDFD = STDIN
         GOTO 10
      ELSE IF (CINDEX .EQ. ERROR .OR. CINDEX .EQ. 0) THEN
         GOTO 10
      ENDIF
 
      RETURN
      END
      SUBROUTINE EXITPGM
 
***   EXITPGM - EXIT THE PROGRAM
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
 
*     RESET TERMINAL PARAMETERS IN CASE OF ABORT
 
      IF (INITDUP .EQ. FULLDUP) THEN
         CALL STTY('RCV-OFF',FULLDUP)
      ELSE
         CALL STTY('RCV-OFF',HALFDUP)
      ENDIF
 
*     FLUSH THE DEBUG FILE
 
      IF (DEBUGFD .NE. CLOSED) CALL FCLOSE(DEBUGFD)
 
*     EXIT TO OPERATING SYSTEM
 
      CALL ENDRUN
 
      END
      OVERLAY(1,0)
      PROGRAM KRM0100
 
***   PRESET - INITIALIZE RUNNING ENVIRONMENT.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER*10 FN
      LOGICAL CFE
      DIMENSION  FET(6), BUFFER(1000)
 
      DATA FN / ' ' /
 
*     INSURE WE ARE AN INTERACTIVE JOB.
 
      IF (USTART().NE.0) THEN
         CALL REMARK(' KERMIT - INCORRECT JOB ORIGIN.')
         CALL ABORT
      ENDIF
 
*     KERMIT IS WRITTEN TO USE THE DISPLAY CODE COLLATING
*     SEQUENCE WITH THE CHAR AND ICHAR FUNCTIONS.
 
      CALL COLSEQ('DISPLAY')
 
*     IF 63 CHARACTER SET, FIX THE CONVERSION TABLES.
 
      IF(ICHAR(':') .EQ. O"63") CALL FIXCTAB
 
*     OPEN THE I/O FILES.
 
      IF (FOPEN('STDIN',RD,CS612) .NE. STDIN) THEN
         CALL REMARK(' CANNOT OPEN STANDARD INPUT')
         CALL ABORT
      ELSE IF (FOPEN('STDOUT',WR,CSTXP) .NE. STDOUT) THEN
         CALL REMARK(' CANNOT OPEN STANDARD OUTPUT')
         CALL ABORT
      ENDIF
 
*     READ IN ENVIRONMENT IF PRESENT
 
      IF (CFE('ZZZZKEN')) THEN
         CALL MAKEFET('ZZZZKEN', FET, 6, BUFFER, 1000)
         CALL REWIND(FET, 1)
         CALL READ(FET, 1)
         CALL READW(FET,HEADER,LOCF(TRAILER)-LOCF(HEADER),STATUS)
         CALL RETURN(FET, 1)
      ELSE
         CALL DPC2AS(VERSDAT, VERSSTR, 10)
         CALL FPRINTF(STDOUT,VERSION,VERSSTR,0,0,0)
         CMDFD = -1
      ENDIF
 
 
      RETURN
      END
      SUBROUTINE FIXCTAB
 
***   FIXCTAB - FIX CONVERSION TABLES IF RUNNING ON A 63 CHARACTER SET
*     NOS SYSTEM.  WE NEED TO REVERSE THE COLON AND PERCENT SIGN FOR
*     ASCII CHARACTER SETS, AND REMOVE THE PERCENT SIGN IN DISPLAY CODE.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
 
 
      DPCTBL(37) = R" "
      DPCTBL(58) = O"63"
      LASCII(0) = 32
      LASCII(O"63") = 58
      UASCII(0) = 32
      UASCII(O"63") = 58
      SX1274(4) = O"45"
      ASC612(37) = O"7404"
      ASC612(58) = O"63"
 
      RETURN
      END
      OVERLAY(2,0)
      PROGRAM KRM0200
 
***   EXECMD - EXECUTE A CONTROL STATEMENT
*
*     EXECUTE A CONTROL STATEMENT AND RETURN TO COMMAND MODE OR
*     EXIT TO THE OPERATING SYSTEM.  NEXT EXECUTION OF KERMIT
*     WILL START WITH THE CURRENT ENVIRONMENT.  THIS SUBROUTINE
*     DOES NOT RETURN UNLESS THERE ARE ERRORS.
*
*     WE WRITE OUT THE KERMIT ENVIRONMENT USING THE NOS *SRVLIB*
*     ROUTINES BECAUSE WE WRITE OUT THE KERMIT FILE/BUFFER AREAS.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      BOOLEAN STR(80)
      CHARACTER*80 CMD
      LOGICAL CONFIRM
      DIMENSION FET(6), BUFFER(1000)
 
*     BEFORE WE DO ANYTHING RASH
 
      IF (AUTORET .EQ. NO) THEN
         IF (.NOT. CONFIRM(CMDFD)) RETURN
      ELSE
 
*        GET THE NOS CONTROL STATEMENT FROM THE COMMAND LINE.
*        MUST BE DONE BEFORE WRITING OUT THE ENVIRONMENT.
 
         OPOS = 1
         TERM = 46
 10      IF (GETC(CMDFD,CH) .EQ. NEL) THEN
            STR(OPOS+0) = TERM
            STR(OPOS+1) = 0
         ELSE
            IF (CH .NE. BLANK .OR. OPOS .GT. 1) THEN
               STR(OPOS) = CH
               OPOS = OPOS+1
            ENDIF
            IF (CH .EQ. 41 .OR. CH .EQ. 46) THEN
               TERM = 0
            ENDIF
            GOTO 10
         ENDIF
      ENDIF
 
*     WRITE OUT THE CURRENT ENVIRONMENT
 
      CALL MAKEFET('ZZZZKEN', FET, 6, BUFFER, 1000)
      CALL RETURN(FET, 1)
      CALL WRITEW(FET,HEADER,LOCF(TRAILER)-LOCF(HEADER),STATUS)
      CALL WRITER(FET, 1)
 
*     IF ONLY EXIT TO THE OPERATING SYSTEM
 
      IF (AUTORET .EQ. NO) THEN
         CALL EXITPGM
      ENDIF
 
*     QUIT IF NO COMMAND ENTERED
 
      IF (OPOS .EQ. 1) RETURN
 
*     PACK THE COMMAND INTO A *C* FORMAT LINE
 
      DO 20 I=1,80
         CMD(I:I) = ':'
 20   CONTINUE
      CALL AS2DPC(STR,CMD)
 
*     WRITE THE CCL PROCEDURE FILE AND BEGIN IT
 
      CALL RETFILE('ZZZZKCC')
      CALL EXE(CMD)
 
 
      END
      OVERLAY(3,0)
      PROGRAM KRM0300
 
***   HLPCMD - PROCESS THE HELP COMMAND.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      PARAMETER (HFLAG = 45)
 
      CHARACTER WORD*20, RECWORD*20
      CHARACTER HELPPFN*10, HELPLFN*10, HELPUN*10
      INTEGER ASTR(21)
      LOGICAL CFE, SKIP
 
      DATA HELPPFN/'KERMHLP'/, HELPLFN/'ZZZZKHL'/, HELPUN/'LIBRARY'/
 
*     FIRST, GET THE HELP FILE.
 
      CALL PF('ATTACH', HELPLFN, HELPPFN, 'UN', HELPUN,
     +        'RC', REPLY, 'NA', ' ')
      IF(REPLY .NE. 0) THEN
         CALL FPRINTF(STDOUT,'^SORRY, BUT THE ^KERMIT HELP FILE'//
     +    ' IS NOT AVAILABLE\N',0,0,0,0)
         RETURN
      ENDIF
      HFD = FOPEN(HELPLFN, RD, CS612)
 
*     NEXT, GET THE KEYWORD AND SEARCH FOR MATCHING RECORD.
 
      LEN = GETWORD(CMDFD, ASTR, 20)
      IF(LEN .EQ. 0) THEN
         WORD = 'HELP'
         LEN = 4
      ELSE
         CALL AS2DPC(ASTR, WORD)
      ENDIF
      SKIP = .TRUE.
      LINES = 22
 
*     READ A LINE INTO 'PACKET' BUFFER.
 
10    I = 1
20    HELPEOF = GETC(HFD, CH)
      IF(HELPEOF .EQ. EOF) THEN
         GOTO 90
      ELSE
         PACKET(I) = CH
         I = I + 1
         IF(CH .NE. NEL) GOTO 20
         PACKET(I) = 0
      ENDIF
 
*     GOT FULL LINE.  SKIP, DISPLAY (22 LINES/PAGE), START DISPLAY,
*     OR EXIT.
 
      IF(PACKET(1) .NE. HFLAG) THEN
         IF(SKIP) THEN
         ELSE
            CALL PUTSTR(STDOUT, PACKET)
            LINES = LINES - 1
            IF(LINES .EQ. 0) THEN
               CALL FPRINTF(STDOUT, '@C\N',BELL,0,0,0)
               CALL FFLUSH(STDIN)
30             CALL GETC(STDIN, CH)
               IF(CH .NE. NEL) GOTO 30
               LINES = 22
            ENDIF
         ENDIF
      ELSE
         IF(SKIP) THEN
            CALL AS2DPC(PACKET(2), RECWORD)
            IF(WORD(1:LEN) .EQ. RECWORD(1:LEN)) THEN
               SKIP = .FALSE.
            ENDIF
         ELSE
            GOTO 90
         ENDIF
      ENDIF
      GOTO 10
 
90    CALL FCLOSE(HFD)
      CALL RETFILE(HELPLFN)
      RETURN
      END
      OVERLAY(4,0)
      PROGRAM KRM0400
 
***   RCVFILE - TOP LEVEL SUBROUTINE TO START RECEIVE STATE.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      LOGICAL CONFIRM
 
*     CONFIRM THE COMMAND
 
      IF (.NOT. CONFIRM(CMDFD)) RETURN
 
*     ENSURE THERE IS NO JUNK IN THE FILE ARRAY.  THIS KEEPS 'REMOVE'
*     HAPPY, IN THE EVENT WE BLOW OFF BEFORE WE GET A FILE SPEC.
 
      CALL FPRINTF(STDOUT,'[^ESCAPE BACK TO MICRO TO ^S^E^N^D FILE(S).]
     +\N',0,0,0,0)
 
      DO 10 I = 1, IPKSIZE
          FILESTR(I) = 0
10    CONTINUE
 
*     SET TERMINAL PARAMETERS
 
      CALL STTY('RCV-ON',0)
 
*     RECEIVE THE FILE
 
      IF (RECEIVE(R) .EQ. OK) THEN
         CALL FPRINTF(STDOUT,'^RECEIVE COMPLETE.\N',0,0,0,0)
      ELSE
         CALL FPRINTF(STDOUT,'^RECEIVE FAILED.\N',0,0,0,0)
      ENDIF
 
*     RESET TERMINAL PARAMETERS
 
      IF (INITDUP .EQ. FULLDUP) THEN
         CALL STTY('RCV-OFF',FULLDUP)
      ELSE
         CALL STTY('RCV-OFF',HALFDUP)
      ENDIF
 
 
      RETURN
      END
      OVERLAY(5,0)
      PROGRAM KRM0500
 
***   SNDFILE - SEND A FILE TO OTHER KERMIT.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      LOGICAL GETFILE
      LOGICAL WILDSET
      CHARACTER*10 LFN
 
 
*     PICK UP THE FILE NAME AND SAVE IT FOR OPENING LATER
 
      CALL SETVAL(FILESTR,'S',IRET,9,0,0,HLPSNFN,.TRUE.)
      IF (IRET .EQ. ERROR) RETURN
 
*     GET POSSIBLE FILE TYPE AND MAKE SURE THE NAME IS LEGAL.
 
      CALL GETFTY(FILESTR, FTYPE)
      CALL AS2DPC(FILESTR,LFN)
      IF(.NOT.WILDSET(LFN)) THEN
         CALL FPRINTF(STDOUT,'?^ILLEGAL FILE NAME: "@S".\N',FILESTR,
     +                0,0,0)
         RETURN
      ENDIF
 
*     CHECK TO MAKE SURE THERE IS A FILE TO SEND SOMEWHERE
 
      IF(.NOT. GETFILE(FTYPE)) THEN
         CALL FPRINTF(STDOUT,'?^FILE "@S" NOT FOUND.\N',FILESTR,0,0,0)
         RETURN
      ENDIF
      CALL FPRINTF(STDOUT,'[^ESCAPE BACK TO MICRO TO RECEIVE ',0,0,0,0)
      IF(LOCFILE) THEN
         CALL FPRINTF(STDOUT,'LOCAL FILE(S).]\N',0,0,0,0)
      ELSE
         CALL FPRINTF(STDOUT,'PERMANENT FILE(S).]\N',0,0,0,0)
      ENDIF
 
*     SET TERMINAL PARAMETERS
 
      CALL STTY('RCV-ON',0)
 
*     DELAY THE FIRST PACKET
 
      IF (DELAYFP .GT. 0) CALL SLEEP(DELAYFP)
 
*     SEND THE FILE
 
      PACKNUM = 0
      IF (SEND(F, ' ') .EQ. OK) THEN
         CALL FPRINTF(STDOUT,'^SEND COMPLETE.\N',0,0,0,0)
      ELSE
         CALL FPRINTF(STDOUT,'^SEND FAILED.\N',0,0,0,0)
      ENDIF
 
*     RESET TERMINAL PARAMETERS
 
      IF (INITDUP .EQ. FULLDUP) THEN
         CALL STTY('RCV-OFF',FULLDUP)
      ELSE
         CALL STTY('RCV-OFF',HALFDUP)
      ENDIF
 
 
      RETURN
      END
      OVERLAY(6,0)
      PROGRAM KRM0600
 
***   SET - SET SOME ATTRIBUTES.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      PARAMETER (TSIZE=10)
      CHARACTER*10 SETTYP(TSIZE)
      DATA SETTYP /  'DEBUG', 'DELAY', 'DUPLEX', 'FILE-MODE',
     +    'INIT-RETRY', 'RECEIVE', 'RDELAY', 'RETRY', 'SEND',
     +    'TEXT-MODE'/
 
 
      INDX = MATCH(SETTYP,TSIZE,.FALSE.)
      IF (INDX .LE. 0) RETURN
      GO TO (20, 30, 40, 10, 50, 70, 75, 80, 90, 100), INDX
 
*     SET CHARACTER SET
 
10    CALL DMODCMD
      RETURN
 
*     SET DEBUGGING MODES
 
20    CALL DBUGCMD
      RETURN
 
*     SET FIRST PACKET DELAY
 
30    CALL SETVAL(DELAYFP,'I',0,30,0,30,HLPDLFP,.TRUE.)
      RETURN
 
*     SET THE DUPLEX
 
40    CALL DPLXCMD
      RETURN
 
*     SET INTIAL PACKET RETRY COUNT
 
50    CALL SETVAL(MAXRINI,'I',1,50,1,50,HLPIPRC,.TRUE.)
      RETURN
 
*     SET ATTRIBUTES WE REQUEST OF OTHER KERMIT
 
70    CALL SETPACK(SPKSIZE)
      RETURN
 
*     SET READ DATA DELAY
 
75    CALL SETVAL(RDELAY,'I',0,2000,0,2000,HLPRDEL,.TRUE.)
      RETURN
 
*     SET PACKET RETRY COUNT
 
80    CALL SETVAL(MAXRTRY,'I',1,50,1,50,HLPPRTR,.TRUE.)
      RETURN
 
*     SET DEFAULT ATTRIBUTES USED WHEN SENDING TO OTHER KERMIT
 
90    CALL SETPACK(DPKSIZE)
      RETURN
 
*     SET TEXT MODE (AUTO, 6/12, DISPLAY, 8/12)
 
100   CALL TXTMCMD
      RETURN
 
      END
      OVERLAY(7,0)
      PROGRAM KRM0700
 
***   SHOW - DISPLAY THE CURRENT PROGRAM SETTINGS
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      LOGICAL CONFIRM
 
*CALL COMXKER
 
 
*     CONFIRM THE COMMAND
 
      IF (.NOT. CONFIRM(CMDFD)) RETURN
      CALL DPC2AS(VERSDAT, VERSSTR, 10)
      CALL FPRINTF(STDOUT,VERSION,VERSSTR,0,0,0)
 
*     DISPLAY THE CURRENT DATE AND TIME
 
      CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
      CALL PUTDAY(STDOUT,MM,DD,YY)
      CALL FPRINTF(STDOUT,', ',0,0,0,0)
      CALL PUTMNTH(STDOUT,MM)
      CALL FPRINTF(STDOUT,' @D, @D ',DD,YY,0,0)
      IF (HR .LT. 10) CALL PUTC(ASC('0'),STDOUT)
      CALL FPRINTF(STDOUT,'@D:',HR,0,0,0)
      IF (MIN .LT. 10) CALL PUTC(ASC('0'),STDOUT)
      CALL FPRINTF(STDOUT,'@D:',MIN,0,0,0)
      IF (SEC .LT. 10) CALL PUTC(ASC('0'),STDOUT)
      CALL FPRINTF(STDOUT,'@D\N\N',SEC,0,0,0)
 
*     DISPLAY DISK CHARACTER SET
 
      CALL FPRINTF(STDOUT,'  ^FILE-MODE: ',0,0,0,0)
      IF(FILMODE .EQ. TEXT) THEN
         CALL FPRINTF(STDOUT,'^TEXT (',0,0,0,0)
         IF(TXTMODE .EQ. CSNONE) THEN
            CALL FPRINTF(STDOUT,'AUTO)',0,0,0,0)
         ELSE IF(TXTMODE .EQ. CSDSP) THEN
            CALL FPRINTF(STDOUT,'DISPLAY)',0,0,0,0)
         ELSE IF(TXTMODE .EQ. CS612) THEN
            CALL FPRINTF(STDOUT,'6/12-ASCII)',0,0,0,0)
         ELSE IF(TXTMODE .EQ. CS812) THEN
            CALL FPRINTF(STDOUT,'8/12-ASCII)',0,0,0,0)
         ENDIF
      ELSE
         CALL FPRINTF(STDOUT,'^BINARY',0,0,0,0)
      ENDIF
 
*     DISPLAY THE CURRENT DUPLEX
 
      CALL FPRINTF(STDOUT,'           ^DUPLEX: ',0,0,0,0)
      IF (GTTY('DUPLEX') .EQ. FULLDUP) THEN
         CALL FPRINTF(STDOUT,'^FULL\N',0,0,0,0)
      ELSE
         CALL FPRINTF(STDOUT,'^HALF\N',0,0,0,0)
      ENDIF
 
*     DISPLAY CURRENT DEBUG MODES
 
      CALL FPRINTF(STDOUT,'  ^DEBUGGING: ',0,0,0,0)
      IF ((DEBUG.AND.DBGSTAT).NE.0) THEN
         IF ((DEBUG.AND.DBGPACK).NE.0) THEN
            CALL FPRINTF(STDOUT,'^STATES/^PACKETS',0,0,0,0)
         ELSE
            CALL FPRINTF(STDOUT,'^STATES        ',0,0,0,0)
         ENDIF
      ELSE
         IF ((DEBUG.AND.DBGPACK).NE.0) THEN
            CALL FPRINTF(STDOUT,'^PACKETS       ',0,0,0,0)
         ELSE
            CALL FPRINTF(STDOUT,'^OFF           ',0,0,0,0)
         ENDIF
      ENDIF
      IF (DEBUG .NE. DBGOFF) THEN
         CALL FPRINTF(STDOUT,'   ^LOG FILE: @S',DEBUGFN,0,0,0)
      ENDIF
 
*     DISPLAY PACKET SETTINGS
 
      CALL FPRINTF(STDOUT,'\N\N^PACKET ^PARAMETERS\N',0,0,0,0)
      CALL FPRINTF(STDOUT,
     +   '                    ^RECEIVE   ^SEND\N',0,0,0,0)
      CALL FPRINTF(STDOUT,'  ^SIZE:             @D        @D\N',
     +   SPKSIZE,DPKSIZE,0,0)
      CALL FPRINTF(STDOUT,'  ^TIMEOUT:          @D        @D\N',
     +   STIMOUT,DTIMOUT,0,0)
      CALL FPRINTF(STDOUT,'  ^PADDING:          @D',SPADCT,0,0,0)
      IF (SPADCT .LT. 10) CALL PUTC(BLANK,STDOUT)
      CALL FPRINTF(STDOUT,'        @D\N',DPADCT,0,0,0)
      CALL FPRINTF(STDOUT,'  ^PAD CHARACTER:    \^@C        \^@C\N',
     +   CTL(SPADCH),CTL(DPADCH),0,0)
      CALL FPRINTF(STDOUT,'  ^END-OF-^LINE:      \^@C        \^@C\N',
     +   CTL(SEOLCH),CTL(DEOLCH),0,0)
      CALL FPRINTF(STDOUT,'  ^CONTROL QUOTE:    @C         @C\N',
     +   SCQUOTE,DCQUOTE,0,0)
      CALL FPRINTF(STDOUT,'  ^EIGHT-BIT QUOTE:  @C         @C\N',
     +   S8QUOTE,D8QUOTE,0,0)
      CALL FPRINTF(STDOUT,'  ^REPEAT-PREFIX:    @C         @C\N',
     +   SRPTPFX,DRPTPFX,0,0)
      CALL FPRINTF(STDOUT,'  ^START-OF-^PACKET:  \^@C        \^@C\N',
     +   CTL(SSYNC),CTL(DSYNC),0,0)
 
*     DISPLAY PROTOCOL STUFF
 
      CALL FPRINTF(STDOUT,'\N^DELAY BEFORE SENDING FIRST PACKET: @D (SEC
     +ONDS)\N',DELAYFP,0,0,0)
      CALL FPRINTF(STDOUT,'^DELAY BEFORE EACH ^T^T^Y READ: @D (MILLISECO
     +NDS)\N',RDELAY,0,0,0)
      CALL FPRINTF(STDOUT,'^INIT PACKET RETRY COUNT: @D\N',MAXRINI,0,0,
     +0)
      CALL FPRINTF(STDOUT,'^PACKET RETRY COUNT: @D\N\N',MAXRTRY,0,0,0)
 
 
      RETURN
      END
      OVERLAY(10,0)
      PROGRAM KRM1000
 
***   STATUS - TELL HOW LONG LAST TRANSFER TOOK.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      LOGICAL CONFIRM
 
 
*     CONFIRM THE COMMAND
 
      IF (.NOT. CONFIRM(CMDFD)) RETURN
 
*     DISPLAY STATISTICS FOR LAST TRANSFER
 
      CALL FPRINTF(STDOUT,
     +   '^MAX CHARACTERS IN PACKET: @D RECEIVED; @D SENT\N',SPKSIZE,
     +   RPKSIZE)
      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 FPRINTF(STDOUT,'^NUMBER OF CHARACTERS TRANSMITTED IN ',0,0)
      IF (HR  .GT. 0) CALL FPRINTF(STDOUT,'@D HOURS ',HR,0)
      IF (MIN .GT. 0) CALL FPRINTF(STDOUT,'@D MINUTES ',MIN,0)
      CALL FPRINTF(STDOUT,'@D SECONDS\N\N',NSEC,0)
      CALL FPRINTF(STDOUT,'             ^SENT:  @20D',SCHCNT,0)
      CALL FPRINTF(STDOUT,' ^OVERHEAD:  @D\N',SCHOVRH,0)
      CALL FPRINTF(STDOUT,'         ^RECEIVED:  @20D',RCHCNT,0)
      CALL FPRINTF(STDOUT,' ^OVERHEAD:  @D\N',RCHOVRH,0)
      CALL FPRINTF(STDOUT,'^TOTAL TRANSMITTED:  @20D',SCHCNT+RCHCNT,0)
      CALL FPRINTF(STDOUT,' ^OVERHEAD:  @D\N\N',SCHOVRH+RCHOVRH,0)
      CALL FPRINTF(STDOUT,
     +   '^TOTAL CHARACTERS TRANSMITTED PER SEC: @D\N',
     +   (SCHCNT+RCHCNT) / (ENDTIM-STARTIM),0)
      CALL FPRINTF(STDOUT,
     +   '^EFFECTIVE DATA RATE: @D BAUD\N\N', ((SCHCNT+RCHCNT) -
     +   (SCHOVRH+RCHOVRH)) / (ENDTIM-STARTIM) * 10,0)
      IF(ABORTYP .NE. 0) THEN
         CALL GETEMSG(PACKET)
         CALL FPRINTF(STDOUT,'?^KERMIT:  @S\N',PACKET,0)
      ENDIF
 
 
      RETURN
      END
      OVERLAY(11,0)
      PROGRAM KRM1100
 
***   SERVER - START KERMIT SERVER
*
*     THE SERVER CAN CURRENTLY RESPOND TO THE FOLLOWING PACKETS: 
*
*        S  (SEND-INIT)
*        R  (RECEIVE-INIT)
*        GL (GENERIC LOGOUT)
*        GF (GENERIC FINISH)
*
*     OTHER PACKETS ARE REPLIED TO WITH AN E (ERROR) PACKET CONTAINING
*     AN "UNIMPLEMENTED SERVER COMMAND" MESSAGE.
 
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      LOGICAL CONFIRM
 
*     CONFIRM THE COMMAND
 
      IF (.NOT. CONFIRM(CMDFD)) RETURN
 
*     SET TERMINAL PARAMETERS
 
      CALL STTY('RCV-ON',0)
 
*     INITIALIZE
 
      PACKNUM = 0
      NUMTRY = 0
      CALL FPRINTF(STDOUT,'[^KERMIT SERVER RUNNING ON ^CYBER HOST.  ^PLE
     +ASE TYPE YOUR ESCAPE SEQUENCE TO\N RETURN TO YOUR LOCAL MACHINE. ^
     +SHUT DOWN THE SERVER BY TYPING THE ^KERMIT ^B^Y^E \N OR ^F^I^N^I^S
     +^H COMMAND ON YOUR LOCAL MACHINE.]\N')
 
 
*     DON'T WAIT AROUND FOR SERVER PACKET; ALLOW SWAPOUT.
 
10    WAITPAK = .FALSE.
      PTYP = RDPACK(LEN, NUM, RECPACK)
      WAITPAK = .TRUE.
      PACKNUM = NUM
      PSIZE = LEN
 
*     S E N D - I N I T
 
      IF (PTYP .EQ. S) THEN
         CALL OVERLAY('KRM1101', O"11", 1, 'RECALL', 1)
 
*     I N I T I A L I Z E
 
      ELSE IF (PTYP .EQ. EYE) THEN
         CALL OVERLAY('KRM1102', O"11", 2, 'RECALL', 1)
*     R E C E I V E - I N I T
 
      ELSE IF (PTYP .EQ. R) THEN
         CALL OVERLAY('KRM1103', O"11", 3, 'RECALL', 1)
 
*     A B O R T
 
      ELSE IF (PTYP .EQ. A) THEN
         IF(INITDUP .EQ. FULLDUP) THEN
            CALL STTY('RCV-OFF',FULLDUP)
         ELSE
            CALL STTY('RCV-OFF',HALFDUP)
         ENDIF
         RETURN
 
*     G E N E R I C
 
      ELSE IF (PTYP .EQ. G) THEN
         CALL OVERLAY('KRM1104', O"11", 4, 'RECALL', 1)
*        U N K N O W N
 
      ELSE
         IF (DEBUG .NE. 0) CALL FPRINTF(DEBUGFD,'SERVER: INVALID PACKET
     -TYPE\N')
         ABORTYP = INVALID.OR.READING.OR.SRVCMD
         CALL GETEMSG(ERRMSG(15))
         CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG)
 
      ENDIF
      GOTO 10
 
      END
      OVERLAY (11,1)
      PROGRAM KRM1101
 
***   SERVER RECEIVE
*
*     THIS OVERLAY PROCESSES THE SEND-INIT PACKET FOR THE SERVER.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CALL RDPARAM(RECPACK)
      CALL SNDPAR(Y,PACKET,PSIZE)
      CALL SNDPACK(Y,PACKNUM,PSIZE,PACKET)
      NUMTRY = 0
      PACKNUM = AND(PACKNUM+1,O"77")
      RECSTAT = RECEIVE(F)
      IF (DEBUG .NE. 0) THEN
         IF (RECSTAT .EQ. ERROR) THEN
            CALL FPRINTF(DEBUGFD,'^R^E^C^E^I^V^E ^F^A^I^L^E^D\N')
         ELSE
            CALL FPRINTF(DEBUGFD,'^R^E^C^E^I^V^E ^C^O^M^P^L^E^T^E\N')
         ENDIF
      ENDIF
      RETURN
 
      END
      OVERLAY (11,2)
      PROGRAM KRM1102
 
***   SERVER INITIALIZE
*
*     THIS OVERLAY PROCESSES THE INITIALIZE PACKET FOR THE SERVER.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL,COMCKER
 
      CALL RDPARAM(RECPACK)
      CALL SNDPAR(Y,PACKET,PSIZE)
      CALL SNDPACK(Y,PACKNUM,PSIZE,PACKET)
      RETURN
 
      END
      OVERLAY (11,3)
      PROGRAM KRM1103
 
***   SERVER SEND
*
*     THIS OVERLAY PROCESSES THE RECEIVE-INIT PACKET FOR THE SERVER.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL,COMCKER
 
      CHARACTER*10 LFN
      LOGICAL GETFILE, WILDSET
 
      CALL EXPSTR(RECPACK, PSIZE, FILESTR)
      CALL GETFTY(FILESTR, FTYPE)
      CALL AS2DPC(FILESTR,LFN)
      IF(.NOT.WILDSET(LFN)) THEN
         ABORTYP = INVFN
         CALL GETEMSG(ERRMSG(15))
         CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG)
      ELSE IF(.NOT.GETFILE(FTYPE)) THEN
         ABORTYP = NOTLCL
         CALL GETEMSG(ERRMSG(15))
         CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG)
      ELSE
         SNDSTAT = SEND(F, ' ')
         PACKNUM = 0
         IF (DEBUG .NE. 0) THEN
            IF (SNDSTAT .EQ. ERROR) THEN
               CALL FPRINTF(DEBUGFD,'^S^E^N^D ^F^A^I^L^E^D\N')
            ELSE
               CALL FPRINTF(DEBUGFD,'^S^E^N^D ^C^O^M^P^L^E^T^E\N')
            ENDIF
         ENDIF
      ENDIF
      RETURN
 
      END
      OVERLAY (11,4)
      PROGRAM KRM1104
 
***   SERVER GENERIC FUNCTIONS
*
*     THIS OVERLAY PROCESSES THE GENERIC FUNCTIONS FOR THE SERVER.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL,COMCKER
 
*CALL,COMXKER
 
*     L O G O U T
 
      IF (RECPACK(1) .EQ. L) THEN
         CALL SNDPACK(Y,PACKNUM,0,0)
         CALL LOGOUT
 
*     F I N I S H
 
      ELSE IF (RECPACK(1) .EQ. F) THEN
         CALL SNDPACK(Y,PACKNUM,0,0)
         CALL EXITPGM
 
*     D I R
 
      ELSE IF (RECPACK(1) .EQ. D) THEN
         IF(PSIZE .GE. 2) THEN
            CALL EXPSTR(RECPACK, PSIZE, FILESTR)
            L1 = UNCHAR(FILESTR(2))
            DO 20 L2 = 1, L1+1
 20         FILESTR(L2) = FILESTR(L2+2)
         ELSE
            L1 = 0
         ENDIF
         CALL RETFILE('ZZZZKDR')
         FD = FOPEN('ZZZZKDR', WR, CS612)
         CALL DIR(FD, L1)
         CALL FCLOSE(FD)
         CALL WILDSET('ZZZZKDR')
         CALL GETFILE(L)
         CALL SEND(X, 'KERMIT-170:')
         CALL RETFILE('ZZZZKDR')
         PACKNUM = 0
 
*     U N K N O W N
 
      ELSE
         ABORTYP = SRVCMD
         CALL GETEMSG(ERRMSG(15))
         CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG)
 
      ENDIF
      RETURN
 
      END
      OVERLAY (12,0)
      PROGRAM KRM1200
 
***   DIR - EXECUTE THE 'DIRECTORY' COMMAND
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL,COMCKER
 
*     GET THE REQUESTED FILE STRING AND CALL THE DIR ROUTINE
 
      LEN = GETWORD(CMDFD, FILESTR, IPKSIZE)
      CALL DIR(STDOUT, LEN)
      RETURN
 
      END
      OVERLAY (13,0)
      PROGRAM KRM1300
 
***   TAKE - EXECUTE THE 'TAKE' COMMAND
*
*     TAKE FILENAM      (TAKE COMMANDS FROM FILENAM)
*
*     WE WILL ACCEPT WILDCARDS, BUT WILL ONLY USE THE FIRST FILE.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL,COMCKER
 
      LOGICAL WILDSET, GETFILE
 
*     GET THE REQUESTED FILE AND START TAKING INPUT FROM THERE.
*     IF CMDFD = -1, THIS IS A FAKE 'TAKE KERMINI' CALL AT STARTUP
*     TIME.
*     ANY ERRORS CAUSE TAKE TO REVERT TO STDIN FOR COMMAND INPUT.
 
      IF(CMDFD .LT. 0) THEN
         CALL DPC2AS('KERMINI', FILESTR, 7)
      ELSE
         IF(CMDFD .NE. STDIN) THEN
            CALL FCLOSE(CMDFD)
            CMDFD = STDIN
         ENDIF
         CALL SETVAL(FILESTR,'S',IRET,9,0,0,HLPSNFN,.TRUE.)
         IF(IRET .EQ. ERROR) RETURN
      ENDIF
 
*     GET FILE TYPE AND MAKE SURE THE NAME IS LEGAL.
 
      CALL GETFTY(FILESTR, FTYPE)
      CALL AS2DPC(FILESTR, CMDLFN)
      IF(.NOT.WILDSET(CMDLFN)) THEN
         CALL FPRINTF(STDOUT,'?^ILLEGAL FILE NAME: "@S".\N',FILESTR,
     +                0,0,0)
         CMDFD = STDIN
         RETURN
      ENDIF
 
*     GET THE FILE AND OPEN IT. IF 'KERMINI' CALL, DON'T OUTPUT ERROR
*     MESSAGE.
 
      IF(.NOT. GETFILE(FTYPE)) THEN
         IF(CMDFD .GT. 0) THEN
            CALL FPRINTF(STDOUT,'?^FILE "@S" NOT FOUND.\N',FILESTR,
     +                   0,0,0)
         ENDIF
         CMDFD = STDIN
         RETURN
      ENDIF
      CALL AS2DPC(FILESTR, CMDLFN)
      CMDFD = FOPEN(CMDLFN, RD, CS612)
      CMDLOCF = LOCFILE
      IF(CMDLOCF) THEN
         CALL FPRINTF(STDOUT,'[^TAKING COMMANDS FROM LOCAL FILE "@S"]\N'
     +           ,FILESTR,0,0,0)
      ELSE
         CALL FPRINTF(STDOUT,'[^TAKING COMMANDS FROM PERM FILE "@S"]\N'
     +           ,FILESTR,0,0,0)
      ENDIF
      RETURN
      END
*WEOR
*DECK KERMLIB
      SUBROUTINE AS2DPC(ASTR,DSTR)
 
***   AS2DPC - TRANSLATE AN ASCII STRING BUFFER TO DPC CHAR STRING.
*
*     ASCII STRING IS TERMINATED BY A ZERO BYTE.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      BOOLEAN ASTR(*)
      CHARACTER DSTR*(*)
      INTEGER CLEN
 
 
      I = 1
      CLEN = LEN(DSTR)
      DSTR = ' '
10    IF (ASTR(I) .NE. 0 .AND. I .LE. CLEN) THEN
         IF (ASTR(I) .GT. 127) THEN
            DSTR(I:I)=' '
         ELSE
            DSTR(I:I)=CHAR(DPCTBL(ASTR(I)))
         ENDIF
         I = I + 1
         GO TO 10
      ENDIF
 
 
      RETURN
      END
      INTEGER FUNCTION ASC(DPCH)
 
***   ASC - CONVERT A DPC CHARACTER TO LOWER CASE ASCII.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER*1 DPCH
 
 
      ASC = LASCII(ICHAR(DPCH))
 
 
      RETURN
      END
      SUBROUTINE BUFEMP(BUFFER,FD,LEN)
 
***   BUFEMP - DUMP A BUFFER TO A FILE.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      BOOLEAN BUFFER(*), CH
 
*CALL COMXKER
 
 
*     WRITE THE PACKET DATA TO THE FILE
 
      I = 1
10    IF (I .LE. LEN) THEN
         CH = BUFFER(I)
 
*        REPEAT COUNTS
*
*        BY THE NATURE OF THE DATA PACKET (VISIBLE CHARACTERS ONLY),
*        CH CANNOT BE ZERO, SO IF REPEAT COUNTS ARE NOT BEING USED,
*        REPCH IS ZERO AND THE FOLLOWING TEST WILL ALWAYS BE FALSE.
*        THE TEST WILL BE TRUE IF AND ONLY IF REPEAT COUNTS ARE
*        BEING DONE AND CH=THE REPEAT COUNT PREFIX CHARACTER.
 
         IF (CH .EQ. REPCH) THEN
            REPCT = UNCHAR(BUFFER(I+1))
            I  = I+2
            CH = BUFFER(I)
         ELSE
            REPCT = 1
         ENDIF
 
*        8-BIT QUOTING
*
*        BY THE NATURE OF THE DATA PACKET (VISIBLE CHARACTERS ONLY),
*        CH CANNOT BE ZERO, SO IF 8-BIT QUOTING IS NOT BEING USED,
*        Q8CH IS ZERO AND THE FOLLOWING TEST WILL ALWAYS BE FALSE.
*        THE TEST WILL BE TRUE IF AND ONLY IF 8-BIT QUOTING IS
*        BEING DONE AND CH=THE 8-BIT QUOTE CHARACTER.
 
         IF (CH .EQ. Q8CH) THEN
            HIGHBIT = Z"80"
            I  = I+1
            CH = BUFFER(I)
         ELSE
            HIGHBIT = Z"00"
         ENDIF
 
*        CONTROL CHARACTER QUOTING
*
*        THIS CODE ALSO HANDLES THE CASE OF SPECIAL CHARACTER
*        QUOTING.  I.E. "##", "#&", AND "#<TILDE>" WILL BE CONVERTED
*        TO "#", "&", AND "<TILDE>", RESPECTIVELY.
 
         IF (CH .EQ. SCQUOTE) THEN
            I  = I+1
            CH = BUFFER(I)
            TCH = CTL(AND(CH,Z"7F"))
            IF (TCH .LT. BLANK .OR. TCH .EQ. DEL) CH = CTL(CH)
         ENDIF
 
*        SET THE HIGH BIT
 
         CH = OR(CH,HIGHBIT)
 
*        FOR TEXT FILES STRIP THE PARITY BIT AND CONVERT *CR*S TO
*        *NEL*S.  FOR BINARY FILES JUST WRITE THE CHARACTERS ASIS.
 
         DO 20 J=1,REPCT
            IF(FCSET(FD) .EQ. CSBIN) THEN
               CALL PUTC(CH,FD)
            ELSE
               CH = AND(CH,Z"7F")
               IF (CH .EQ. CR) THEN
                  CALL PUTC(NEL,FD)
               ELSE IF (CH .NE. LF) THEN
                  CALL PUTC(CH,FD)
               ENDIF
            ENDIF
 20      CONTINUE
 
         I = I+1
         GO TO 10
      ENDIF
 
 
      RETURN
      END
      INTEGER FUNCTION BUFFILL(FD,BUFFER)
 
***   BUFFILL - GET SOME DATA TO SEND.
*
*     BUFFILL READS FROM THE FILE TO SEND AND PERFORMS ALL
*     THE PROPER ESCAPING OF CONTROL CHARACTERS AND MAPPING
*     NEWLINES INTO CRLF SEQUENCES.  IT ALSO GENERATES REPEAT
*     SEQUENCES.
*
*     ENTRY    (FD) = FILE DESCRIPTOR OF FILE TO READ FROM.
*              (BUFFER) = UNPACKED ASCII TRANSMISSION BUFFER.
*
*     EXIT     BUFFER FILLED WITH DATA FROM FILE IN KERMIT
*              TRANSMISSION FORMAT.
 
**    NOTE: THIS ALGORITHM ASSUMES 5 OVERHEAD CHARACTERS FOR THE
*     PACKET AND LEAVES 4 CHARACTERS IN CASE THE LAST CHARACTER
*     TO BUFFER IS A REPEATED CONTROL CHARACTER WITH THE HIGH
*     BIT SET.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
      PARAMETER (MAXREP=94)
 
*CALL COMCKER
 
      BOOLEAN BUFFER(*)
 
*CALL COMXKER
 
 
*     FETCH THE FIRST CHARACTER
 
      IF (GETC(FD,CH1) .EQ. EOF) THEN
         BUFFER(1) = 0
         BUFFILL = EOF
         RETURN
      ENDIF
 
*     PREFETCH THE NEXT CHARACTER AND ADD THE CURRENT CHARACTER
*     TO THE BUFFER
 
      BUFPTR = 0
      REPCT = 1
 
 10   IF (CH1 .NE. EOF) THEN
         CH2 = GETC(FD,CH2)
 
*        COMPUTE BREAK-EVEN COUNT FOR REPEAT CHARACTERS
 
         IF (CH1 .LT. 32 .OR. CH1 .GT. 126) THEN
            MINREP = 2
         ELSE
            MINREP = 3
         ENDIF
 
*        ADD THE CHARACTER TO THE BUFFER
 
         IF (RRPTPFX .EQ. BLANK .OR. CH1 .EQ. NEL) THEN
            CALL BUFPACK(CH1,BUFFER,BUFPTR)
         ELSE IF (CH2 .EQ. CH1 .AND. REPCT .LT. MAXREP) THEN
            REPCT = REPCT+1
         ELSE IF (REPCT .GE. MINREP) THEN
            BUFFER(BUFPTR+1) = RRPTPFX
            BUFFER(BUFPTR+2) = TOCHAR(REPCT)
            BUFPTR = BUFPTR+2
            CALL BUFPACK(CH1,BUFFER,BUFPTR)
            REPCT = 1
         ELSE
            DO 20 I=1,REPCT
               CALL BUFPACK(CH1,BUFFER,BUFPTR)
 20         CONTINUE
            REPCT = 1
         ENDIF
         IF (BUFPTR .LT. RPKSIZE-9) THEN
            CH1 = CH2
            GOTO 10
         ELSE
            CALL UNGETC(FD,CH2)
         ENDIF
      ENDIF
 
      BUFFILL = BUFPTR
      BUFFER(BUFPTR+1) = 0
 
 
      RETURN
      END
      SUBROUTINE BUFPACK(TCH,BUFFER,BUFPTR)
 
***   BUFPACK - ADD A CHARACTER TO THE TRANSMISSION BUFFER.
*
*     THIS ROUTINE ADDS A CHARACTER TO THE OUTGOING TRANSMISSION
*     BUFFER, CONVERTING <NEL> TO <CR><LF> PAIRS, AND DOING SPECIAL
*     CHARACTER, CONTROL CHARACTER, AND EIGHT-BIT QUOTING.
*
*     ENTRY    (TCH) = CHARACTER TO BE ADDED TO BUFFER.
*              (BUFFER) = UNPACKED ASCII BUFFER.
*              (BUFPTR) = POINTER TO LAST CHARACTER IN BUFFER.
*
*     EXIT     (BUFPTR) = UPDATED POINTER.
*              CHARACTER(S) ADDED TO BUFFER.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      BOOLEAN BUFFER(*)
 
*CALL COMXKER
 
 
*     CONVERT END OF LINE CHARACTER TO <CR><LF>
 
      IF (TCH .EQ. NEL) THEN
         BUFFER(BUFPTR+1) = RCQUOTE
         BUFFER(BUFPTR+2) = CTL(CR)
         BUFPTR = BUFPTR+2
         CH  = LF
         XCH = LF
      ELSE
         CH  = TCH
         XCH = AND(TCH,Z"7F")
      ENDIF
 
*     8-TH BIT QUOTING
 
      IF (Q8CH .NE. 0) THEN
 
*        CONVERT 'A TO &A
 
         IF (CH .GT. Z"7F") THEN
            BUFPTR = BUFPTR+1
            BUFFER(BUFPTR) = Q8CH
            CH = AND(CH,Z"7F")
         ENDIF
 
*        CONVERT & TO #&
 
         IF (CH .EQ. Q8CH) THEN
            BUFPTR = BUFPTR+1
            BUFFER(BUFPTR) = RCQUOTE
         ENDIF
      ENDIF
 
*     SPECIAL CHARACTER AND CONTROL CHARACTER QUOTING
 
      IF ((XCH .EQ. RCQUOTE) .OR.
     +    (XCH .EQ. RRPTPFX .AND. RRPTPFX .NE. BLANK)) THEN
 
*        CONVERT <TILDE> TO #<TILDE>
*        CONVERT # TO ##
 
         BUFPTR = BUFPTR+1
         BUFFER(BUFPTR) = RCQUOTE
 
      ELSE IF (XCH .LT. BLANK .OR. XCH .EQ. DEL) THEN
 
*        CONVERT <CC> TO #<CC>
 
         BUFPTR = BUFPTR+1
         BUFFER(BUFPTR) = RCQUOTE
         CH = CTL(CH)
      ENDIF
 
      BUFPTR = BUFPTR+1
      BUFFER(BUFPTR) = CH
 
      RETURN
      END
          IDENT  CFE
          ENTRY  CFE
          SST
          SYSCOM B1
 CFE      TITLE  CFE - CHECK FILES EXISTANCE.
          COMMENT CHECK FILES EXISTANCE.
 CFE      SPACE  4,10
**        CFE - CHECK FILES EXISTANCE.
*
*         LOGICAL CFE, RESULT
*
*         RESULT =  CFE(LFN)
*
*         ENTRY  (LFN) = IS THE CHARACTER*7 FILE NAME.
*
*         EXIT   (RESULT) = .TRUE. IF FILE EXISTS.
*                (RESULT) = .FALSE. OTHERWISE.
 
 
 CFE      SUBR               ENTRY/EXIT
          SB1    1
          SA1    X1          (X1) = FILE NAME
          RJ     =XBTZ>      CONVERT BLANKS TO 00B
          SX1    B1          SET COMPLETE BIT
          BX6    X6+X1
          SA6    CFEA
          STATUS CFEA
          MX6    0           ASSUME NO FILE (.FALSE.)
          MX1    11
          LX1    12          (X1) = LOW BITS MASK
          SA2    CFEA
          BX2    X1*X2       (X2) = 0 IF FILE NOT FOUND
          ZR     X2,CFEX     IF NO FILE
          MX6    -1          SET FILE FOUND (.TRUE.)
          EQ     CFEX        RETURN
 
 CFEA     DATA   0           FET
 
          END
      LOGICAL FUNCTION CONFIRM(FD)
 
***   CONFIRM - LOOK FOR A NEWLINE.
*
*     CONFIRM WILL EXPECT THAT THE NEXT TOKEN OF INPUT BE A
*     NEWLINE FOR CONFIRMATION TO BE TRUE.  IF THE NEXT TOKEN
*     IS A QUESTION MARK, THEN CONFIRMATION IS FALSE AND
*     A "CONFIRM WITH A CARRIAGE RETURN" MESSAGE WILL BE DISPLAYED.
*     ANY OTHER TEXT WILL CAUSE A 'NOT CONFIRMED "TEXT"' MESSAGE
*     TO BE DISPLAYED AND CONFIRM WILL RETURN FALSE.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
 
*     GET LEADING BLANKS TIL A TOKEN IS FOUND
 
      CONFIRM = .FALSE.
 10   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
         GO TO 10
      ELSE IF (CH .EQ. QMARK) THEN
         CALL FPRINTF(STDOUT,'^CONFIRM WITH A CARRIAGE RETURN\N')
      ELSE
         CALL FPRINTF(STDOUT,'?^NOT CONFIRMED - "')
 20      CALL PUTC(CH,STDOUT)
         CH = GETC(FD,CH)
         IF (CH .NE. NEL .AND. CH .NE. EOF) GO TO 20
         CALL FPRINTF(STDOUT,'"\N')
      ENDIF
 
 
      RETURN
      END
      INTEGER FUNCTION CTOI(ASTR)
 
***   CTOI - CONVERT CHARACTER BUFFER TO INTEGER.
*
*     CTOI CONVERTS THE NUMBER USING BASE 10 AS A DEFAULT.
*     A SUFFIX OF H WILL CONVERT USING BASE 16 AND A SUFFIX
*     OF O WILL CONVERT USING BASE 8.  DEFAULT SUFFIX IS
*     D.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      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 ASTR(*)
 
 
      BASE = 0
      PTR = 0
 
*     FIND LAST VALID DIGIT
 
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
 
*     TRY TO FIGURE OUT THE BASE
 
      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
 
*     IF DIDN'T FIND A BASE
 
      IF (BASE .EQ. 0) THEN
         CALL FPRINTF(STDOUT,'CTOI - INVALID BASE @C\N',ASTR(PTR),0,0,0)
         CTOI = 0
         RETURN
      ENDIF
 
*     ADD UP THE DIGITS
 
      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 FPRINTF(STDOUT,'CTOI - INVALID DECIMAL DIGIT @C\N',
     +                      CH,0,0,0)
               CTOI = 0
               RETURN
            ELSE
               CH = CH - DIG0
            ENDIF
         ELSE IF (BASE .EQ. 8) THEN
            IF (CH .LT. DIG0 .OR. CH .GT. DIG7) THEN
               CALL FPRINTF(STDOUT,'CTOI - INVALID OCTAL DIGIT @C\N',
     +                      CH,0,0,0)
               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 FPRINTF(STDOUT,'CTOI - INVALID HEX DIGIT @C\N',
     +                      CH,0,0,0)
               CTOI = 0
               RETURN
            ENDIF
         ENDIF
         TOTAL = TOTAL*BASE + CH
100   CONTINUE
      CTOI = TOTAL * ISNEG
 
 
      RETURN
      END
      SUBROUTINE DBUGCMD
 
***   DBUGCMD - SET THE DEBUGGING MODES.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER*10 FN
      LOGICAL CONFIRM
      PARAMETER (TSIZE=5)
      CHARACTER*10 DBGTYP(TSIZE)
      DATA DBGTYP / 'ALL', 'LOG-FILE', 'OFF', 'PACKETS', 'STATES' /
 
 
      INDX = MATCH(DBGTYP,TSIZE,.FALSE.)
      IF (INDX .LE. 0) RETURN
      GO TO (10, 20, 30, 40, 50), INDX
 
*     SET ALL DEBUG MODES
 
10    IF (.NOT. CONFIRM(CMDFD)) RETURN
      DEBUG = DBGALL
      GO TO 100
 
*     SET DEBUG LOGFILE
 
20    CALL SETVAL(DEBUGFN,'S',IRET,7,0,0,HLPDBFN,.TRUE.)
      IF (IRET .EQ. OK) THEN
         IF (DEBUGFD .NE. 0) THEN
            CALL FCLOSE(DEBUGFD)
            DEBUGFD = 0
         ENDIF
         GO TO 100
      ENDIF
      RETURN
 
*     TURN OFF ALL DEBUGGING
 
30    IF (.NOT. CONFIRM(CMDFD)) RETURN
      DEBUG = DBGOFF
      IF (DEBUGFD .NE. 0) THEN
         CALL FCLOSE(DEBUGFD)
         DEBUGFD = 0
      ENDIF
      RETURN
 
*     TOGGLE DEBUG PACKETS
 
40    IF (.NOT. CONFIRM(CMDFD)) RETURN
      DEBUG = DEBUG .XOR. DBGPACK
      GO TO 100
 
*     TOGGLE DEBUG STATES
 
50    IF (.NOT. CONFIRM(CMDFD)) RETURN
      DEBUG = DEBUG .XOR. DBGSTAT
      GO TO 100
 
*     OPEN THE DEBUG FILE IF NOT DONE ALREADY
 
100   IF (DEBUGFD .EQ. 0) THEN
         FN = ' '
         CALL AS2DPC(DEBUGFN,FN)
         DEBUGFD = FOPEN(FN,WR,CS612)
      ENDIF
 
 
      RETURN
      END
      SUBROUTINE DELAY(MSEC)
 
***   DELAY - DELAY FOR A FEW MILLISECONDS.
*
*     ENTRY   MSEC = DELAY TIME IN MILLISECONDS.
*
*     EXIT    TIME HAS ELAPSED.
*
*     NOTES   WORKS FOR SCOPE, UT2D, AND NOS/BE SYSTEMS.  NOS USERS MUST
*             CHANGE THE COMPUTATION TO ACCOUNT FOR THE DIFFERENCE
*             IN DATA RETURNED BY RTIME MACRO.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
 
*    USE REAL TIME CLOCK TO CONTROL DELAY PERIOD.
 
      CALL RTIME(RTCL)
      RTCL = AND(RTCL,COMPL(MASK(24)))
10    CALL RTIME(RTCL1)
      RTCL1 = AND(RTCL1,COMPL(MASK(24)))
 
*     CONVERT FROM SECONDS/4096 TO MILLISECONDS.
 
      IF((RTCL1-RTCL).GT.MSEC) RETURN
 
*     SLEEP FOR 100 MILLISECONDS.
 
      CALL RECALL(0)
      GO TO 10
 
      END
      SUBROUTINE DIR(FD, LEN)
 
***   DIR - CREATE DIRECTORY LISTING ON SPECIFIED FILE.
*
*     ENTRY FD - OUTPUT FILE DESCRIPTOR
*           LEN - LENGTH OF STRING IN 'FILESTR' ARRAY.
*           FILESTR CONTAINS FILE REQUEST STRING: 
*              FILENAM
*              FILE*          (WILDCARD LOCAL FILES)
*              L:* OR L:      (ALL LOCAL FILES)
*              P:* OR P:      (ALL PERMANENT FILES)
*              P:FILE*        (WILDCARD PERMANENT FILES)
*     EXIT  FILE CONTAINS DIRECTORY OUTPUT.
*
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER FILENAM*10
      LOGICAL WILDSET
 
      FILESTR(LEN+1) = 0
 
*     CHECK FOR L: OR P:, REMOVE AND FLAG IF PRESENT.
*     MOVE REST OF REQUEST STRING TO RIGHT PLACE.
 
      CALL GETFTY(FILESTR, FTYPE)
      IF(SLEN(FILESTR) .EQ. 0) THEN
         FILENAM = '*'
      ELSE
         CALL AS2DPC(FILESTR, FILENAM)
      ENDIF
      LOCFILE = (FTYPE .NE. P)
 
      IF(.NOT.WILDSET(FILENAM)) THEN
         CALL FPRINTF(FD,'? ^INVALID FILE NAME STRING. \N',0,0,0,0)
         RETURN
      ENDIF
 
*     WE KNOW WHAT TO GET A DIRECTORY OF.  NOW DO IT.
 
      PACKET(1) = BLANK
 
      IF(LOCFILE) THEN
         CALL GETLFNI
         CALL FPRINTF(FD,'^DIRECTORY OF ^LOCAL FILES.\N',0,0,0,0)
      ELSE
         CALL GETPFNI
         CALL FPRINTF(FD,'^DIRECTORY OF ^PERMANENT FILES.\N',0,0,0,0)
      ENDIF
 
      I1 = 0
10    IF(LOCFILE) THEN
         CALL GETLFN(FILENAM)
      ELSE
         CALL GETPFN(FILENAM)
      ENDIF
      IF(FILENAM .NE. ' ') THEN
         CALL DPC2AS(FILENAM, PACKET(2), 9)
         CALL PUTSTR(FD, PACKET)
         I1 = I1 + 1
         IF(MOD(I1, 7) .EQ. 0) THEN
            CALL PUTC(NEL, FD)
         ENDIF
         GOTO 10
      ELSE
         IF(I1 .EQ. 0) THEN
            CALL FPRINTF(FD,'? ^NO FILES FOUND. \N',0,0,0,0)
         ELSE IF(I1 .EQ. 1) THEN
            CALL FPRINTF(FD,'\N 1 FILE FOUND.\N',0,0,0,0)
         ELSE
            CALL FPRINTF(FD,'\N @D FILES FOUND.\N',I1,0,0,0)
         ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE DMODCMD
 
***   DMODCMD - PERFORM A SET FILE-MODE XXXX COMMAND.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      LOGICAL CONFIRM
      PARAMETER (TSIZE=2)
      CHARACTER*15 DATATYP(TSIZE)
      DATA DATATYP /'BINARY','TEXT'/
 
 
*     MATCH THE PARAMETER.
 
      INDX = MATCH(DATATYP,TSIZE,.FALSE.)
      IF (INDX .LE. 0) RETURN
      IF (.NOT. CONFIRM(CMDFD)) RETURN
 
*     TAKE THE APPROPRIATE ACTION.
 
      GO TO (10,20), INDX
 
*     SET BINARY TRANSFER MODE
 
 10   FILMODE = BINARY
      RETURN
 
*     SET TEXT TRANSFER MODE
 
 20   FILMODE = TEXT
      RETURN
 
      END
      SUBROUTINE DOPRNT(FD,STRNG,PTYP,FMT,I1,I2,I3,I4)
 
***   DOPRNT - WORKHORSE FOR FORMATTED ASCII I/O.
*
*     CONVERSION IS SIMILAR TO FPRINTF USED IN C.  SUPPORTED
*     CONVERSIONS ARE @D (INTEGER), @C (ASCII CHARACTER), @S (ASCII
*     STRING BUFFER).  A \N WILL MAP TO A NEWLINE, A \T WILL
*     WILL MAP TO A TAB, A \0 WILL TERMINATE THE FORMAT SCANNING.
*     A \ FOLLOWED BY ANY OTHER CHARACTER WILL CAUSE THAT CHARACTER
*     TO BE OUTPUT.  THE DEFAULT OUTPUT CASE WILL BE LOWERCASE.
*     A ^ FOLLOWED BY A LETTER WILL CAUSE THAT CHARACTER TO BE OUTPUT
*     AS UPPERCASE.  A @D CONVERSION MAY NOW SPECIFY A MINIMUM FIELD
*     WIDTH AS @<N>D (I.E. @10D) IN WHICH THE NUMBER WILL BE BLANK
*     PADDED TO THE RIGHT TO USE UP <N> CHARACTERS.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER*(*) FMT
      BOOLEAN STR(21), STRNG(*)
      CHARACTER*1 CH
 
 
*     CHECK FOR FILE OR STRING WRITE
 
      IF (PTYP .NE. 1 .AND. PTYP .NE. 2) THEN
         CALL DISPLA(' DOPRNT - INVALID WRITE FUNCTION',PTYP)
         CALL ABORT
      ENDIF
 
*     OUTPUT THE FORMATTED STRING
 
      IPTR = 1
      OPTR = 1
      FPTR = 1
      FMTLEN = LEN(FMT)
10    IF (FPTR .LE. FMTLEN) THEN
         CH = FMT(FPTR:FPTR)
         IF (CH .NE. '\' .AND. CH .NE. '@' .AND. CH .NE. '^') THEN
            IF (PTYP .EQ. 1) THEN
               CALL PUTC(ASC(CH),FD)
            ELSE
               STRNG(OPTR) = ASC(CH)
               OPTR = OPTR + 1
            ENDIF
 
*        IS IT A QUOTE OR SPECIAL SEQUENCE CHARACTER?
 
         ELSE IF (CH .EQ. '\') THEN
            FPTR = FPTR+1
            CH = FMT(FPTR:FPTR)
            IF (CH .EQ. 'N' .AND. PTYP .EQ. 1) THEN
               CALL PUTC(NEL,FD)
            ELSE IF (CH .EQ. 'T' .AND. PTYP .EQ. 1) THEN
               CALL PUTC(TAB,FD)
            ELSE IF (CH .EQ. '0') THEN
               IF (PTYP .EQ. 2) STRNG(OPTR) = 0
               RETURN
            ELSE IF (CH .EQ. 'N') THEN
               STRNG(OPTR) = NEL
               OPTR = OPTR + 1
            ELSE IF (CH .EQ. 'T') THEN
               STRNG(OPTR) = TAB
               OPTR = OPTR + 1
            ELSE
               IF (PTYP .EQ. 1) THEN
                  CALL PUTC(ASC(CH),FD)
               ELSE
                  STRNG(OPTR) = ASC(CH)
                  OPTR = OPTR + 1
               ENDIF
            ENDIF
 
*     IS IT AN UPPERCASE MAPPING?
 
         ELSE IF (CH .EQ. '^') THEN
            FPTR = FPTR + 1
            CH = FMT(FPTR:FPTR)
            IF (CH .GE. 'A' .AND. CH .LE. 'Z') THEN
               ACH = ASC(CH)-32
            ELSE
               ACH = ASC(CH)
            ENDIF
            IF (PTYP .EQ. 1) THEN
               CALL PUTC(ACH,FD)
            ELSE
               STRNG(OPTR) = ACH
               OPTR = OPTR + 1
            ENDIF
 
*        MUST BE A CONVERSION (@)
 
         ELSE
            INTWDTH = 1
            FPTR = FPTR + 1
            CH = FMT(FPTR:FPTR)
 
*           IS IT AN INTEGER VALUE FORMAT SPEC?
 
20          IF (CH .EQ. 'D') THEN
               IF (IPTR .EQ. 1) THEN
                  ACH = I1
               ELSE IF (IPTR .EQ. 2) THEN
                  ACH = I2
               ELSE IF (IPTR .EQ. 3) THEN
                  ACH = I3
               ELSE
                  ACH = I4
               ENDIF
               IF (PTYP .EQ. 1) THEN
                  CALL PUTINT(FD,ACH,INTWDTH)
               ELSE
                  TLEN = ITOS(ACH,STRNG(OPTR),INTWDTH)
                  OPTR = OPTR + TLEN
               ENDIF
               IPTR = IPTR + 1
 
*           IS IT A CHARACTER VALUE OUTPUT SPEC?
 
            ELSE IF (CH .EQ. 'C') THEN
               IF (IPTR .EQ. 1) THEN
                  ACH = I1
               ELSE IF (IPTR .EQ. 2) THEN
                  ACH = I2
               ELSE IF (IPTR .EQ. 3) THEN
                  ACH = I3
               ELSE
                  ACH = I4
               ENDIF
               IF (PTYP .EQ. 1) THEN
                  CALL PUTC(ACH,FD)
               ELSE
                  STRNG(OPTR) = ACH
                  OPTR = OPTR + 1
               ENDIF
               IPTR = IPTR + 1
 
*           IS IT A STRING VALUE OUTPUT SPEC?
 
            ELSE IF (CH .EQ. 'S') THEN
               IF (IPTR .EQ. 1) THEN
                  IF (PTYP .EQ. 1) THEN
                     CALL PUTSTR(FD,I1)
                  ELSE
                     CALL STRCPY(I1,STRNG(OPTR))
                     OPTR = OPTR + SLEN(I1)
                  ENDIF
               ELSE IF (IPTR .EQ. 2) THEN
                  IF (PTYP .EQ. 1) THEN
                     CALL PUTSTR(FD,I2)
                  ELSE
                     CALL STRCPY(I2,STRNG(OPTR))
                     OPTR = OPTR + SLEN(I2)
                  ENDIF
               ELSE IF (IPTR .EQ. 3) THEN
                  IF (PTYP .EQ. 1) THEN
                     CALL PUTSTR(FD,I3)
                  ELSE
                     CALL STRCPY(I3,STRNG(OPTR))
                     OPTR = OPTR + SLEN(I3)
                  ENDIF
               ELSE
                  IF (PTYP .EQ. 1) THEN
                     CALL PUTSTR(FD,I4)
                  ELSE
                     CALL STRCPY(I4,STRNG(OPTR))
                     OPTR = OPTR + SLEN(I4)
                  ENDIF
               ENDIF
               IPTR = IPTR + 1
 
*           IS IT A FIELD WIDTH SPECIFIER?
 
            ELSE IF (CH .GE. '0' .AND. CH .LE. '9') THEN
               SPTR = 0
30             SPTR = SPTR + 1
               STR(SPTR) = ASC(CH)
               FPTR = FPTR + 1
               CH = FMT(FPTR:FPTR)
               IF (CH .GE. '0' .AND. CH .LE. '9') GO TO 30
               STR(SPTR+1) = 0
               INTWDTH = CTOI(STR)
               GO TO 20
 
*           UNKNOWN CONVERSION SO OUTPUT THE @ AND CONVERSION CHAR
 
            ELSE
               IF (PTYP .EQ. 1) THEN
                  CALL PUTC(ASC('@'),FD)
                  CALL PUTC(ASC(CH),FD)
               ELSE
                  STRNG(OPTR) = ASC('@')
                  STRNG(OPTR+1) = ASC(CH)
                  OPTR = OPTR + 2
               ENDIF
         ENDIF
         ENDIF
         FPTR = FPTR + 1
         GO TO 10
      ENDIF
      IF (PTYP .EQ. 2) STRNG(OPTR) = 0
 
 
      RETURN
      END
      SUBROUTINE DPC2AS(DSTR,ASTR,NWORDS)
 
***   DPC2AS - CONVERT A DPC CHARACTER STRING TO UPPERCASE ASCII.
*
*     TRANSLATE STRING OF DISPLAY CODE CHARACTERS TO UPPERCASE ASCII.
*     STRING IS NWORDS CHARACTERS (WORDS) LONG, WITH A ZERO TERMINATION
*     AT NWORDS+1.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER*(*) DSTR
      BOOLEAN ASTR(*)
 
 
      DO 1 I=1,NWORDS
         ASTR(I) = UASCII((ICHAR(DSTR(I:I))))
    1    CONTINUE
 
*     SET ASCII END-OF-STRING-BUFFER
 
      ASTR(NWORDS+1) = 0
 
 
      RETURN
      END
      SUBROUTINE DPLXCMD
 
***   DPLXCMD - PERFORM A SET DUPLEX XXXX COMMAND
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      LOGICAL CONFIRM
      PARAMETER (TSIZE=2)
      CHARACTER*10 DUPTYP(TSIZE)
      DATA DUPTYP / 'FULL', 'HALF' /
 
 
*     MATCH THE PARAMETER
 
      INDX = MATCH(DUPTYP,TSIZE,.FALSE.)
      IF (INDX .LE. 0) RETURN
      IF (.NOT. CONFIRM(CMDFD)) RETURN
 
*     TAKE THE APPROPRIATE ACTION
 
      GO TO (10, 20), INDX
 
*     SET FULL DUPLEX
 
 10   CALL STTY('DUPLEX',FULLDUP)
      INITDUP = FULLDUP
      RETURN
 
*     SET HALF DUPLEX
 
 20   CALL STTY('DUPLEX',HALFDUP)
      INITDUP = HALFDUP
      RETURN
 
 
      END
          IDENT  EXE
          ENTRY  EXE
          B1=1
          TITLE  EXE - WRITE AND BEGIN A CCL PROC.
          COMMENT EXE - WRITE AND BEGIN A CCL PROC.
 EXE      SPACE  4,10
***       EXE - WRITE AND BEGIN A CCL PROC.
*
*         ENTRY  (X1) = ADDRESS OF *C* FORMAT NOS COMMAND.
*
*         EXIT   NONE.
 
 EXE      SUBR               ENTRY
          SB1    1
          WRITEC ZZZZKCC,X1
          WRITEC ZZZZKCC,(=C*$REVERT,EX.KERMIT.*)
          WRITEC ZZZZKCC,(=C*$EXIT.*)
          WRITEC ZZZZKCC,(=C*$REVERT,EX.KERMIT.*)
          WRITER ZZZZKCC,R
          EXCST  (=C*$BEGIN,,ZZZZKCC.*)
 
*         FET AND BUFFER
 ZZZZKCC  FILEB  BUF,101B
 BUF      EQU    *
          ORG    ZZZZKCC+2
          VFD    42/0,18/CEND
          ORG    BUF
          DATA   C*.PROC,X.*
          DATA   C*$RETURN,ZZZZKCC.*
 CEND     EQU    *
          BSS    101B-CEND+BUF
 
          END
      SUBROUTINE EXPSTR(ISTR, LEN, OSTR)
 
***   EXPSTR - EXPAND STRING
*
*     EXPSTR EXPANDS AN INPUT STRING, DUPLICATING REPEAT-PREFIXED
*     CHARACTERS AND REMOVING CONTROL-QUOTE CHARACTERS AS REQUIRED.
*     THIS ROUTINE DOESN'T HANDLE 8TH BIT QUOTED CONVERSIONS.
*
*     ENTRY ISTR - INPUT STRING
*           LEN  - INPUT STRING LENGTH
*           OSTR - OUTPUT STRING (WILL BE ZERO-TERMINATED)
*
*     NOTE THAT IF THERE IS NO REPEAT PREFIXING, REPCT = 0, BUT SINCE CH
*     CAN NEVER BE ZERO, EVERYTHING SHOULD BE OK.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
      INTEGER ISTR(*), OSTR(*)
 
*CALL COMCKER
 
*CALL,COMXKER
 
      I1 = 1
      I2 = 1
 10   CH = ISTR(I1)
      IF((CH.EQ.REPCH) .AND. (CH.NE.0) .AND. (I1+2.LE.LEN)) THEN
         CH = ISTR(I1+2)
         DO 20 I3 = 1, UNCHAR(ISTR(I1+1))
         OSTR(I2) = CH
 20      I2 = I2 + 1
         I1 = I1 + 2
      ELSE IF(CH .EQ. SCQUOTE) THEN
         I1 = I1 + 1
         OSTR(I2) = ISTR(I1)
         I2 = I2 + 1
      ELSE
         OSTR(I2) = CH
         I2 = I2 + 1
      ENDIF
      I1 = I1 + 1
      IF(I1 .LE. LEN) GOTO 10
 
      OSTR(I2) = 0
      RETURN
      END
      SUBROUTINE FCLOSE(FD)
 
***   FCLOSE - REMOVE AN FD FROM THE ACTIVE LIST.
*
*     FCLOSE WILL REMOVE THE FD FROM THE ACTIVE LIST FOR
*     ALLOCATION AT A LATER DATE.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
 
      IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
         CALL DISPLA(' FCLOSE - INVALID FD ',FD)
         CALL ABORT
      ELSE IF (FMODE(FD) .EQ. 0) THEN
         CALL DISPLA(' FCLOSE - FD NOT OPEN.',FD)
         RETURN
      ENDIF
 
*     FORCE EMPTYING OF THE BUFFER
 
      CALL FFLUSH(FD)
 
*     WRITE A FILE MARK
 
      IF(FMODE(FD) .EQ. WR .AND. .NOT. CTDEV(FD)) THEN
         CALL WRITER(FETS(0,FD),1)
      ENDIF
 
      FMODE(FD) = CLOSED
 
 
      RETURN
      END
      SUBROUTINE FFLUSH(FD)
 
***   FFLUSH - FLUSH AN I/O BUFFER.
*
*     FFLUSH WILL FLUSH THE ASCII STRING BUFFER FOR A PARTICULAR
*     FILE DESCRIPTOR.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*                               #    E    O    R   \N
      PARAMETER (EORLINE = O"0043 0105 0117 0122 0000")
 
*                               #    E    O    F   \N
      PARAMETER (EOFLINE = O"0043 0105 0117 0106 0000")
 
*CALL COMCKER
 
      PARAMETER (FIRST = 1, IN = 2, OUT = 3, LIMIT = 4)
 
 
*     IS THE FD VALID?
 
      IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
         CALL DISPLA(' FFLUSH - INVALID FILE DESCRIPTOR',FD)
         CALL ABORT
      ELSE IF (FMODE(FD) .EQ. 0) THEN
         CALL DISPLA(' FFLUSH - FILE DESCRIPTOR NOT OPEN',FD)
         CALL ABORT
      ENDIF
 
*     IF FD WAS OPENED FOR WRITE FLUSH TO THE FILE
 
      IF (FMODE(FD) .EQ. WR) THEN
         IF (FCSET(FD) .EQ. CSBIN) THEN
            CALL WRITEW(FETS(0,FD),FCHBUF(1,FD),FNWDS(FD),STATUS)
         ELSE IF (CTDEV(FD)) THEN
            IF (FCSET(FD) .EQ. CSDSP .OR. FCSET(FD) .EQ. CS612) THEN
               CALL A8SX12(FCHBUF(1,FD),FNWDS(FD))
               FNWDS(FD) = FINDEOL(FCHBUF(1,FD),FNWDS(FD),.FALSE.)
            ENDIF
            CALL WRITEW(FETS(0,FD),FCHBUF(1,FD),FNWDS(FD),STATUS)
 
*           ENSURE ZERO EOL BYTE
 
            IF((FCHBUF(FNWDS(FD),FD).AND.O"7777").NE.0) THEN
               CALL WRITEW(FETS(0,FD), 0, 1, STATUS)
            ENDIF
            CALL WRITE(FETS(0,FD), 0)
         ELSE
            IF (FCHBUF(1,FD) .EQ. EORLINE) THEN
               CALL WRITER(FETS(0,FD),1)
            ELSE IF (FCHBUF(1,FD) .EQ. EOFLINE) THEN
               CALL WRITEF(FETS(0,FD),1)
            ELSE
               IF (FCSET(FD) .EQ. CSDSP) THEN
                  CALL A8DPC(FCHBUF(1,FD),FNWDS(FD))
                  FNWDS(FD) = FINDEOL(FCHBUF(1,FD),FNWDS(FD),.FALSE.)
               ELSE IF (FCSET(FD) .EQ. CS612) THEN
                  CALL A8SX12(FCHBUF(1,FD),FNWDS(FD))
                  FNWDS(FD) = FINDEOL(FCHBUF(1,FD),FNWDS(FD),.FALSE.)
               ENDIF
               CALL WRITEW(FETS(0,FD),FCHBUF(1,FD),FNWDS(FD),STATUS)
            ENDIF
         ENDIF
 
*     IF FD WAS OPENED FOR READ CLEAR THE BUFFERS
 
      ELSE
         CALL RECALL(FETS(0,FD))
         FETS(IN,FD) = FETS(OUT,FD) = AND(FETS(FIRST,FD),O"777777")
         FUNGTCH(FD) = EOF
 
      ENDIF
 
*     RESET THE BUFFER POINTERS
 
      FWPTR(FD) = 1
      FNWDS(FD) = 0
      FWSHFT(FD) = 0
 
 
      RETURN
      END
      SUBROUTINE FILCHK(FN)
 
***   FILCHK - CHECK AND FIX FILENAME VALIDITY.
*
*     CHECK VALIDITY OF FILENAME.  INVALID CHARACTERS ARE DROPPED.
*     IF A PERIOD IS FOUND (FILENAME.EXT), KEEP PART OF THE FILENAME
*     AND PART OF THE EXTENSION (NORMALLY 4 AND 3 CHARACTERS,
*     RESPECTIVELY).  USE UP TO 7 CHARACTERS OF THE INPUT NAME.
*     IF THERE IS NO VALID FILENAME (NO CHARACTERS WERE ALPHANUMERIC),
*     THEN RETURN THE NAME 'KERMDAT'.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER CH*1
      CHARACTER FN*(*)
 
      LENGTH = LEN(FN)
      L1 = 0
      EXTP = 0
 
*     REMOVE INVALID CHARACTERS, DETERMINE LENGTH OF STRING
*     AND START OF EXTENSION.
 
      DO 10 I1 = 1, LENGTH
      CH = FN(I1:I1)
      IF((CH.GE.'A'.AND.CH.LE.'Z') .OR. (CH.GE.'0'.AND.CH.LE.'9')) THEN
         L1 = L1 + 1
         FN(L1:L1) = CH
      ELSE IF((CH.EQ.'.') .AND. (EXTP.EQ.0)) THEN
         EXTP = L1 + 1
      ENDIF
10    CONTINUE
 
*     IF STRING CONTAINS ALL ILLEGAL CHARACTERS, USE DEFAULT FILE NAME.
*     IF EMPTY EXTENSION OR NO EXTENSION, TRUNCATE STRING AT 7.
*     IF STRING > 7 CHARACTERS, TRUNCATE EXTENSION TO 3 CHARACTERS
*        (UNLESS THE FILENAME PART IS SHORT) AND THE ENTIRE STRING
*        TO 7, MOVE THE EXTENSION DOWN.
 
      IF(L1 .EQ. 0) THEN
         FN = 'KERMDAT'
         L1 = 7
      ELSE IF((EXTP.EQ.0) .OR. (EXTP.GT.L1)) THEN
         L1 = MIN0(L1, 7)
      ELSE
*        (IF FILENAME > 4 CHARACTERS, RETAIN UP TO 3 CHARACTERS OF THE
*         EXTENSION; ELSE, KEEP AS MANY AS POSSIBLE.)
         MAXEL = MAX0(3,7-(EXTP-1))
         L1 = MIN0(L1, EXTP+MAXEL-1)
         IF(L1 .GT. 7) THEN
            REMOVE = L1 - 7
            DO 20 I1 = EXTP, L1
            CH = FN(I1:I1)
            FN(I1-REMOVE:I1-REMOVE) = CH
20          CONTINUE
            L1 = 7
         ENDIF
      ENDIF
      DO 30 I1 = L1+1, LENGTH
      FN(I1:I1) = ' '
30    CONTINUE
      RETURN
      END
          IDENT  FILECS
          ENTRY  FILECS
          B1=1
          TITLE   FILECS - RETURN THE CHARACTER SET OF A CIO BUFFER
          COMMENT RETURN THE CHARACTER SET OF A CIO BUFFER
 FILECS   SPACE  4,10
***       INTEGER FUNCTION FILECS(FET)
*
*         RETURN THE CHARACTER SET OF A CIO BUFFER.
*
*         ENTRY  (X1) = FWA OF FET OF FILE TO BE CHECKED.  THE CIRCULAR
*                       BUFFER SHOULD HAVE BEEN FILLED BY A PREVIOUS
*                       READ FUNCTION.
*
*         EXIT   (X6) = -1 IF THE BUFFER IS EMPTY.
*                     =  1 FOR DISPLAY CODE.
*                     =  2 FOR 8/12 ASCII.
*                     =  3 FOR 6/12 ASCII.
*
*         USES   X - 0, 1, 2, 3, 4, 5, 6.
*                A - 1, 2, 3, 4, 5.
*                B - 1, 2, 3, 4, 5, 6.
*
*
*         PAUL WELLS  82/11/12
 
 
 FILECS   SUBR               ENTRY/EXIT
          SB1    1
 
          SA1    X1+B1       (X1) = FET+1
          SB2    X1          (B2) = *FIRST*
          SA1    A1+B1
          SB3    X1          (B3) = *IN*
          SA1    A1+B1
          SB4    X1          (B4) = *OUT*
          SA1    A1+B1
          SB5    X1          (B5) = *LIMIT*
 
          MX0    0           CLEAR ASCII HIGH BITS ACCUMULATOR
          SX6    -B1         PRESET EMPTY BUFFER STATUS
          EQ     B3,B4,FILECSX  IF BUFFER EMPTY
 
          SA2    GCSA        (X2) = 8/12 MASK
          SA3    A2+B1       (X3) = CARETS
          SA4    A3+B1       (X4) = 6/12 MASK
          SX6    B1+         PRESET DISPLAY CODE STATUS
 
 GCS1     SA1    B4+         (X1) = WORD FROM BUFFER
          BX5    X2*X1       (X5) = HIGH BITS OF EACH BYTE
          BX0    X0+X5       ACCUMULATE HIGH BITS
 
          SB6    8           (B6) = 6/12 SHIFT COUNTER
 GCS2     BX5    X4*X1       (X5) = FIRST AND THIRD CHARACTERS
          BX5    X5-X3
          NZ     X5,GCS3     IF NOT TWO CARETS
          SX6    3           SET 6/12 STATUS
 GCS3     LX1    6           LOOK AT NEXT CHARACTER POSITION
          SB6    B6-B1       DECREMENT SHIFT COUNT
          NZ     B6,GCS2     LOOP ON THIS WORD
 
          SB4    B4+B1       ADVANCE BUFFER POINTER
          NE     B4,B5,GCS4  IF NO WRAP AROUND
          SB4    B2          WRAP
 GCS4     NE     B4,B3,GCS1  IF NOT END OF DATA
 
 
*         HERE WHEN THE TEST LOOP IS COMPLETE
          NZ     X0,FILECSX  RETURN IF NOT 8/12
          SX6    2           RETURN 8/12 STATUS
          EQ     FILECSX     RETURN
 
 
*         MASKS
 GCSA     DATA   74007400740074007400B
          DATA   76007600000000000000B
          DATA   77007700000000000000B
 
          END
      INTEGER FUNCTION FINDEOL(WSA,WSAL,ADDNEL)
 
***   FINDEOL - FIND EOL BYTE IN WORKING BUFFER.
*
*     ENTRY   (WSA)    = LINE IMAGE.
*             (WSAL)   = LENGTH OF WSA.
*             (ADDNEL) = .TRUE. IF A NEL SHOULD BE APPENDED TO BUFFER.
*
*     EXIT    (FINDEOL) = LENGTH OF DATA LINE IN WORDS.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      BOOLEAN WSA(WSAL)
      LOGICAL ADDNEL
 
 
*     IF THE LINE LENGTH IS ZERO, RETURN ZERO LENGTH
 
      IF(WSAL .LE. 0) THEN
          FINDEOL = 0
          RETURN
      ENDIF
 
*     FIND ZERO BYTE EOL AND REPLACE WITH NEL IF REQUESTED
 
      DO 20 I = 1, WSAL
         IF (AND(WSA(I),O"7777") .EQ. 0) THEN
            IF (ADDNEL) THEN
               WSA(I) = OR(WSA(I),NEL)
            ENDIF
            FINDEOL = I
            RETURN
         ENDIF
 20   CONTINUE
 
*     NO EOL FOUND - REPLACE LAST BYTE WITH NEL
 
      IF(ADDNEL) WSA(WSAL) = OR(AND(WSA(WSAL),MASK(48)),NEL)
      FINDEOL = WSAL
 
 
      RETURN
      END
      INTEGER FUNCTION FOPEN(FN,MODE,CSET)
 
***   FOPEN - OPEN A FILE FOR I/O.
*
*     FOPEN ASSIGNS A FILE DESCIPTOR (INTEGER INDEX) TO A FILE NAME.
*
*     ENTRY    (FN)   = FILE NAME.
*              (MODE) = FILE MODE.
*                     = *RD* FOR READ MODE.
*                     = *WR* FOR WRITE MODE.
*                     = *CREATE* FOR NEW FILE / WRITE MODE.
*              (CSET) = CHARACTER SET OF THE FILE.
*                     = *CSNONE* FOR NONE SPECIFIED (CHECK IT).
*                     = *CSDSP* FOR DISPLAY CODE.
*                     = *CS812* FOR 8/12 ASCII.
*                     = *CS612* FOR 6/12 ASCII.
*                     = *CSBIN* FOR BINARY (60 BIT).
*                     = *CSTXP* FOR INTERACTIVE TRANSPARENT.
*
*     EXIT     (FOPEN) = FILE DESCRIPTOR OR ERROR CODE.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER*10 FN
      LOGICAL CFE
 
 
*     CHECK FOR VALID PARAMETERS
 
      IF (MODE .LT. RD .OR. MODE .GT. CREATE) THEN
         CALL DISPLA(' FOPEN - INVALID MODE ',MODE)
         CALL ABORT
      ENDIF
 
*     FIND THE NEXT UNUSED ENTRY
 
      DO 100 I = 1, MAXFILE
 
*        SET THE FILE NAME, DEVICE TYPE, AND MODE
 
         IF (FMODE(I) .EQ. CLOSED) THEN
            IF (FN .EQ. 'STDIN') THEN
               FNAME(I) = 'INPUT'
               CTDEV(I) = .TRUE.
            ELSE IF (FN .EQ. 'STDOUT') THEN
               FNAME(I) = 'OUTPUT'
               CTDEV(I) = .TRUE.
            ELSE
               FNAME(I) = FN
               CTDEV(I) = .FALSE.
            ENDIF
            IF (MODE .EQ. CREATE) THEN
               IF (.NOT.CTDEV(I) .AND. CFE(FNAME(I))) THEN
                  FMODE(I) = CLOSED
                  FOPEN = ERROR
                  RETURN
               ENDIF
               FMODE(I) = WR
            ELSE
               FMODE(I) = MODE
            ENDIF
 
*           INITIALIZE THE FILE
 
            CALL MAKEFET(FNAME(I),FETS(0,I),FETL,CIOBUFF(1,I),CIOBUFL)
            FCSET(I) = CSET
            IF (.NOT.CTDEV(I)) THEN
               CALL NODROP(FETS(0,I))
               CALL REWIND(FETS(0,I),1)
               IF (FMODE(I) .EQ. RD) THEN
                  CALL READ(FETS(0,I),1)
                  IF (CSET .EQ. CSNONE) THEN
                     FCSET(I) = MAX(FILECS(FETS(0,I)),CSDSP)
                  ENDIF
               ELSE
                  IF (CSET .EQ. CSNONE) THEN
                     FCSET(I) = CS612
                  ENDIF
               ENDIF
            ENDIF
 
*           INITIALIZE THE BUFFER POINTERS
 
            FWPTR(I) = 1
            FNWDS(I) = 0
            FWSHFT(I) = 0
            FEOF(I) = .FALSE.
 
            FOPEN = I
            RETURN
 
*        IF TABLE ENTRY FILE NAME MATCHES FN
 
         ELSE IF (FNAME(I) .EQ. FN) THEN
            CALL REMARK(' FOPEN - FILE ' // FN // ' ALREADY OPEN.')
            CALL ABORT
 
         ENDIF
100   CONTINUE
 
*     NO UNUSED ENTRY FOUND
 
      CALL REMARK(' FOPEN - TOO MANY FILES OPEN.')
      CALL ABORT
 
      END
      SUBROUTINE FPRINTF(FD,FMT,I1,I2,I3,I4)
 
***   FPRINTF - POOR ATTEMPT AT FORMATTED ASCII OUTPUT.
*
*     CONVERSION IS SIMILAR TO FPRINTF USED IN C.  SUPPORTED
*     CONVERSIONS ARE @D (INTEGER), @C (ASCII CHARACTER), @S (ASCII
*     STRING BUFFER).  A \N WILL MAP TO A NEWLINE, A \T WILL
*     WILL MAP TO A TAB, A \0 WILL TERMINATE THE FORMAT SCANNING.
*     A \ FOLLOWED BY ANY OTHER CHARACTER WILL CAUSE THAT CHARACTER
*     TO BE OUTPUT.  THE DEFAULT OUTPUT CASE WILL BE LOWERCASE.
*     A ^ FOLLOWED BY A LETTER WILL CAUSE THAT CHARACTER TO BE OUTPUT
*     AS UPPERCASE.  A @D CONVERSION MAY NOW SPECIFY A MINIMUM FIELD
*     WIDTH AS @<N>D (I.E. @10D) IN WHICH THE NUMBER WILL BE BLANK
*     PADDED TO THE RIGHT TO USE UP <N> CHARACTERS.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER*(*) FMT
 
 
*     IS THE FD VALID?
 
      IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
         CALL DISPLA(' FPRINTF - INVALID FD ',FD)
         CALL ABORT
      ELSE IF (FMODE(FD) .EQ. CLOSED) THEN
         CALL DISPLA(' FPRINTF - FD NOT OPEN.',FD)
         RETURN
      ENDIF
 
*     IS IT OK TO WRITE ON THIS STREAM?
 
      IF ((FMODE(FD).AND.WR) .NE. WR) THEN
         CALL DISPLA(' FPRINTF - WRITE ON READ-ONLY FILE ',FD)
         CALL ABORT
      ENDIF
 
*     NOW CALL THE REAL FPRINTF WORKHORSE
 
      CALL DOPRNT(FD,0,1,FMT,I1,I2,I3,I4)
 
 
      RETURN
      END
      SUBROUTINE FREAD(FD,BUF,NWD)
 
***   FREAD - READ SOME WORDS FROM A FILE.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      BOOLEAN BUF(NWD)
 
 
*     IS THE FD VALID?
 
      IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
         CALL DISPLA(' FREAD - INVALID FILE DESCRIPTOR',FD)
         CALL ABORT
      ELSE IF (FMODE(FD) .EQ. CLOSED) THEN
         CALL DISPLA(' FREAD - FILE DESCRIPTOR NOT OPEN',FD)
         CALL ABORT
      ENDIF
 
*     CHECK IF OK TO READ
 
      IF ((FMODE(FD).AND.RD) .NE. RD) THEN
         CALL DISPLA(' FREAD - READ ON WRITE-ONLY FILE ',FD)
         CALL ABORT
      ENDIF
 
*     TRANSFER WORDS FROM THE FILE
 
      CALL READW(FETS(0,FD),BUF,NWD,STATUS)
 
 
      RETURN
      END
      SUBROUTINE FWRITE(FD,BUF,NWD)
 
***   FWRITE - WRITE SOME WORDS TO A FILE.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      BOOLEAN BUF(NWD)
 
 
*     IS THE FD VALID?
 
      IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
         CALL DISPLA(' FWRITE - INVALID FD ',FD)
         CALL ABORT
      ELSE IF (FMODE(FD) .EQ. CLOSED) THEN
         CALL DISPLA(' FWRITE - FD NOT OPEN.',FD)
         RETURN
      ENDIF
 
*     IS IT OK TO WRITE ON THIS STREAM?
 
      IF ((FMODE(FD).AND.WR) .NE. WR) THEN
         CALL DISPLA(' FWRITE - WRITE ON READ-ONLY FILE ',FD)
         CALL ABORT
      ENDIF
 
*     WRITE THE WORDS TO THE FILE
 
      CALL WRITEW(FETS(0,FD),BUF,NWD,STATUS)
 
 
      RETURN
      END
      INTEGER FUNCTION GETC(FD,CH)
 
***   GETC - RETURN NEXT CHARACTER FROM THE INPUT STREAM.
*
*     GETC WILL RETURN THE NEXT BYTE READ FROM THE FILE DESCRIPTOR FD.
*     EOF (-1) IS RETURNED WHEN EOF IS READ ON A DISK FILE.  CONNECTED
*     FILES NEVER RETURN EOF.
*
*     ZERO BYTES IN NON-BINARY FILES ARE IGNORED.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
 
*     IS THE FD VALID?
 
      IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
         CALL DISPLA(' GETC - INVALID FILE DESCRIPTOR',FD)
         CALL ABORT
      ELSE IF (FMODE(FD) .EQ. CLOSED) THEN
         CALL DISPLA(' GETC - FILE DESCRIPTOR NOT OPEN',FD)
         CALL ABORT
      ENDIF
 
*     CHECK IF OK TO READ
 
      IF ((FMODE(FD).AND.RD) .NE. RD) THEN
         CALL DISPLA(' GETC - READ ON WRITE-ONLY FILE ',FD)
         CALL ABORT
      ENDIF
 
*     CHECK FOR A PUSHED-BACK CHARACTER
 
      IF (FUNGTCH(FD) .NE. EOF) THEN
         GETC = CH = FUNGTCH(FD)
         FUNGTCH(FD) = EOF
         RETURN
      ENDIF
 
*     GET MORE DATA IF NEEDED
 
 10   IF (FWPTR(FD) .GT. FNWDS(FD)) THEN
         IF (FEOF(FD)) THEN
            GETC = CH = EOF
            RETURN
         ELSE
            FNWDS(FD) = GETREC(FD,FCHBUF(1,FD),MAXWD,FEOF(FD))
            FWPTR(FD) = 1
            IF (FCSET(FD) .EQ. CSBIN) THEN
               FWSHFT(FD) = 8
            ELSE IF (FCSET(FD) .EQ. CSTXP) THEN
               FWSHFT(FD) = 24
            ELSE
               FWSHFT(FD) = 12
            ENDIF
            GOTO 10
         ENDIF
      ENDIF
 
*     BREAK OUT THE NEXT BYTE FROM THE BUFFER
 
      IF (FCSET(FD) .EQ. CSBIN) THEN
         IF (FWSHFT(FD) .EQ. 64) THEN
            CH = OR( AND(SHIFT(FCHBUF(FWPTR(FD)+0,FD),4),Z"F0"),
     -               AND(SHIFT(FCHBUF(FWPTR(FD)+1,FD),4),Z"0F") )
            FWSHFT(FD) = 4+8
            FWPTR(FD) = FWPTR(FD)+1
         ELSE IF (FWSHFT(FD) .EQ. 60) THEN
            CH = AND(FCHBUF(FWPTR(FD),FD),Z"FF")
            FWSHFT(FD) = 8
            FWPTR(FD) = FWPTR(FD)+1
         ELSE
            CH = AND(SHIFT(FCHBUF(FWPTR(FD),FD),FWSHFT(FD)),Z"FF")
            FWSHFT(FD) = FWSHFT(FD)+8
         ENDIF
      ELSE
         IF (FWSHFT(FD) .EQ. 60) THEN
            CH = AND(FCHBUF(FWPTR(FD),FD),Z"FFF")
            FWSHFT(FD) = 12
            FWPTR(FD) = FWPTR(FD)+1
         ELSE
            CH = AND(SHIFT(FCHBUF(FWPTR(FD),FD),FWSHFT(FD)),Z"FFF")
            FWSHFT(FD) = FWSHFT(FD)+12
         ENDIF
         IF (CH .EQ. 0) THEN
            GOTO 10
         ELSE IF (CH .NE. NEL) THEN
            CH = AND(CH,Z"FF")
         ENDIF
      ENDIF
 
      GETC = CH
 
 
      RETURN
      END
      SUBROUTINE GETEMSG(STRNG)
 
***   GETEMSG - GET AN ERROR MESSAGE STRING FOR THE CURRENT ERROR.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      INTEGER DIREC(8,2)
      INTEGER PACKNAM(9,0:6)
 
      DATA DIREC / 115, 101, 110, 100, 4*0,
*                    S    E    N    D
     +             114, 101,  99, 101, 105, 118, 101, 0 /
*                    R    E    C    E    I    V    E
 
      DATA PACKNAM / 85,  78,  75,  78,  79,  87,  78, 2*0,
*                     U    N    K    N    O    W    N
     +               73, 110, 105, 116, 5*0,
*                     I    N    I    T
     +               70, 105, 108, 101, 110,  97, 109, 101, 0,
*                     F    I    L    E    N    A    M    E
     +               68,  97, 116,  97, 5*0,
*                     D    A    T    A
     +               69,  79,  70, 6*0,
*                     E    O    F
     +               66, 114, 101,  97, 107, 4*0,
*                     B    R    E    A    K
     +               83, 101, 114, 118, 101, 114, 3*0 /
*                     S    E    R    V    E    R
 
 
      IF ((ABORTYP.AND.INITERR) .NE. 0) THEN
         PTYP = 1
      ELSE IF ((ABORTYP.AND.FILERR) .NE. 0) THEN
         PTYP = 2
      ELSE IF ((ABORTYP.AND.DATAERR) .NE. 0) THEN
         PTYP = 3
      ELSE IF ((ABORTYP.AND.EOFERR) .NE. 0) THEN
         PTYP = 4
      ELSE IF ((ABORTYP.AND.BRKERR) .NE. 0) THEN
         PTYP = 5
      ELSE IF ((ABORTYP.AND.SRVCMD) .NE. 0) THEN
         PTYP = 6
      ELSE
         PTYP = 0
      ENDIF
      DTYP = SHIFT(ABORTYP.AND.O"300",-6)
      IF ((ABORTYP.AND.TOOMANY) .NE. 0) THEN
         CALL SPRINTF(STRNG,'^CANNOT @S @S PACKET',DIREC(1,
     +      DTYP),PACKNAM(1,PTYP))
      ELSE IF ((ABORTYP.AND.INVALID) .NE. 0) THEN
         CALL SPRINTF(STRNG,
     +  '^RECEIVED AN INVALID PACKET WHILE TRYING TO @S @S PACKET',
     +  DIREC(1,DTYP),PACKNAM(1,PTYP))
      ELSE IF ((ABORTYP.AND.SEQERR) .NE. 0) THEN
         CALL SPRINTF(STRNG,
     +   '^PACKET SEQUENCE ERROR WHILE TRYING TO @S @S PACKET',
     +   DIREC(1,DTYP),PACKNAM(1,PTYP))
      ELSE IF ((ABORTYP.AND.LCLFILE) .NE. 0) THEN
         CALL SPRINTF(STRNG,'^FILE ALREADY EXISTS',0,0)
      ELSE IF ((ABORTYP.AND.NOTLCL) .NE. 0) THEN
         CALL SPRINTF(STRNG,'^FILE NOT FOUND',0,0)
      ELSE IF ((ABORTYP.AND.INVFN) .NE. 0) THEN
         CALL SPRINTF(STRNG,'^INVALID FILENAME',0,0)
      ELSE IF ((ABORTYP.AND.SRVCMD) .NE. 0) THEN
         CALL SPRINTF(STRNG,'^UNIMPLEMENTED SERVER COMMAND',0,0)
      ELSE IF ((ABORTYP.AND.INTRPT) .NE. 0) THEN
         CALL SPRINTF(STRNG, '^TRANSFER INTERRUPTED DURING @S.',
     +   DIREC(1, DTYP), 0, 0)
      ELSE IF ((ABORTYP.AND.MICERR) .NE. 0) THEN
         CALL STRCPY(MICMSG, STRNG)
      ENDIF
 
 
      RETURN
      END
      LOGICAL FUNCTION GETFILE(FTYPE)
 
***   GETFILE - CHECK IF THE REQUESTED FILE (OR WILDCARD FILES)
*     EXIST SOMEWHERE IN THE SYSTEM.  IF FTYPE = B, CHECK FIRST FOR A
*     MATCH IN THE USER'S LOCAL FILES.  IF NOT FOUND, TRY THE USER'S PERM FILE
*     CATALOG.  IF FTYPE = L OR P, CHECK ONLY THE SPECIFIED LOCATION.
*
*     ENTRY    FTYPE = B TO ALLOW LOCAL OR PERMANENT FILE(S)
*                      L TO ALLOW LOCAL ONLY
*                      P TO ALLOW PERMANENT ONLY
*              WILDSET HAS BEEN CALLED W/ FILE NAME STRING.
*
*     EXIT     (GETFILE) = .TRUE. IF FILE HAS BEEN FOUND SOMEWHERE.
*              (FILESTR) HAS FIRST FILE NAME STRING.
*              (LOCFILE) = .TRUE. IF TRANSFER IS FROM LOCAL FILES,
*                          .FALSE. IF TRANSFER IF FROM PERM FILES.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
 
 
      CHARACTER LFN*10
 
*     CHECK TO SEE IF WE CAN FIND A MATCHING FILE.  LOOK IN LOCAL FILE
*     LIST AND/OR THE PERMANENT FILE CATALOG.
 
      IF((FTYPE.EQ.L) .OR. (FTYPE.EQ.B)) THEN
         CALL GETLFNI
         CALL GETLFN(LFN)
         LOCFILE = (LFN .NE. ' ')
      ENDIF
      IF((FTYPE.EQ.P) .OR. ((FTYPE.EQ.B).AND..NOT.LOCFILE)) THEN
         CALL GETPFNI
         CALL GETPFN(LFN)
         LOCFILE = .FALSE.
      ENDIF
 
      IF(LFN.EQ.' ') THEN
         GETFILE = .FALSE.
         RETURN
      ELSE
         GETFILE = .TRUE.
         IF(.NOT.LOCFILE) THEN
            CALL GETPFIL(LFN)
         ENDIF
      ENDIF
 
*     MOVE ACTUAL FILE NAME OF FIRST FILE TO STRING
 
      CALL DPC2AS(LFN, FILESTR, INDEX(LFN,' ')-1)
      RETURN
      END
      SUBROUTINE GETFTY(STR, FTYPE)
 
***   GETFTY - GET AND REMOVE FILE TYPE SPECIFIER FROM STRING.
*
*     CHECKS THE STRING, AND IF THERE IS A FILE TYPE SPECIFIER, REMOVE
*     IT FROM THE STRING AND RETURN THE VALUE OF THE SPECIFIER.  VALID
*     SPECIFIERS ARE: 
*        L: FOR LOCAL FILES ONLY
*        P: FOR PERMANENT FILES ONLY
*        B: FOR LOCAL OR PERMANENT FILES.
*     ANY OTHER FILE TYPE OR NONE IS RETURNED AS B
*
*     ENTRY STR   ASCII STRING ARRAY
*     EXIT  FTYPE L, P, OR B.
*
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      DIMENSION STR(*)
 
      IF(STR(2) .EQ. COLON) THEN
         IF((STR(1).AND.O"137") .EQ. L) THEN
            FTYPE = L
         ELSE IF((STR(1).AND.O"137") .EQ. P) THEN
            FTYPE = P
         ELSE
            FTYPE = B
         ENDIF
         CALL STRCPY(STR(3), STR(1))
      ELSE
         FTYPE = B
      ENDIF
      RETURN
 
      END
      LOGICAL FUNCTION GETPFIL(LFN)
 
***   GETPFIL - GET/ATTACH A PERMANENT FILE.
*
*     ENTRY    (LFN) = FILE NAME.
*
*     EXIT     (GETFILE) = .TRUE. IF FILE IS NOW LOCAL.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER*(*) LFN
      CALL PF('GET',LFN,LFN,'RC',REPLY,'NA',' ')
      IF (REPLY .NE. 0) CALL PF('ATTACH',LFN,LFN,'RC',REPLY,'NA',' ')
 
      GETPFIL = (REPLY .EQ. 0)
 
      RETURN
      END
      SUBROUTINE GETLFN(NAME)
 
***   GETLFN - GET THE NAME OF NEXT LOCAL FILE IN THE JOB WHICH
*     MATCHES THE WILDCARD CRITERIA.
*
*     BE SURE TO CALL 'GETLFNI' AND 'WILDSET' FIRST!
*
*     CALL GETLFN(NAME)
*
*     ENTRY    GETLFNI AND WILDSET SHOULD HAVE BEEN CALLED
*     EXIT     NAME*7 CONTAINS THE NEXT LOCAL FILE, OR ' ' IF NO MORE
*              MATCHING FILES.
*
 
      CHARACTER NAME*(*)
      LOGICAL WILDMAT
 
10    I = NEXTLF(1)
      IF(I .EQ. 0) THEN
         NAME = ' '
         RETURN
      ENDIF
      CALL MOVETOC(I, NAME)
      IF(.NOT.WILDMAT(NAME)) GOTO 10
      RETURN
 
      ENTRY GETLFNI
 
***   GETLFNI - INITIALIZE FOR SEQUENCE OF 'GETLFN' CALLS.
*
*     HAS 'NEXTLF' RESET FOR BEGINNING OF LOCAL FILE LIST.
*
      I = NEXTLF(0)
      RETURN
      END
      SUBROUTINE GETNOW(MM,DD,YY,HR,MIN,SEC)
 
***   GET THE CURRENT DATE AND TIME.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER*10 DATE, TIME, STRING
 
 
      STRING = DATE()
      OFFSET = ICHAR('0')
      YY = (ICHAR(STRING(2:2))-OFFSET)*10 + ICHAR(STRING(3:3))-OFFSET
      MM = (ICHAR(STRING(5:5))-OFFSET)*10 + ICHAR(STRING(6:6))-OFFSET
      DD = (ICHAR(STRING(8:8))-OFFSET)*10 + ICHAR(STRING(9:9))-OFFSET
      YY = YY + 1900
      STRING = TIME()
      HR  = (ICHAR(STRING(2:2))-OFFSET)*10 + ICHAR(STRING(3:3))-OFFSET
      MIN = (ICHAR(STRING(5:5))-OFFSET)*10 + ICHAR(STRING(6:6))-OFFSET
      SEC = (ICHAR(STRING(8:8))-OFFSET)*10 + ICHAR(STRING(9:9))-OFFSET
 
 
      RETURN
      END
      SUBROUTINE GETPFN(NAME)
 
***   GETPFN - GET THE NAME OF NEXT PERM FILE IN THE CATALOG WHICH
*     MATCHES THE WILDCARD CRITERIA.
*
*     BE SURE TO CALL 'GETPFNI' AND 'WILDSET' FIRST!
*
*     CALL GETPFN(NAME)
*
*     ENTRY    GETPFNI AND WILDMAT SHOULD HAVE BEEN CALLED
*     EXIT     NAME*7 CONTAINS THE NEXT PERM FILE, OR ' ' IF NO MORE
*              MATCHING FILES.
*
 
      CHARACTER NAME*(*)
      LOGICAL WILDMAT
 
10    I = NEXTPF(1)
      IF(I .EQ. 0) THEN
         NAME = ' '
         RETURN
      ENDIF
      CALL MOVETOC(I, NAME)
      IF(.NOT.WILDMAT(NAME)) GOTO 10
      RETURN
 
      ENTRY GETPFNI
 
***   GETPFNI - INITIALIZE FOR SEQUENCE OF 'GETPFN' CALLS.
*
*     HAS 'NEXTPF' RESET FOR BEGINNING OF CATALOG.
*
      I = NEXTPF(0)
      RETURN
      END
      INTEGER FUNCTION GETREC(FD,WSA,WSAL,EOFFLAG)
 
***   GETREC - READ A LINE FROM A FILE.
*
*     ENTRY   (FD) = FILE DESCRIPTOR.
*             (WSAL) = LENGTH OF WSA.
*
*     EXIT    (WSA) = DATA FROM FILE.
*             (GETREC) = NUMBER OF WORDS ACTUALLY PLACED IN WSA.
*             (EOFFLAG) = .TRUE. IF END OF FILE HIT.
*
*     NOTES: PERFORMS DISPLAY TO ASCII CONVERSION IF NEEDED.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*                               #    E    O    R   \N
      PARAMETER (EORLINE = O"0043 0105 0117 0122 3777")
 
*                               #    E    O    F   \N
      PARAMETER (EOFLINE = O"0043 0105 0117 0106 3777")
 
*CALL COMCKER
 
      BOOLEAN WSA(WSAL)
      BOOLEAN SWSA(MAXWD), STATUS
      LOGICAL EOFFLAG
 
 
      EOFFLAG = .FALSE.
      IF(CTDEV(FD)) THEN
 
*        PROCESS CONNECTED FILES.
 
         IF (RDELAY .GT. 0) CALL DELAY(RDELAY)
         CALL READ(FETS(0,FD),1)
         IF (FCSET(FD) .EQ. CSTXP) THEN
            CALL READC(FETS(0,FD),WSA,WSAL,STATUS)
            GETREC = FINDEOL(WSA,WSAL,.TRUE.)
         ELSE
            CALL READC(FETS(0,FD),SWSA,WSAL,STATUS)
            IF(STATUS .GE. 0) THEN
               CALL SX12A8(SWSA,WSA,WSAL,STATUS)
               GETREC = FINDEOL(WSA,WSAL,.TRUE.)
            ELSE
               WSA(1) = NEL
               GETREC = 1
            ENDIF
         ENDIF
 
      ELSE
 
*        PROCESS DISK FILES.
 
         IF(FCSET(FD) .EQ. CSBIN) THEN
            CALL READW(FETS(0,FD),WSA,WSAL,STATUS)
         ELSE IF (FCSET(FD) .EQ. CS812) THEN
            CALL READC(FETS(0,FD),WSA,WSAL,STATUS)
         ELSE
            CALL READC(FETS(0,FD),SWSA,MAXWD,STATUS)
            IF(STATUS .GE. 0) THEN
               IF(FCSET(FD) .EQ. CSDSP) THEN
                  CALL DPCA8(SWSA,WSA,WSAL,STATUS)
               ELSE
                  CALL SX12A8(SWSA,WSA,WSAL,STATUS)
               ENDIF
            ENDIF
         ENDIF
 
         IF (FCSET(FD) .EQ. CSBIN) THEN
            IF (STATUS .EQ. 0) THEN
               NWDS = WSAL
            ELSE IF (STATUS .GT. 0) THEN
               NWDS = STATUS-LOCF(WSA)
               CALL READ(FETS(0,FD),1)
            ELSE IF (STATUS .EQ. -1) THEN
               NWDS = 0
               CALL READ(FETS(0,FD),1)
            ELSE
               NWDS = 0
               EOFFLAG = .TRUE.
            ENDIF
         ELSE
            IF (STATUS .EQ. 0) THEN
               NWDS = FINDEOL(WSA,WSAL,.TRUE.)
            ELSE IF (STATUS .GT. 0) THEN
               NWDS = STATUS-LOCF(WSA)
               IF (NWDS .GT. 0) THEN
                  NWDS = FINDEOL(WSA,NWDS,.TRUE.)
               ENDIF
               CALL READ(FETS(0,FD),1)
               IF (AND(FETS(0,FD),O"7770") .EQ. O"0030") THEN
                  NWDS = NWDS+1
                  WSA(NWDS) = EOFLINE
                  CALL READ(FETS(0,FD),1)
               ELSE IF (AND(FETS(0,FD),O"7770") .EQ. O"1030") THEN
                  EOFFLAG = .TRUE.
               ELSE
                  NWDS = NWDS+1
                  WSA(NWDS) = EORLINE
               ENDIF
            ELSE IF (STATUS .EQ. -1) THEN
               CALL READ(FETS(0,FD),1)
               NWDS = 1
               WSA(NWDS) = EOFLINE
            ELSE
               NWDS = 0
               EOFFLAG = .TRUE.
            ENDIF
         ENDIF
         GETREC = NWDS
 
      ENDIF
 
 
      RETURN
      END
      INTEGER FUNCTION GETWORD(FD,STR,MAXLEN)
 
***   GETWORD - GET A WORD FROM AN INPUT STREAM.
*
*     GETWORD CONSIDERS A WORD TO BE DELIMITED BY BLANKS.
*     IT WILL RETURN THE LENGTH OF THE WORD AS ITS VALUE.
*     NOTE THAT THE STRING IS TERMINATED BY A ZERO WORD AT LEN+1.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      INTEGER STR(*)
 
 
      LEN = 0
 
*     SKIP LEADING WHITE SPACES
 
10    IF (GETC(FD,CH) .EQ. EOF) THEN
         GETWORD = EOF
         RETURN
      ELSE IF (CH .EQ. NEL) THEN
         GETWORD = 0
         RETURN
      ELSE IF (CH .EQ. BLANK .OR. CH .EQ. TAB) THEN
         GO TO 10
      ENDIF
 
*     ACCUMULATE CHARACTERS
 
20    IF (LEN .LT. MAXLEN) THEN
         LEN = LEN + 1
         STR(LEN) = CH
      ENDIF
      CH = GETC(FD,CH)
      IF (CH .NE. EOF .AND. CH .NE. BLANK .AND. CH .NE. TAB .AND.
     +    CH .NE. NEL) GO TO 20
 
*     SAVE EOLS FOR NEXT GETWORD OR CONFIRM
 
      IF (CH .EQ. NEL) CALL UNGETC(FD,CH)
 
      STR(LEN+1) = 0
      GETWORD = LEN
 
 
      RETURN
      END
      INTEGER FUNCTION GTTY(MODE)
 
***   GTTY - GET A TTY MODE.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER*(*) MODE
 
 
      IF (MODE .EQ. 'DUPLEX') THEN
         GTTY = DUPLEX
      ELSE
         CALL DISPLA(' GTTY - INVALID MODE ',BOOL(MODE))
         CALL ABORT
      ENDIF
 
 
      RETURN
      END
      INTEGER FUNCTION ITOS(INT,STR,MINWID)
 
***   ITOS - CONVERT AN INTEGER TO STRING FORMAT.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      INTEGER STR(*)
 
 
      WIDTH = 0
      IF (INT .LT. 0) THEN
         WIDTH = 1
         STR(WIDTH) = ASC('-')
      ENDIF
      VAL = IABS(INT)
      ASCII0 = ASC('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
 
*     NOW REVERSE THE DIGITS
 
      IPTR = 1
      ENDPTR = WIDTH
      IF (STR(IPTR) .EQ. ASC('-')) 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
      SUBROUTINE LOGOUT
 
***   LOGOUT - LOG OUT THE TERMINAL.
*
*     ENTRY    NONE.
*
*     EXIT     CONTROL BYTE SENT.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
 
      IF (INITDUP .EQ. FULLDUP) THEN
         CALL STTY('RCV-OFF',FULLDUP)
      ELSE
         CALL STTY('RCV-OFF',HALFDUP)
      ENDIF
      FCHBUF(1,STDOUT) = O"0004 0000 0000 0000 0000"
      FNWDS(STDOUT) = 1
      CALL FFLUSH(STDOUT)
 
 
      RETURN
      END
          IDENT  MAKEFET
          ENTRY  MAKEFET
          SST
          SYSCOM B1
 MAKEFET  TITLE  MAKEFET - MAKE A FILE ENVIRONMENT TABLE.
          COMMENT MAKE A FILE ENVIRONMENT TABLE.
 MAKEFET  SPACE  4,10
**        MAKEFET - MAKE A FILE ENVIRONMENT TABLE.
*
*         CALL MAKEFET(LFN,FET,FETL,CIOBUF,CIOBUFL)
*
*         ENTRY  (LFN) = IS THE CHARACTER*7 FILE NAME.
*                (FET) = AN ARRAY TO RECEIVE THE FET.
*                (FETL) = LENGTH OF FET IN WORDS (MINIMUM OF 5).
*                (CIOBUF) = AN ARRAY TO BE USED AS THE CIO BUFFER.
*                (CIOBUFL) = THE LENGTH OF CIOBUF.
*
*         EXIT   FET BUILT.
 
 
 MAKEFET  SUBR               ENTRY/EXIT
          SB1    1
          SA2    A1+B1
          SB6    X2          (B6) = FET ADDRESS
          SA2    A2+B1
          SA3    X2          (X3) = FET LENGTH
          SA2    A2+B1
          SX6    X2          (X6) = FWA OF CIO BUFFER
          SA2    A2+B1
          SA2    X2          (X2) = BUFFER LENGTH
          IX7    X6+X2       (X7) = LIMIT POINTER
          SA6    B6+2        SET IN AND OUT
          SA6    A6+B1
          SA7    A6+B1       SET LIMIT
          SX7    X3-5        (X7) = FET LENGTH - 5
          SB7    X7
          LX7    18
          BX6    X6+X7       ADD (FET LENGTH - 5) TO FIRST
          SA6    B6+B1       SET FIRST
          MX7    0
 MAKEFET1 GT     B7,B0,MAKEFET2  IF NO MORE WORDS TO SET
          SA7    A7+B1
          SB7    B7-B1
          EQ     MAKEFET1    LOOP TILL DONE
 
 MAKEFET2 SB7    B1          LENGTH OF TRANSFER
          RJ     =XMFS>      MOVE LFN INTO FET
          SA1    B6-B1
          RJ     =XBTZ>      CONVERT BLANKS TO 00B
          SX1    B1          ADD COMPLETE BIT TO LFN
          BX6    X6+X1
          SA6    A1
          EQ     MAKEFETX    RETURN
 
          END
      INTEGER FUNCTION MATCH(TABLE,TABLEN,NELOK)
 
***   MATCH - MATCH INPUT WITH A TABLE OF POSSIBILITIES.
*
*     TABLE SHOULD BE AN ARRAY OF CHARACTER STRINGS DEFINING WHAT
*     IS REASONABLE INPUT.  MATCH WILL READ INPUT AND RETURN THE
*     INDEX OF THE TABLE ENTRY THAT MATCHES OR "ERROR" IF A PROPER
*     MATCH COULDN'T BE MADE.  MATCHS WILL FAIL IF THE INPUT MATCH
*     IS AMBIGUOUS OR DOESN'T MATCH AT ALL.  A QUESTION MARK IN THE
*     INPUT WILL OUTPUT THE POSSIBLE MATCHES ACCORDING TO THE INPUT
*     PREVIOUSLY READ AND THEN RETURN AS IF NO MATCH WAS MADE.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER*(*) TABLE(TABLEN)
      LOGICAL NELOK
      CHARACTER*40 WORD
      INTEGER ASTR(41)
 
 
*     GET THE WORD TO MATCH
 
      LEN = GETWORD(CMDFD,ASTR,40)
      IF (LEN .EQ. 0) THEN
         MATCH = LEN
         IF (.NOT. NELOK) THEN
            MATCH = ERROR
            CALL FPRINTF(STDOUT,'?^NULL SWITCH OR KEYWORD GIVEN\N')
         ENDIF
         RETURN
      ELSE IF (LEN .EQ. EOF) THEN
         MATCH = EOF
         RETURN
      ENDIF
      CALL AS2DPC(ASTR,WORD)
      IF(WORD(1:3) .EQ. '#EO') THEN
         MATCH = EOF
         RETURN
      ENDIF
 
*     BEGIN THE MATCHING HERE; TABLES MUST BE IN ALPHABETICAL ORDER
 
      T1 = 1
      T2 = TABLEN
      CHP = 1
10    IF (CHP .LE. LEN) THEN
 
*        IF WE FIND A "?", THEN GIVE THE POSSIBILITIES
 
         IF (WORD(CHP:CHP) .EQ. '?') THEN
            CALL FPRINTF(STDOUT,'^ONE OF THE FOLLOWING:\N')
            CALL OUTTBL(TABLE,T1,T2)
            MATCH = ERROR
            RETURN
         ENDIF
 
*        WHILE WORD IS LESS THAN LOWER TABLE ENTRY
 
20       IF (T1 .LE. T2) THEN
            IF (WORD(CHP:CHP) .GT. TABLE(T1)(CHP:CHP)) THEN
               T1 = T1+1
               GOTO 20
            ENDIF
         ENDIF
 
*        WHILE WORD IS GREATER THAN UPPER TABLE ENTRY
 
30       IF (T2 .GE. T1) THEN
            IF (WORD(CHP:CHP) .LT. TABLE(T2)(CHP:CHP)) THEN
               T2 = T2-1
               GOTO 30
            ENDIF
         ENDIF
 
*        IF WE KNOW WE HAVE A MISMATCH
 
         IF (T2 .LT. T1) THEN
            CALL FPRINTF(STDOUT,'?^DOES NOT MATCH KEYWORD - "')
            CALL PUTSTR(STDOUT,ASTR)
            CALL FPRINTF(STDOUT,'"\N')
            MATCH = ERROR
            RETURN
         ENDIF
 
         CHP = CHP+1
         GOTO 10
      ENDIF
 
*     AFTER LOOKING AT THE WHOLE WORD, IS IT STILL AMBIGUOUS?
 
      IF (T1 .NE. T2) THEN
         CALL FPRINTF(STDOUT,'?^AMBIGUOUS - "')
         CALL PUTSTR(STDOUT,ASTR)
         CALL FPRINTF(STDOUT,'"\N')
         MATCH = ERROR
 
      ELSE
         MATCH = T1
 
      ENDIF
 
 
      RETURN
      END
      SUBROUTINE MOVETOC(I, J)
*
*     SUBROUTINE MOVETOC - MOVE BOOLEAN WORD TO CHARACTER VARIABLE.
*     THIS ROUTINE MUST BE USED ONLY FOR A *10 WORD-ALIGNED CHARACTER
*     VARIABLE; ELSE, ALL HADES MAY BREAK LOOSE.
*
      J = I
      RETURN
      END
          IDENT  NEXTFN
 
***       NEXTFN - RETURN THE NEXT FILE NAME
*
*         THIS ROUTINE CONSISTS OF 2 SUBROUTINES, ONE TO RETURN LOCAL
*         FILE NAMES AND ONE FOR PERMANENT FILE NAMES.
*
 NXTBUFL  =      400B        BUFFER LENGTH
 NXTBUF   BSS    NXTBUFL     SHARED BUFFER
 NEXTPF   SPACE  4,8
***       NEXTPF - RETURN THE NEXT PERM FILE NAME
*
*         INTEGER FUNCTION NEXTPF RETURNS THE NEXT PERM FILE NAME FROM
*         THE USER'S CATALOG.
*
*         PFN = NEXTPF(IFLAG)
*
*         ENTRY  IFLAG = 0 TO RESET POINTERS, DON'T RETURN PF.
*                      .NE. 0 TO RETURN NEXT PF.
*         EXIT   PFN = NEXT PERM FILE NAME (L FORMAT), OR 0 IF NO
*                      MORE PERM FILES.  UNDEFINED IF IFLAG=0.
*
 PFET     FILEB  NXTBUF,NXTBUFL,FET=10
 NWCE     =      16          NUMBER OF WORDS IN CATALOG ENTRY
 PWSA     BSS    NWCE
 
          ENTRY  NEXTPF
 
 NEXTPF   EQ     *+40000B
          SB1    1
          SA2    X1          X2 = IFLAG
          NZ,X2  PFN1        CONTINUATION CALL
 
          MX6    0
          SA6    PFET+6      CLEAR CONTINUATION DATA
          SX6    NXTBUF      RESET BUFFER POINTERS
          SA6    PFET+2      IN
          SA6    A6+B1       OUT
          CATLIST  PFET      START CATLIST
          EQ     NEXTPF
 
 PFN1     READW  PFET,PWSA,NWCE    READ CATALOG ENTRY
          NG,X1  PFN2        BUFFER EMPTY
          SA1    PWSA
          MX0    42
          BX1    X0*X1       RETURN PFN
          RJ     =XZTB=      CONVERT 00 TO BLANKS
          EQ     NEXTPF
 
 PFN2     SX1    X1+B1
          NG,X1  PFN3        EOI - COMPLETE
          SX6    NXTBUF      RESET BUFFER POINTERS
          SA6    PFET+2      IN
          SA6    A6+B1       OUT
          CATLIST  PFET      FILL UP BUFFER AGAIN
          EQ     PFN1        CONTINUE
 
 PFN3     MX6    0           RETURN COMPLETE
          EQ     NEXTPF
 NEXTLF   SPACE  4,8
***       NEXTLF - RETURN THE NEXT LOCAL FILE NAME
*
*         INTEGER FUNCTION NEXTLF RETURNS THE NEXT LOCAL FILE NAME FROM
*         THE USER'S JOB.
*
*         LFN = NEXTLF(IFLAG)
*
*         ENTRY  IFLAG = 0 TO RESET POINTERS, DON'T RETURN LF.
*                      .NE. 0 TO RETURN NEXT LF.
*         EXIT   LFN = NEXT LOCAL FILE NAME (L FORMAT), OR 0 IF NO
*                      MORE LOCAL FILES.  UNDEFINED IF IFLAG=0.
*
 LFET     FILEB  NXTBUF,NXTBUFL,FET=13
 NLFE     =      2           NUMBER OF WORDS IN FILE ENTRY
 LFPW     VFD    12/NXTBUFL/2-2,24/0,6/10B,18/NXTBUF
 LPTR     BSS    1
 
          ENTRY  NEXTLF
 
 NEXTLF   EQ     *+40000B
          SB1    1
          SA2    X1          X2 = IFLAG
          NZ,X2  LFN1        CONTINUATION CALL
 
          MX6    0
          SA6    NXTBUF      CLEAR CONTINUATION ADDRESS
          SX6    NXTBUF+1    FIRST ENTRY POINTER
          SA6    LPTR        POINTER TO NEXT ENTRY
          SA1    LFPW        POINTER WORD FOR GETFNT
          BX6    X1
          SA6    LFET+10B
          GETFNT LFET        GET FIRST BUFFER LOAD
          EQ     NEXTLF
 
 LFN1     SA1    LPTR        POINTER TO NEXT ENTRY
          SX6    X1+NLFE     INCREMENT POINTER
          SA6    A1
          SA1    X1          ENTRY WORD
          ZR,X1  LFN2        BUFFER EMPTY
          MX0    2           CHECK FILE RESIDENCE
          LX0    14-59
          BX2    X0*X1
          NZ,X2  LFN1        NOT MASS STORAGE.  GET NEXT FILE.
          MX0    42
          BX1    X0*X1       RETURN LFN
          RJ     =XZTB=      CONVERT 00 TO BLANKS
          EQ     NEXTLF
 
 LFN2     SA1    NXTBUF      IF TABLE HEADER NON-ZERO, MORE TO DO.
          ZR,X1  LFN3        COMPLETE
          SX6    NXTBUF+1    FIRST ENTRY POINTER
          SA6    LPTR        POINTER TO NEXT ENTRY
          GETFNT LFET        FILL UP BUFFER AGAIN
          EQ     LFN1        CONTINUE
 
 LFN3     MX6    0           RETURN COMPLETE
          EQ     NEXTLF
          END
      SUBROUTINE OUTTBL(TABLE,START,FIN)
 
***   OUTTBL - OUTPUT A STRING ARRAY IN TABULAR FORMAT.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER*(*) TABLE(FIN)
      INTEGER START, FIN
      CHARACTER*80 LINE
      INTEGER ASTR(81)
      INTEGER COLWID, NCOLS
 
 
      COLWID = LEN(TABLE(1)) + 2
      NCOLS = 80 / COLWID
      LINE = ' '
      ICOL = 1
      DO 100 I = START,FIN
         IPOS = (ICOL-1)*COLWID + 1
         LINE(IPOS:) = TABLE(I)
         ICOL = ICOL + 1
         IF (ICOL .GT. NCOLS .OR. I .EQ. FIN) THEN
            CALL DPC2AS(LINE,ASTR,LEN(LINE))
 
*           DELETE TRAILING BLANKS
 
            J = LEN(LINE)
10          IF (LINE(J:J) .EQ. ' ') THEN
               ASTR(J) = 0
               J = J - 1
               GO TO 10
            ENDIF
            CALL PUTSTR(STDOUT,ASTR)
            CALL PUTC(NEL,STDOUT)
            LINE = ' '
            ICOL = 1
         ENDIF
100   CONTINUE
 
 
      RETURN
      END
      SUBROUTINE PUTC(TCH,FD)
 
***   PUTC - PUT A CHARACTER INTO AN OUTPUT STREAM
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
 
*     IS THE FD VALID?
 
      IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
         CALL DISPLA(' PUTC - INVALID FILE DESCRIPTOR',FD)
         CALL ABORT
      ELSE IF (FMODE(FD) .EQ. CLOSED) THEN
         CALL DISPLA(' PUTC - FILE DESCRIPTOR NOT OPEN',FD)
         CALL ABORT
      ENDIF
 
*     IS IT OK TO WRITE ON THIS STREAM?
 
      IF ((FMODE(FD).AND.WR) .NE. WR) THEN
         CALL DISPLA(' PUTC - WRITE ON READ-ONLY FILE ',FD)
         CALL ABORT
      ENDIF
 
*     TRANSLATE EOLS AND NULLS AND SET THE HIGH BIT FOR CONNECTED FILES
 
      CH = TCH
10    IF (FCSET(FD) .EQ. CSTXP) THEN
         IF (CH .EQ. NEL) THEN
            CH = CR+O"4000"
         ELSE
            CH = XOR(CH,O"4000")
         ENDIF
      ELSE IF (FCSET(FD) .NE. CSBIN) THEN
         IF (CH .EQ. NEL) THEN
            CH = 0
         ELSE IF (CH .EQ. 0) THEN
            CH = NULL
         ELSE
            CH = AND(CH,Z"7F")
         ENDIF
      ENDIF
 
*     PACK THE CHARACTER INTO THE OUTPUT BUFFER - FLUSH IF FULL
 
      IF (FCSET(FD) .EQ. CSBIN) THEN
         IF (FWSHFT(FD) .EQ. 0) THEN
            IF (FNWDS(FD) .EQ. MAXWD) CALL FFLUSH(FD)
            FWSHFT(FD) = 52
            FNWDS(FD) = FNWDS(FD)+1
            FCHBUF(FNWDS(FD),FD) = SHIFT(CH,52)
         ELSE IF (FWSHFT(FD) .EQ. 4) THEN
            FWSHFT(FD) = 56
            FCHBUF(FNWDS(FD),FD) = OR(FCHBUF(FNWDS(FD),FD),SHIFT(CH,-4))
            FNWDS(FD) = FNWDS(FD)+1
            FCHBUF(FNWDS(FD),FD) = SHIFT(AND(CH,Z"0F"),56)
         ELSE
            FWSHFT(FD) = FWSHFT(FD)-8
            FCHBUF(FNWDS(FD),FD) = OR(FCHBUF(FNWDS(FD),FD),
     -                                SHIFT(CH,FWSHFT(FD)) )
         ENDIF
 
      ELSE IF (FCSET(FD) .EQ. CSTXP) THEN
         IF (FWSHFT(FD) .EQ. 0) THEN
            IF (FNWDS(FD) .EQ. MAXWD) CALL FFLUSH(FD)
            FNWDS(FD) = FNWDS(FD)+1
            IF (FNWDS(FD) .EQ. 1) THEN
               IF (FCSET(STDIN) .EQ. CSTXP) THEN
                  FCHBUF(FNWDS(FD),FD) = O"0016 4064 4001 0000 0000"
                  FNWDS(FD) = FNWDS(FD)+1
               ENDIF
               FWSHFT(FD) = 36
               FCHBUF(FNWDS(FD),FD) = O"0007 0000 0000 0000 0000"
            ELSE
               FWSHFT(FD) = 48
               FCHBUF(FNWDS(FD),FD) = O"0000 0000 0000 0000 0000"
            ENDIF
         ELSE
            FWSHFT(FD) = FWSHFT(FD)-12
         ENDIF
         FCHBUF(FNWDS(FD),FD) = OR(FCHBUF(FNWDS(FD),FD),
     -                             SHIFT(CH,FWSHFT(FD)) )
 
      ELSE
         IF (FWSHFT(FD) .EQ. 0) THEN
            IF (FNWDS(FD) .EQ. MAXWD) CALL FFLUSH(FD)
            FNWDS(FD) = FNWDS(FD)+1
            FCHBUF(FNWDS(FD),FD) = O"0000 0000 0000 0000 0000"
            FWSHFT(FD) = 48
         ELSE
            FWSHFT(FD) = FWSHFT(FD)-12
         ENDIF
         FCHBUF(FNWDS(FD),FD) = OR(FCHBUF(FNWDS(FD),FD),
     -                             SHIFT(CH,FWSHFT(FD)) )
 
      ENDIF
 
*     FOR CONNECTED FILES ADD A LF AFTER A CR
*     FOR ALL FILES FLUSH THE BUFFER ON A NEL
 
      IF (TCH .EQ. NEL) THEN
         IF (CH .EQ. CR+O"4000") THEN
            CH = LF
            GO TO 10
         ENDIF
         CALL FFLUSH(FD)
      ENDIF
 
 
      RETURN
      END
      SUBROUTINE PUTDAY(FD,MM,DD,YY)
 
***   OUTPUT DAY OF WEEK.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
 
      IZLR(IYR,M,IDY)=MOD((13*(M+10-(M+10)/13*12)-1)/5+IDY+77
     1 +5*(IYR+(M-14)/12-(IYR+(M-14)/12)/100*100)/4
     2 +(IYR+(M-14)/12)/400-(IYR+(M-14)/12)/100*2,7)+1
 
      WKDAY = IZLR(YY,MM,DD)
      IF (WKDAY .EQ. 1) THEN
         CALL FPRINTF(FD,'^SUNDAY')
      ELSE IF (WKDAY .EQ. 2) THEN
         CALL FPRINTF(FD,'^MONDAY')
      ELSE IF (WKDAY .EQ. 3) THEN
         CALL FPRINTF(FD,'^TUESDAY')
      ELSE IF (WKDAY .EQ. 4) THEN
         CALL FPRINTF(FD,'^WEDNESDAY')
      ELSE IF (WKDAY .EQ. 5) THEN
         CALL FPRINTF(FD,'^THURSDAY')
      ELSE IF (WKDAY .EQ. 6) THEN
         CALL FPRINTF(FD,'^FRIDAY')
      ELSE
         CALL FPRINTF(FD,'^SATURDAY')
      ENDIF
 
 
      RETURN
      END
      SUBROUTINE PUTINT(FD,INT,MINWID)
 
***   PUTINT - OUTPUT AN INTEGER.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      INTEGER STRING(21)
 
 
      WIDTH = 0
      IF (INT .LT. 0) THEN
         CALL PUTC(ASC('-'),FD)
         WIDTH = 1
      ENDIF
      VAL = IABS(INT)
      ASCII0 = ASC('0')
      NCH = 0
10    NCH = NCH + 1
      STRING(NCH) = MOD(VAL,10) + ASCII0
      VAL = VAL / 10
      IF (VAL .NE. 0 .AND. NCH .LT. 20) GO TO 10
      WIDTH = WIDTH + NCH
 
*     NOW OUTPUT THE DIGITS
 
20    CALL PUTC(STRING(NCH),FD)
      NCH = NCH - 1
      IF (NCH .GT. 0) GO TO 20
30    IF (WIDTH .LT. MINWID) THEN
         CALL PUTC(BLANK,FD)
         WIDTH = WIDTH + 1
         GO TO 30
      ENDIF
 
 
      RETURN
      END
      SUBROUTINE PUTMNTH(FD,MM)
 
***   PUTMNTH - OUTPUT THE MONTH NAME.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
 
      IF (MM .EQ. 1) THEN
         CALL FPRINTF(FD,'^JANUARY',0)
      ELSE IF (MM .EQ. 2) THEN
         CALL FPRINTF(FD,'^FEBRUARY',0)
      ELSE IF (MM .EQ. 3) THEN
         CALL FPRINTF(FD,'^MARCH',0)
      ELSE IF (MM .EQ. 4) THEN
         CALL FPRINTF(FD,'^APRIL',0)
      ELSE IF (MM .EQ. 5) THEN
         CALL FPRINTF(FD,'^MAY',0)
      ELSE IF (MM .EQ. 6) THEN
         CALL FPRINTF(FD,'^JUNE',0)
      ELSE IF (MM .EQ. 7) THEN
         CALL FPRINTF(FD,'^JULY',0)
      ELSE IF (MM .EQ. 8) THEN
         CALL FPRINTF(FD,'^AUGUST',0)
      ELSE IF (MM .EQ. 9) THEN
         CALL FPRINTF(FD,'^SEPTEMBER',0)
      ELSE IF (MM .EQ. 10) THEN
         CALL FPRINTF(FD,'^OCTOBER',0)
      ELSE IF (MM .EQ. 11) THEN
         CALL FPRINTF(FD,'^NOVEMBER',0)
      ELSE IF (MM .EQ. 12) THEN
         CALL FPRINTF(FD,'^DECEMBER',0)
      ELSE
         CALL FPRINTF(FD,'PUTMNTH - NO SUCH MONTH AS @D\N',MM)
      ENDIF
 
 
      RETURN
      END
      SUBROUTINE PUTSTR(FD,STR)
 
***   PUTSTR - OUTPUT A STRING TO AN OUTPUT STREAM.
*
*     PUTSTR WILL ADD CHARACTERS FROM THE NULL TERMINATED CHARACTER
*     BUFFER STR TO THE SPECIFIED OUTPUT STREAM.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      INTEGER STR(*)
 
 
*     IS THE FD VALID?
 
      IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
         CALL DISPLA(' PUTC - INVALID FD ',FD)
         CALL ABORT
      ELSE IF (FMODE(FD) .EQ. 0) THEN
         CALL DISPLA(' PUTC - FD NOT OPEN.',FD)
         RETURN
      ENDIF
 
*     IS IT OK TO WRITE ON THIS STREAM?
 
      IF ((FMODE(FD).AND.WR) .NE. WR) THEN
         CALL DISPLA(' PUTC - WRITE ON READ-ONLY FILE ',FD)
         CALL ABORT
      ENDIF
 
*     PUT CHARS IN THE OUTPUT BUFFER
 
      I = 1
10    IF (STR(I) .NE. 0) THEN
         CALL PUTC(STR(I),FD)
         I = I+1
         GOTO 10
      ENDIF
 
 
      RETURN
      END
      INTEGER FUNCTION RDATA()
 
***   RDATA - READ A DATA PACKET.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
 
*     CHECK RETRY COUNT
 
      IF (NUMTRY .GT. MAXRTRY) THEN
         RDATA = A
         ABORTYP = TOOMANY.OR.READING.OR.DATAERR
         RETURN
      ENDIF
      NUMTRY = NUMTRY + 1
 
*     READ A PACKET
 
      PTYP = RDPACK(LEN,NUM,PACKET)
 
*     D A T A
 
      IF (PTYP .EQ. D) THEN
         IF (NUM .NE. PACKNUM) THEN
            IF (MOD(NUM+1,64) .EQ. PACKNUM) THEN
               CALL SNDPACK(Y,NUM,0,0)
               RDATA = STATE
            ELSE
               RDATA = A
               ABORTYP = SEQERR.OR.READING.OR.DATAERR
            ENDIF
         ELSE
            CALL BUFEMP(PACKET,FFD,LEN)
            CALL SNDPACK(Y,PACKNUM,0,0)
            NUMTRY = 0
            PACKNUM = MOD(PACKNUM+1,64)
            RDATA = STATE
         ENDIF
 
*     F I L E N A M E
 
      ELSE IF (PTYP .EQ. F) THEN
         IF (MOD(NUM+1,64) .EQ. PACKNUM) THEN
            CALL SNDPACK(Y,NUM,0,0)
            NUMTRY = 0
            RDATA = STATE
         ELSE
            RDATA = A
            ABORTYP = SEQERR.OR.READING.OR.FILERR
         ENDIF
 
*     E O F
 
      ELSE IF (PTYP .EQ. Z) THEN
         IF (NUM .NE. PACKNUM) THEN
            RDATA = A
            ABORTYP = SEQERR.OR.READING.OR.EOFERR
         ELSE
            CALL SNDPACK(Y,PACKNUM,0,0)
            CALL FCLOSE(FFD)
            FFD = 0
            IF(LEN.GT.0 .AND. PACKET(1).EQ.D) THEN
 
*              INTERRUPTED FILE TRANSFER, UNLOAD INCOMPLETE FILE.
 
               CALL REMOVE(FILESTR)
               ABORTYP = INTRPT .OR. READING
            ENDIF
            PACKNUM = MOD(PACKNUM+1,64)
            RDATA = F
         ENDIF
 
*     E R R O R
 
      ELSE IF (PTYP .EQ. E) THEN
         RDATA = E
         CALL EXPSTR(PACKET, LEN, MICMSG(16))
         ABORTYP = READING .OR. MICERR
         RETURN
 
*     B A D   C H E C K S U M
 
      ELSE IF (PTYP .EQ. ERROR) THEN
         RDATA = STATE
         CALL SNDPACK(N,PACKNUM,0,0)
 
*     B A D   T Y P E
 
      ELSE
         RDATA = A
         ABORTYP = INVALID.OR.READING.OR.DATAERR
 
      ENDIF
 
 
      RETURN
      END
      INTEGER FUNCTION RDPACK(LEN,NUM,DATA)
 
***   RDPACK - READ A PACKET OF INFORMATION.
*
*     RDPACK WILL READ A PACKET OF DATA AND RETURN THE PACKET TYPE
*     AS A RESULT.  IF THE PACKET CONTAINS AN ERROR (CHECKSUM) THEN
*     ERROR WILL BE RETURNED.  LEN, NUM, AND DATA WILL BE SET ACCORDING
*     TO THE FIELDS OF THE PACKET.
*
*     IT MAY WELL BE THAT CHARACTERS ARE LOST IN TRANSMISSION, MAKING
*     A PACKET SHORTER THAN EXPECTED.  THIS SHOULD CAUSE A REQUEST FOR
*     RETRANSMISSION (NAK).  RDPACK LOOKS FOR AN NEL RETURNED BY
*     GETC TO TELL IT WHERE THE END OF THE DATA IS.
*
*     IF THE USER ENTERS A CTRL/C OR CTRL/T AS THE FIRST CHARACTER OF
*     A LINE, RETURN AN ABORT.  THIS ALLOWS THE PROTOCOL TO BE ABORTED
*     IF NECESSARY.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      INTEGER DATA(*)
      LOGICAL TYPE0
      LOGICAL WAITINP
 
*CALL COMXKER
 
 
*     LOG INCOMING PACKETS
 
      IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
         CALL FPRINTF(DEBUGFD,'^R^E^A^D^I^N^G:\N',0)
      ENDIF
      NCH = 0
 
*     HUNT FOR THE START OF THE PACKET
 
10    CONTINUE
 
*     WAIT 'STIMOUT' SECONDS TO RECEIVE PACKET IF 'WAITPAK' IS TRUE.
 
      IF(WAITPAK .AND. .NOT.WAITINP(STIMOUT)) THEN
         RDPACK = ERROR
         CALL FFLUSH(STDIN)
         RETURN
      ENDIF
      CH = GETC(STDIN, CH)
      IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
         CALL PUTC(CH,DEBUGFD)
      ENDIF
      IF(CH .NE. SSYNC) THEN
         IF(CH .EQ. NEL) THEN
            IF (DEBUG .NE. 0) THEN
               CALL FPRINTF(DEBUGFD,'\N<^N^U^L^L ^P^A^C^K^E^T>\N',0)
            ENDIF
            CALL FFLUSH(STDIN)
            RDPACK = ERROR
            RETURN
         ELSE IF(CH.EQ.DC4 .OR. CH.EQ.ETX) THEN
            CALL FFLUSH(STDIN)
            RDPACK = A
            RETURN
         ENDIF
         NCH = NCH+1
         GOTO 10
      ENDIF
 
      CHKSUM = LEN = 0
 
*     PARSE EACH FIELD OF THE PACKET
*     FIELD IS PACKET FIELD, 'LEN' TO 'CHECK'.
*     XFIELD IS EXT-LENGTH PACKET INTERNAL FIELD, 'LENX1' TO 'HCHECK'.
 
      FIELD = 1
      XFIELD = 1
20    IF (FIELD .LE. 5) THEN
 
*        A CHARACTER READ IN FIELD 4 HERE IS THE FIRST CHAR OF THE
*        DATA FIELD OR THE CHECKSUM CHARACTER IF THE DATA FIELD IS EMPTY
*
*        *LEN* IS THE >DATA< LENGTH
 
         IF (FIELD .LE. 4 .OR. LEN .GT. 0) THEN
            IF(GETC(STDIN,CH) .EQ. NEL) THEN
               IF (DEBUG .NE. 0) THEN
                 CALL FPRINTF(DEBUGFD,'\N<^S^H^O^R^T ^P^A^C^K^E^T>\N',0)
               ENDIF
               CALL FFLUSH(STDIN)
               RDPACK = ERROR
               RETURN
            ENDIF
            IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
               CALL PUTC(CH,DEBUGFD)
            ENDIF
            IF (CH .EQ. SSYNC) FIELD = 0
            NCH = NCH+1
         ENDIF
 
         IF (FIELD .LE. 3) CHKSUM = CHKSUM+CH
 
*        R E S Y N C   ( 0 )
 
         IF (FIELD .EQ. 0) THEN
            CHKSUM = 0
            IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
               CALL FPRINTF(DEBUGFD,'\N<^R^E^S^Y^N^C>\N',0)
               CALL FPRINTF(DEBUGFD,'^R^E^A^D^I^N^G:\N@C',SSYNC)
            ENDIF
 
*        L E N G T H   ( 1 )
 
         ELSE IF (FIELD .EQ. 1) THEN
            LEN = UNCHAR(CH-3)
            TYPE0 = (LEN .EQ. -3)
 
*        P A C K E T   N U M B E R   ( 2 )
 
         ELSE IF (FIELD .EQ. 2) THEN
            NUM = UNCHAR(CH)
 
*        P A C K E T   T Y P E   ( 3 )
 
         ELSE IF (FIELD .EQ. 3) THEN
            TYPE = CH
 
*        D A T A   ( 4 )
 
         ELSE IF (FIELD .EQ. 4 .AND. LEN .GT. 0) THEN
            CHKSUM = CHKSUM+CH
            DATA(1) = CH
 
*           READ 2ND-LEN CHARS OF DATA
 
            DO 100 I=2,LEN
               IF(GETC(STDIN,CH) .EQ. NEL) THEN
                  IF (DEBUG .NE. 0) THEN
                     CALL FPRINTF(DEBUGFD,
     +               '\N<^S^H^O^R^T ^P^A^C^K^E^T>\N',0)
                  ENDIF
                  CALL FFLUSH(STDIN)
                  RDPACK = ERROR
                  RETURN
               ENDIF
               NCH = NCH+1
               IF (CH .EQ. SSYNC) THEN
                  FIELD = 0
                  GO TO 20
               ENDIF
               IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
                  CALL PUTC(CH,DEBUGFD)
               ENDIF
               CHKSUM = CHKSUM+CH
               DATA(I) = CH
 100        CONTINUE
 
*        LENX1, LENX2, HCHECK
 
         ELSE IF(FIELD.EQ.4 .AND. TYPE0 .AND. LEN.LT.0) THEN
            FIELD = 3
            CHKSUM = CHKSUM + CH
            IF(XFIELD .EQ. 1) THEN
               EXLEN = UNCHAR(CH)*95
            ELSE IF(XFIELD .EQ. 2) THEN
               EXLEN = EXLEN + UNCHAR(CH)
            ELSE IF(XFIELD .EQ. 3) THEN
               LEN = EXLEN - 1
               HCH = CHKSUM - CH
               HCH = AND(HCH+(AND(HCH,O"300")/O"100"),O"77")
               IF(HCH .NE. UNCHAR(CH)) THEN
                  FIELD = 6
                  CHKSUM = HCH
                  IF(DEBUG.NE.0) CALL FPRINTF(DEBUGFD,'\NHEADER CHKSUM',
     +              0,0,0,0)
               ENDIF
            ENDIF
            XFIELD = XFIELD + 1
 
*        C H E C K S U M   ( 5 )
 
         ELSE IF (FIELD .EQ. 5) THEN
            DATA(LEN+1) = 0
            CHKSUM = AND(CHKSUM+(AND(CHKSUM,O"300")/O"100"),O"77")
 
         ENDIF
 
*        PROCESS NEXT PACKET FIELD
 
         FIELD = FIELD+1
         GOTO 20
      ENDIF
 
*     DOES THE CHECKSUM MATCH?
 
      IF (CHKSUM .NE. UNCHAR(CH)) THEN
         RDPACK = ERROR
         RCHOVRH = RCHOVRH+NCH
         IF (DEBUG .NE. 0) THEN
            CALL FPRINTF(DEBUGFD,'\NCKSUM ERROR, FOUND @D ',UNCHAR(CH))
            CALL FPRINTF(DEBUGFD,'NEEDED @D\N',CHKSUM)
         ENDIF
      ELSE
         RDPACK = TYPE
         RCHOVRH = RCHOVRH+NCH-LEN
         IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
            CALL PUTC(NEL,DEBUGFD)
         ENDIF
      ENDIF
      RCHCNT = RCHCNT+NCH
 
*     FLUSH ANY END-OF-LINE CHARACTERS AND OTHER GARBAGE
 
      CALL FFLUSH(STDIN)
 
 
      RETURN
      END
      SUBROUTINE RDPARAM(PDATA)
 
***   RDPARAM - GET THE PACKET PARAMETERS FROM THE OTHER KERMIT.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      BOOLEAN PDATA(*)
      INTEGER DPARAMS(12), RPARAMS(12)
      EQUIVALENCE (RPARAMS,RPKSIZE)
      EQUIVALENCE (DPARAMS,DPKSIZE)
 
*CALL COMXKER
 
 
*     INITIALIZE DEFAULT PACKET PARAMETERS.
 
      DO 10 I=1,12
         RPARAMS(I) = DPARAMS(I)
 10   CONTINUE
 
 
*     MOVE THE FIRST (UP TO 9) RECEIVED PARAMETERS TO RPARAMS BLOCK.
*     THEN COMPLETE SIZE NEGOTIATIONS AND CHECK CAPABILITIES.
 
      PDATAL = SLEN(PDATA)
      DO 20 I=1, MIN0(PDATAL, 9)
 
*     PAD CHARACTER
 
      IF (I .EQ. 4) THEN
        RPARAMS(I) = CTL(PDATA(I))
 
*     CONTROL, EIGHT-BIT, OR REPEAT PREFIX CHARACTER
 
      ELSE IF (I.EQ.6 .OR. I.EQ.7 .OR. I.EQ.9) THEN
         IF ( (PDATA(I).GE.33 .AND. PDATA(I).LE.62) .OR.
     +        (PDATA(I).GE.96 .AND. PDATA(I).LE.126) ) THEN
            RPARAMS(I) = PDATA(I)
         ENDIF
 
*     OTHER FIELDS - SET WITH *UNCHAR* UNLESS DEFAULTED
 
      ELSE IF (UNCHAR(PDATA(I)) .NE. 0) THEN
         RPARAMS(I) = UNCHAR(PDATA(I))
 
      ENDIF
 
20    CONTINUE
 
*     DETERMINE SIZE OF PACKETS TO SEND.  CHECK FOR LONG-PACKET
*     CAPABILITIES OF OTHER END.
 
      RPKSIZE = MIN0(DPKSIZE, RPKSIZE)
 
      IF(PDATAL.GE.10 .AND. (UNCHAR(PDATA(10)).AND.CAPAS5).NE.0) THEN
         I = 10
30       J = UNCHAR(PDATA(I))
         IF((J .AND. CAPAS6) .NE. 0) GOTO 30
         RMAXLX = 0
         IF(PDATAL .GE. I+3) THEN
            RMAXLX = UNCHAR(PDATA(I+2))*95 +
     +               UNCHAR(PDATA(I+3))
         ENDIF
         IF(RMAXLX .EQ. 0) RMAXLX = 500
         RPKSIZE = RMAXLX
      ENDIF
 
      RPKSIZE = MIN0(DPKSIZE, RPKSIZE)
 
 
      RETURN
      END
      INTEGER FUNCTION RECEIVE(ISTATE)
 
***   RECEIVE - RECEIVE FILE STATE SWITCHING ROUTINE.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
 
*     INITIALIZE STATISTICS VARIABLES
 
         ABORTYP = 0
      SCHCNT = 0
      RCHCNT = 0
      SCHOVRH = 0
      RCHOVRH = 0
 
*     SET PACKET RETRY COUNT & CURRENT STATE
 
      NUMTRY = 0
      STATE = ISTATE
 
*     TAKE APPROPRIATE ACTION FOR THE CURRENT STATE
 
 10   IF ((DEBUG.AND.DBGSTAT).NE.0) THEN
         CALL FPRINTF(DEBUGFD,'\N^S^T^A^T^E=@C  ^P^A^C^K^E^T=@2D\N',
     +    STATE,PACKNUM)
      ENDIF
      IF (STATE .EQ. D) THEN
         STATE = RDATA()
         GOTO 10
      ELSE IF (STATE .EQ. F) THEN
         STATE = RFILE()
         GOTO 10
      ELSE IF (STATE .EQ. R) THEN
         STATE = RINIT()
         CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
         STARTIM = HR * 3600 + MIN * 60 + SEC
         GOTO 10
      ELSE IF (STATE .EQ. C) THEN
         CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
         ENDTIM = HR * 3600 + MIN * 60 + SEC
         RECEIVE = OK
      ELSE IF (STATE .EQ. E) THEN
         IF (FFD .NE. CLOSED) THEN
            CALL FCLOSE(FFD)
            CALL REMOVE(FILESTR)
         ENDIF
         RECEIVE = ERROR
      ELSE IF (STATE .EQ. A) THEN
         CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
         ENDTIM = HR * 3600 + MIN * 60 + SEC
         IF (FFD .NE. CLOSED) THEN
            CALL FCLOSE(FFD)
            CALL REMOVE(FILESTR)
         ENDIF
         CALL GETEMSG(ERRMSG(15))
         CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG)
         RECEIVE = ERROR
      ELSE
         CALL DISPLA(' RECEIVE - STATE ERROR = ',STATE)
         IF (FFD .NE. CLOSED) CALL FCLOSE(FFD)
         RECEIVE = ERROR
      ENDIF
 
 
      RETURN
      END
      SUBROUTINE REMOVE(FN)
 
***   REMOVE - REMOVE A FILE FROM THE LOCAL FILE LIST.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      BOOLEAN FN(*)
      CHARACTER*10 LFN
 
 
*     QUIT IF NOTHING USEFUL IN THE FILE NAME ARRAY.
 
      IF(FN(1) .EQ. 0) RETURN
 
*     CONVERT THE FILE NAME TO DISPLAY CODE.
 
      CALL AS2DPC(FN,LFN)
 
*     GET RID OF THE FILE.
 
      CALL RETFILE(LFN)
 
 
      RETURN
      END
      INTEGER FUNCTION RFILE()
 
***   RFILE - READ A FILENAME PACKET.
*
*     RFILE EXPECTS TO SEE A FILENAME (TYPE F) PACKET.  HOWEVER, IT MAY
*     FIND A SEND-INIT RETRY, END-OF-FILE RETRY OR BREAK PACKET.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER*20 FILENAM
 
 
      IF (NUMTRY .GT. MAXRTRY) THEN
         RFILE = A
         ABORTYP = TOOMANY.OR.READING.OR.FILERR
         RETURN
      ENDIF
      NUMTRY = NUMTRY + 1
 
*     READ A PACKET
 
      PTYP = RDPACK(LEN,NUM,PACKET)
 
*     F I L E N A M E
 
      IF (PTYP .EQ. F) THEN
         IF (NUM .NE. PACKNUM) THEN
            RFILE = A
            ABORTYP = SEQERR.OR.READING.OR.FILERR
            RETURN
         ENDIF
         CALL EXPSTR(PACKET, LEN, FILESTR)
         CALL AS2DPC(FILESTR, FILENAM)
         CALL FILCHK(FILENAM)
         CALL DPC2AS(FILENAM, FILESTR, 7)
         IF (FILMODE .EQ. TEXT) THEN
            FFD = FOPEN(FILENAM, CREATE, TXTMODE)
         ELSE
            FFD = FOPEN(FILENAM, CREATE, CSBIN)
         ENDIF
         IF (FFD .EQ. ERROR) THEN
            FFD = CLOSED
            RFILE = A
            ABORTYP = LCLFILE.OR.READING.OR.FILERR
         ELSE
            IF (DEBUG .NE. 0) CALL FPRINTF(DEBUGFD,
     +         '^R^E^C^E^I^V^I^N^G ^F^I^L^E: @S\N',FILESTR,0,0,0)
 
*           SEND FILE NAME USED BACK TO MICRO.
 
            CALL SNDPACK(Y, NUM, LEN, FILESTR)
            NUMTRY = 0
            PACKNUM = MOD(PACKNUM+1,64)
            RFILE = D
         ENDIF
 
*     S E N D - I N I T
 
      ELSE IF (PTYP .EQ. S) THEN
         IF (MOD(NUM+1,64) .EQ. PACKNUM) THEN
            CALL SNDPAR(Y,PACKET,LEN)
            CALL SNDPACK(Y,NUM,LEN,PACKET)
            NUMTRY = 0
            RFILE = STATE
         ELSE
            RFILE = A
            ABORTYP = SEQERR.OR.READING.OR.INITERR
         ENDIF
 
*     E O F
 
      ELSE IF (PTYP .EQ. Z) THEN
         IF (MOD(NUM+1,64) .EQ. PACKNUM) THEN
            CALL SNDPACK(Y,NUM,0,0)
            NUMTRY = 0
            RFILE = STATE
         ELSE
            RFILE = A
            ABORTYP = SEQERR.OR.READING.OR.EOFERR
         ENDIF
 
*     B R E A K
 
      ELSE IF (PTYP .EQ. B) THEN
         IF (NUM .NE. PACKNUM) THEN
            RFILE = A
            ABORTYP = SEQERR.OR.READING.OR.BRKERR
         ELSE
            CALL SNDPACK(Y,PACKNUM,0,0)
            RFILE = C
         ENDIF
 
*     E R R O R
 
      ELSE IF (PTYP .EQ. E) THEN
         RFILE = E
         RETURN
 
*     B A D   C H E C K S U M
 
      ELSE IF (PTYP .EQ. ERROR) THEN
         RFILE = STATE
         CALL SNDPACK(N,PACKNUM,0,0)
 
*     B A D   T Y P E
 
      ELSE
         RFILE = A
         ABORTYP = INVALID.OR.READING.OR.FILERR
 
      ENDIF
 
 
      RETURN
      END
      INTEGER FUNCTION RINIT()
 
***   RINIT - RECEIVE A SEND-INIT PACKET.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
 
*     CLEAN OUT FILESTR ARRAY SO REMOVE DOES NOT DO DIRE THINGS
*     TO THE PREVIOUSLY RECEIVED FILE IF WE DIE BEFORE WE GET
*     THE NEW FILE SPECIFICATION.
 
      DO 10 I=1, IPKSIZE
 10       FILESTR(I) = 0
 
*     CHECK RETRY COUNT
 
      IF (NUMTRY .GT. MAXRINI) THEN
         RINIT = A
         ABORTYP = TOOMANY.OR.READING.OR.INITERR
         RETURN
      ENDIF
      NUMTRY = NUMTRY+1
 
*     IF AN TRASH PACKET IS READ, THE SEQUENCE NUMBER IN THE PACKET
*     MAY BE INVALID, SO THAT WHEN A NAK IS SENT (BELOW), WE
*     USE PACKNUM AS THE NAK SEQUENCE NUMBER.  SET PACKNUM
*     TO A VALID STARTING VALUE.
 
      PACKNUM = 0
 
 
*     READ A PACKET (SHOULD BE INIT).  ALLOW SWAPOUT WHILE WAITING.
 
      WAITPAK = .FALSE.
      PTYP = RDPACK(LEN, NUM, PACKET)
      WAITPAK = .TRUE.
 
*     S E N D - I N I T
 
      IF (PTYP .EQ. S) THEN
         PACKNUM = NUM
         CALL RDPARAM(PACKET)
         CALL SNDPAR(Y,PACKET,LEN)
         CALL SNDPACK(Y,NUM,LEN,PACKET)
         NUMTRY = 0
         PACKNUM = MOD(PACKNUM+1,64)
         RINIT = F
 
*     B A D   C H E C K S U M
 
      ELSE IF (PTYP .EQ. ERROR) THEN
         RINIT = STATE
         CALL SNDPACK(N,PACKNUM,0,0)
 
*     B A D   T Y P E
 
      ELSE
         RINIT = A
         ABORTYP = INVALID.OR.READING.OR.INITERR
 
      ENDIF
 
 
      RETURN
      END
      INTEGER FUNCTION SBREAK()
 
***   SBREAK - SEND THE BREAK PACKET AND WAIT FOR REPLY.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
 
*     HAVE WE TRIED THIS TOO MANY TIMES?
 
      IF (NUMTRY .GT. MAXRTRY) THEN
         SBREAK = A
         ABORTYP = TOOMANY.OR.SENDING.OR.BRKERR
         RETURN
      ENDIF
      NUMTRY = NUMTRY + 1
 
*     SEND THE BREAK PACKET
 
      CALL SNDPACK(B,PACKNUM,0,0)
 
*     READ THE REPLY
 
      PTYP = RDPACK(LEN,NUM,RECPACK)
 
*     N A K
 
      IF (PTYP .EQ. N) THEN
         IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
            SBREAK = STATE
            RETURN
         ELSE
            PTYP = Y
            NUM = NUM-1
         ENDIF
      ENDIF
 
*     A C K
 
      IF (PTYP .EQ. Y) THEN
         IF (PACKNUM .NE. NUM) THEN
            SBREAK = STATE
            RETURN
         ENDIF
         NUMTRY = 0
         PACKNUM = MOD(PACKNUM+1,64)
         SBREAK = C
 
*     E R R O R
 
      ELSE IF (PTYP .EQ. E) THEN
         SBREAK = E
         RETURN
 
*     B A D   C H E C K S U M
 
      ELSE IF (PTYP .EQ. ERROR) THEN
         SBREAK = STATE
 
*     B A D   T Y P E
 
      ELSE
         SBREAK = A
         ABORTYP = INVALID.OR.SENDING.OR.BRKERR
 
      ENDIF
 
 
      RETURN
      END
      INTEGER FUNCTION SDATA()
 
***   SDATA - SEND A DATA PACKET AND WAIT FOR REPLY.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
         CHARACTER LFN*10
 
 
*     HAVE WE TRIED THIS TOO MANY TIMES?
 
      IF (NUMTRY .GT. MAXRTRY) THEN
         SDATA = A
         ABORTYP = TOOMANY.OR.SENDING.OR.DATAERR
         RETURN
      ENDIF
      NUMTRY = NUMTRY + 1
 
*     SEND THE CURRENT DATA BUFFER
 
      IF (PSIZE .EQ. EOF) THEN
         SDATA = Z
         RETURN
      ENDIF
      CALL SNDPACK(D,PACKNUM,PSIZE,PACKET)
 
*     READ THE REPLY
 
      PTYP = RDPACK(LEN,NUM,RECPACK)
 
*     N A K
 
      IF (PTYP .EQ. N) THEN
         IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
            SDATA = STATE
            RETURN
         ELSE
            PTYP = Y
            NUM = NUM-1
         ENDIF
      ENDIF
 
*     A C K
 
      IF (PTYP .EQ. Y) THEN
         IF (PACKNUM .NE. NUM) THEN
            SDATA = STATE
            RETURN
         ENDIF
         NUMTRY = 0
         PACKNUM = MOD(PACKNUM+1,64)
         PSIZE = BUFFILL(FFD,PACKET)
         IF (PSIZE .EQ. EOF) THEN
            SDATA = Z
         ELSE IF(LEN.GT.0 .AND. RECPACK(1).EQ.X) THEN
 
*           INTERRUPT FILE TRANSFER
 
            ABORTYP = INTRPT .OR. SENDING
            SDATA = Z
         ELSE IF(LEN.GT.0 .AND. RECPACK(1).EQ.Z) THEN
 
*           INTERRUPT GROUP TRANSFER
*           EAT UP REST OF FILE-SEND LIST
 
            ABORTYP = INTRPT .OR. SENDING
            SDATA = Z
10          IF(LOCFILE) THEN
               CALL GETLFN(LFN)
            ELSE
               CALL GETPFN(LFN)
            ENDIF
            IF(LFN .NE. ' ') GOTO 10
         ELSE
            SDATA = STATE
         ENDIF
 
*     E R R O R
 
      ELSE IF (PTYP .EQ. E) THEN
         SDATA = E
         CALL EXPSTR(RECPACK, LEN, MICMSG(16))
         ABORTYP = SENDING .OR. MICERR
         RETURN
 
*     B A D   C H E C K S U M
 
      ELSE IF (PTYP .EQ. ERROR) THEN
         SDATA = STATE
 
*     B A D   T Y P E
 
      ELSE
         SDATA = A
         ABORTYP = INVALID.OR.SENDING.OR.DATAERR
 
      ENDIF
 
 
      RETURN
      END
      INTEGER FUNCTION SEND(SENDTYP, STR)
 
***   SEND - SEND FILE STATE SWITCHING ROUTINE
*
*     THE FILENAME TO SEND IS ASSUMED TO HAVE ALREADY BEEN
*     OBTAINED AND SET IN ASCII STRING BUFFER FILESTR.
*
*     ENTRY:   SENDTYP - F OR X SEND TYPE FOR 'SFILE'
*              STR - CHARACTER MESSAGE STRING IF X TYPE SEND
*
*     F TYPE SEND IS FOR NORMAL FILE TRANSFER.
*     X TYPE SEND ALLOWS TEXT TRANSFER TO THE REMOTE KERMIT WITH A
*     HEADER TEXT STRING.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER STR*(*)
 
*     INITIALIZE STATICS VARIABLES
 
         ABORTYP = 0
      SCHCNT = 0
      RCHCNT = 0
      SCHOVRH = 0
      RCHOVRH = 0
      STATE = S
      NUMTRY = 0
 
*     TAKE APPROPRIATE ACTION FOR THE CURRENT STATE
 
 10   IF ((DEBUG.AND.DBGSTAT).NE.0) THEN
         CALL FPRINTF(DEBUGFD,'\N^S^T^A^T^E=@C  ^P^A^C^K^E^T=@2D\N',
     +    STATE,PACKNUM)
      ENDIF
      IF (STATE .EQ. D) THEN
         STATE = SDATA()
         GOTO 10
      ELSE IF (STATE .EQ. F) THEN
         STATE = SFILE(SENDTYP, STR)
         GOTO 10
      ELSE IF (STATE .EQ. Z) THEN
         STATE = SEOF()
         GOTO 10
      ELSE IF (STATE .EQ. S) THEN
         STATE = SINIT()
         CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
         STARTIM = HR * 3600 + MIN * 60 + SEC
         GOTO 10
      ELSE IF (STATE .EQ. B) THEN
         STATE = SBREAK()
         GOTO 10
      ELSE IF (STATE .EQ. C) THEN
         CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
         ENDTIM = HR * 3600 + MIN * 60 + SEC
         SEND = OK
      ELSE IF (STATE .EQ. E) THEN
         CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
         ENDTIM = HR * 3600 + MIN * 60 + SEC
         SEND = ERROR
         IF (FFD .NE. CLOSED) CALL FCLOSE(FFD)
      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. CLOSED) CALL FCLOSE(FFD)
         CALL GETEMSG(ERRMSG(15))
         CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG)
      ELSE
         CALL DISPLA(' SEND - STATE ERROR = ',STATE)
         SEND = ERROR
         IF (FFD .NE. CLOSED) CALL FCLOSE(FFD)
      ENDIF
 
 
      RETURN
      END
      INTEGER FUNCTION SEOF()
 
***   SEOF - SEND AN EOF PACKET AND WAIT FOR THE REPLY.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER LFN*10
 
*     HAVE WE TRIED THIS TOO MANY TIMES?
 
      IF (NUMTRY .GT. MAXRTRY) THEN
         SEOF = A
         ABORTYP = TOOMANY.OR.SENDING.OR.EOFERR
         RETURN
      ENDIF
      NUMTRY = NUMTRY + 1
 
*     SEND THE EOF PACKET
 
      CALL SNDPACK(Z,PACKNUM,0,0)
 
*     READ THE REPLY
 
      PTYP = RDPACK(LEN,NUM,RECPACK)
 
*     N A K
 
      IF (PTYP .EQ. N) THEN
         IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
            SEOF = STATE
            RETURN
         ELSE
            PTYP = Y
            NUM = NUM-1
         ENDIF
      ENDIF
 
*     A C K
 
      IF (PTYP .EQ. Y) THEN
         IF (PACKNUM .NE. NUM) THEN
            SEOF = STATE
            RETURN
         ENDIF
         NUMTRY = 0
         PACKNUM = MOD(PACKNUM+1,64)
         CALL FCLOSE(FFD)
 
*     GET NEXT FILE TO SEND, IF ANY.
 
         IF(LOCFILE) THEN
            CALL GETLFN(LFN)
         ELSE
            CALL REMOVE(FILESTR)
            CALL GETPFN(LFN)
         ENDIF
         IF(LFN .NE. ' ') THEN
            IF(.NOT.LOCFILE) CALL GETPFIL(LFN)
            CALL DPC2AS(LFN, FILESTR, INDEX(LFN,' ')-1)
            SEOF = F
         ELSE
            SEOF = B
         ENDIF
 
*     E R R O R
 
      ELSE IF (PTYP .EQ. E) THEN
         SEOF = E
         RETURN
 
*     B A D   C H E C K S U M
 
      ELSE IF (PTYP .EQ. ERROR) THEN
         SEOF = STATE
 
*     B A D   T Y P E
 
      ELSE
         SEOF = A
         ABORTYP = INVALID.OR.SENDING.OR.EOFERR
 
      ENDIF
 
 
      RETURN
      END
          IDENT  SETF
          ENTRY  SETF
          B1=1
          TITLE  SETF - SET SPECIAL HANDLING FOR TERMINAL OUTPUT FILE.
          COMMENT SETF - SET SPECIAL HANDLING FOR TERMINAL OUTPUT FILE.
          SPACE  4
***       SETF - SET SPECIAL HANDLING FOR TERMINAL OUTPUT FILE.
*
*         FORTRAN CALL -
*
*            CALL SETF(FET)
*
*         ENTRY  (FET) = FET OF TERMINAL OUTPUT FILE.
*
*         EXIT   NONE.
 
 
 SETF     SUBR               ENTRY/EXIT
          SA2    X1+B1       (X2) = FET+1
          SX6    B1
          LX6    36
          BX6    X6+X2       SET FLUSH BIT
          SA6    A2
          SA2    X1          (X2) = FET+0
          MX6    42
          BX6    X6*X2       (X6) = FILE NAME
          BX6    X6+X1       COMBINE WITH FET ADDRESS
          SA6    2
          MX6    0
          SA6    A6+B1
          EQ     SETFX       RETURN
 
          END
      SUBROUTINE SETPACK(ATTR)
 
***   SETPACK - SET PACKET SEND OR RECEIVE ATTRIBUTES.
*
*     SETPACK WILL WET THE ATTRIBUTES OF THE PASSED ATTRIBUTE
*     LIST.  THIS SUBROUTINE WILL SET THE APPROPRIATE PACKET
*     PARAMETER.  THE PARAMETER TO SET IS PASSED IN AN ARRAY
*     AND IS VERY ORDER DEPENDENT.  SEE COMMON BLOCK /PACKET/
*     FOR THE ORDERING.  NOTE THAT SEND AND RECEIVE PARAMETER
*     ORDERING AND STORAGE SIZE IN THE COMMON BLOCK ARE
*     IDENTICAL.  KEEP IT THAT WAY!
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      INTEGER ATTR(12)
      PARAMETER (TSIZE=9)
      CHARACTER*15 ATTRTYP(TSIZE)
      DATA ATTRTYP / 'END-OF-LINE', 'PACKET-LENGTH', 'PAD-CHARACTER',
     +               'PAD-LENGTH', 'QUOTE-CHARACTER', 'Q8-CHARACTER',
     +               'REPEAT-PREFIX','SYNC-CHARACTER', 'TIME-OUT' /
 
 
      INDX = MATCH(ATTRTYP,TSIZE,.FALSE.)
      IF (INDX .LE. 0) RETURN
      GO TO (10, 20, 30, 40, 50, 55, 56, 60, 70), INDX
 
*     SET EOL CHARACTER
 
 10   CALL SETVAL(ATTR(5),'I',1,31,127,127,HLPASCH,.TRUE.)
      RETURN
 
*     SET MAXIMUM PACKET LENGTH
 
 20   CALL SETVAL(ATTR(1),'I',20,LPKSIZE,20,LPKSIZE,HLPPLEN,.TRUE.)
      RETURN
 
*     SET PAD CHARACTER
 
 30   CALL SETVAL(ATTR(4),'I',0,31,127,127,HLPASCH,.TRUE.)
      RETURN
 
*     SET PAD LENGTH
 
 40   CALL SETVAL(ATTR(3),'I',0,94,0,94,HLPPADL,.TRUE.)
      RETURN
 
*     SET CONTROL QUOTE CHARACTER
 
 50   CALL SETVAL(ATTR(6),'I',33,62,96,126,HLPASCH,.TRUE.)
      RETURN
 
*     SET EIGHT BIT QUOTE CHARACTER
 
 55   CALL SETVAL(ATTR(7),'I',33,62,96,126,HLPASCH,.TRUE.)
      RETURN
 
*     SET REPEAT PREFIX CHARACTER
 
 56   CALL SETVAL(ATTR(9),'I',33,62,96,126,HLPASCH,.TRUE.)
      RETURN
 
*     SET SYNC CHARACTER
 
 60   CALL SETVAL(ATTR(12),'I',0,127,0,127,HLPASCH,.TRUE.)
      RETURN
 
*     SET TIMEOUT VALUE
 
 70   CALL SETVAL(ATTR(2),'I',0,94,0,94,HLPTIMO,.TRUE.)
      RETURN
 
 
      END
      SUBROUTINE SETVAL(VAR,VTYP,MN1,MX1,MN2,MX2,HLPMSG,CONFRM)
 
***   SETVAL - SET A VARIABLE VALUE.
*
*     SETVAL WILL READ A TOKEN FROM INPUT AND SET A VARIABLE TO
*     THAT VALUE.  IF THE TOKEN IS A QUESTION MARK THEN THE
*     HELP MESSAGE WILL BE DISPLAYED AND SETVAL WILL RETURN
*     WITHOUT SETTING A VALUE.
*
*     ENTRY:   (VTYP) = CHARACTER 'S' FOR STRING VARIABLE.
*                     = CHARACTER 'I' FOR INTEGER VARIABLE.
*              (MN1-MX1) = RANGE #1 FOR VAR TO FIT IN IF INTEGER.
*                        = MN1 IS RETURN CODE FOR ERROR AND MX1 IS
*                          MAX SIZE OF STRING IF STRING VAR.
*              (MN2-MX2) = SECONDARY RANGE FOR VAR TO FIT IN IF
*                          INTEGER VAR.
*                        = UNUSED FOR STRING VAR.
*              (HLPMSG) = FPRINTF MESSAGE FORMAT TO DISPLAY IF
*                         A QUESTION MARK IS READ.
*
*     EXIT:    (VAR) = INT VALUE READ IF INTEGER VAR. OR STRING
*                      VALUE READ IF STRING VAR.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER*(*) VTYP, HLPMSG
      INTEGER VAR(41), STR(41)
      LOGICAL CONFRM, CONFIRM
 
 
*     CHECK VAR TYPE
 
      IF (VTYP .NE. 'S' .AND. VTYP .NE. 'I') THEN
         CALL DISPLA('SETVAL - INVALID VAR TYPE ',ASC(VTYP))
         CALL ABORT
      ENDIF
      IF (VTYP .EQ. 'S' .AND. MX1 .GT. 40) THEN
         CALL DISPLA('SETVAL - STRING MAX IS TOO LARGE ',MX1)
         CALL ABORT
      ENDIF
      LEN = GETWORD(CMDFD,STR,MX1)
      IF (LEN .EQ. 0 .OR. LEN .EQ. EOF) THEN
         IF (VTYP .EQ. 'I') THEN
            CALL FPRINTF(STDOUT,'?^INVALID, ^FIRST NONSPACE CHARACTER IS
     - NOT A DIGIT\N',0,0)
         ELSE
            CALL FPRINTF(STDOUT,'?^INVALID, ^MISSING PARAMETER\N',0,0)
            MN1 = ERROR
         ENDIF
         RETURN
      ENDIF
      IF (STR(1) .EQ. QMARK) THEN
         CALL FPRINTF(STDOUT,HLPMSG,0,0)
         CALL FFLUSH(CMDFD)
         IF (VTYP .EQ. 'S') MN1 = ERROR
         RETURN
      ENDIF
 
*     CONFIRM THE REQUEST IF NECESSARY
 
      IF (CONFRM) THEN
         IF (.NOT. CONFIRM(CMDFD)) THEN
            IF (VTYP .EQ. 'S') MN1 = ERROR
            RETURN
         ENDIF
      ENDIF
 
*     GO AHEAD AND SET THE VARIABLE
 
      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 FPRINTF(STDOUT,'?^VALUE IS NOT WITHIN RANGE OF @D - @D'
     +        ,MN1,MX1)
            IF (MN1 .NE. MN2 .OR. MX1 .NE. MX2) THEN
               CALL FPRINTF(STDOUT,' OR @D - @D',MN2,MX2)
            ENDIF
            CALL PUTC(NEL,STDOUT)
         ENDIF
      ELSE
         DO 100 I = 1,LEN
            VAR(I) = STR(I)
100      CONTINUE
         VAR(LEN+1) = 0
         MN1 = OK
      ENDIF
 
 
      RETURN
      END
      INTEGER FUNCTION SFILE(SENDTYP, STR)
 
***   SFILE - SEND A FILENAME PACKET AND WAIT FOR REPLY.
*
*     THE FILENAME IS ASSUMED TO HAVE BEEN PREVIOUSLY OBTAINED
*     AND STORED IN THE ASCII STRING BUFFER FILESTR IN UPPER CASE.
*
*     ENTRY:   SENDTYP - F OR X SEND TYPE FOR 'SFILE'
*              STR - CHARACTER MESSAGE STRING IF X TYPE SEND
*
*     F TYPE SEND IS FOR NORMAL FILE TRANSFER.
*     X TYPE SEND ALLOWS TEXT TRANSFER TO THE REMOTE KERMIT WITH A
*     HEADER TEXT STRING.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER STR*(*)
      CHARACTER FILENAM*10
 
*     HAVE WE TRIED THIS TOO MANY TIMES?
 
      IF (NUMTRY .GT. MAXRTRY) THEN
         SFILE = A
         ABORTYP = TOOMANY.OR.SENDING.OR.FILERR
         RETURN
      ENDIF
      NUMTRY = NUMTRY + 1
 
*     SEND THE FILENAME PACKET
 
 
*     OPEN FILE ON FIRST TRY OF 'F' PACKET SEND.
 
      IF(NUMTRY .EQ. 1) THEN
         CALL AS2DPC(FILESTR,FILENAM)
         IF (FILMODE .EQ. TEXT) THEN
            FFD = FOPEN(FILENAM,RD,TXTMODE)
         ELSE
            FFD = FOPEN(FILENAM,RD,CSBIN)
         ENDIF
         IF (FFD .EQ. ERROR) THEN
            SINIT = A
            FFD = CLOSED
            RETURN
         ENDIF
      ENDIF
      IF(SENDTYP .EQ. F) THEN
         CALL SNDPACK(F,PACKNUM,SLEN(FILESTR),FILESTR)
      ELSE
         CALL DPC2AS(STR, RECPACK, LEN(STR))
         CALL SNDPACK(X, PACKNUM, LEN(STR), RECPACK)
      ENDIF
 
*     READ THE REPLY
 
      PTYP = RDPACK(I, NUM, RECPACK)
 
*     N A K
 
      IF (PTYP .EQ. N) THEN
         IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
            SFILE = STATE
            RETURN
         ELSE
            PTYP = Y
            NUM = NUM-1
         ENDIF
      ENDIF
 
*     A C K
 
      IF (PTYP .EQ. Y) THEN
         IF (PACKNUM .NE. NUM) THEN
            SFILE = STATE
            RETURN
         ENDIF
         NUMTRY = 0
         PACKNUM = MOD(PACKNUM+1,64)
 
*        GET FIRST PACKET OF DATA FROM THE FILE
 
         PSIZE = BUFFILL(FFD,PACKET)
         SFILE = D
 
*     E R R O R
 
      ELSE IF (PTYP .EQ. E) THEN
         SFILE = E
         RETURN
 
*     B A D   C H E C K S U M
 
      ELSE IF (PTYP .EQ. ERROR) THEN
         SFILE = STATE
 
*     B A D   T Y P E
 
      ELSE
         SFILE = A
         ABORTYP = INVALID.OR.SENDING.OR.FILERR
 
      ENDIF
 
 
      RETURN
      END
      INTEGER FUNCTION SINIT()
 
***   SINIT - SEND THE SEND-INIT PACKET AND WAIT FOR REPLY.
*
*     ASSUMES FILESTR HAS ALREADY BEEN CHECKED FOR LEGAL FILENAME
*     AND BEING LOCAL.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
*     CHECK NUMBER OF RETRIES
 
      IF (NUMTRY .GT. MAXRINI) THEN
         SINIT = A
         ABORTYP = TOOMANY.OR.SENDING.OR.INITERR
         RETURN
      ELSE
         NUMTRY = NUMTRY + 1
      ENDIF
 
*     SEND THE SEND-INIT PACKET
 
      CALL SNDPAR(S,PACKET,LEN)
      CALL SNDPACK(S,PACKNUM,LEN,PACKET)
 
*     READ AND PROCESS THE REPLY
 
      PTYP = RDPACK(LEN,NUM,RECPACK)
 
*     N A K
 
      IF (PTYP .EQ. N) THEN
         SINIT = STATE
         RETURN
 
*     A C K
 
      ELSE IF (PTYP .EQ. Y) THEN
         IF (PACKNUM .NE. NUM) THEN
            SINIT = STATE
            RETURN
         ENDIF
         CALL RDPARAM(RECPACK)
 
*        CONVERT Q8CH FOR EASIER USE LATER ON IN ENCODING FILE DATA.
*        ANY RESPONSE TO OUR "Y" THAT IS NOT A VALID EIGHT-BIT QUOTE
*        CHARACTER WILL CAUSE EIGHT-BIT QUOTING TO BE SUPPRESSED.
 
         IF ((R8QUOTE .LT. 33 .OR.  R8QUOTE .GT. 126) .OR.
     -       (R8QUOTE .GT. 62 .AND. R8QUOTE .LT. 96)) THEN
            Q8CH = 0
         ELSE
            Q8CH = R8QUOTE
         ENDIF
 
         NUMTRY = 0
         PACKNUM = MOD(PACKNUM+1,64)
         SINIT = F
 
*     E R R O R
 
      ELSE IF (PTYP .EQ. E) THEN
         SINIT = E
         RETURN
 
*     B A D  C E C K S U M
 
      ELSE IF (PTYP .EQ. ERROR) THEN
         SINIT = STATE
 
*     B A D  T Y P E
 
      ELSE
         SINIT = A
         ABORTYP = INVALID.OR.SENDING.OR.INITERR
 
      ENDIF
 
 
      RETURN
      END
      SUBROUTINE SLEEP(SECONDS)
 
***   SLEEP - DELAY A NUMBER OF SECONDS
*
*     ENTRY   SECONDS = INTEGER NUMBER OF SECONDS TO SLEEP.
*
*     EXIT    INDICATED NUMBER OF SECONDS HAS ELAPSED.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
 
      CALL ROLLOUT(O"0200 00 0000"+SECONDS)
 
 
      RETURN
      END
      INTEGER FUNCTION SLEN(STR)
 
***   SLEN - RETURN THE LENGTH OF A ZERO TERMINATED ASCII STRING BUFFER.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      BOOLEAN STR(*)
 
 
      I = 0
 10   IF (STR(I+1) .NE. 0) THEN
         I = I+1
         GOTO 10
      ENDIF
      SLEN = I
 
 
      RETURN
      END
      SUBROUTINE SNDPACK(TYPE,NUM,LEN,DATA)
 
***   SNDPACK - SEND A PACKET DOWN AN OUTPUT STREAM
*
*     SNDPACK WILL SEND A PACKET OF INFORMATION AND LOG IT
*     IF DEBUG IS TURNED ON.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      INTEGER DATA(*)
      LOGICAL LONGPAK
 
*CALL COMXKER
 
 
*     LOG THE PACKET
 
      IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
         CALL FPRINTF(DEBUGFD,'^S^E^N^D^I^N^G:\N')
      ENDIF
 
*     PUT OUT PAD CHARS
 
      DO 100 I = 1,RPADCT
         CALL PUTC(RPADCH,STDOUT)
         IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
            CALL PUTC(RPADCH,DEBUGFD)
         ENDIF
 100  CONTINUE
 
*     PACKET LEN ASSUMES ONE CHARACTER CHECKSUMS
 
      CALL PUTC(RSYNC,STDOUT)
 
*     DETERMINE IF WE NEED EXTENDED PACKET.
*     OUTPUT PROPER LENGTH FIELD, 0 IF EXTENDED PACKET
 
      LONGPAK = ((RPKSIZE.GT.IPKSIZE) .AND. (LEN.GT.91))
      IF(LONGPAK) THEN
         CHKSUM = TOCHAR(0)
      ELSE
         CHKSUM = TOCHAR(LEN+3)
      ENDIF
      CALL PUTC(CHKSUM,STDOUT)
      TMP = TOCHAR(NUM)
      CHKSUM = CHKSUM + TMP
      CALL PUTC(TMP,STDOUT)
      CHKSUM = CHKSUM + TYPE
      CALL PUTC(TYPE,STDOUT)
 
*     IF EXTENDED PACKET, OUTPUT EXTENDED HEADER BEFORE DATA
 
      IF(LONGPAK) THEN
         LENX1 = TOCHAR((LEN+1)/95)
         CHKSUM = CHKSUM + LENX1
         CALL PUTC(LENX1, STDOUT)
         LENX2 = TOCHAR(MOD(LEN+1, 95))
         CHKSUM = CHKSUM + LENX2
         CALL PUTC(LENX2, STDOUT)
         HCHKSUM = TOCHAR((CHKSUM + (CHKSUM.AND.O"300") / O"100")
     +                     .AND. O"77")
         CHKSUM = CHKSUM + HCHKSUM
         CALL PUTC(HCHKSUM, STDOUT)
      ENDIF
      DO 110 I = 1,LEN
         CHKSUM = CHKSUM + (DATA(I) .AND. O"377")
         CALL PUTC(DATA(I),STDOUT)
110   CONTINUE
      CHKSUM = (CHKSUM + (CHKSUM.AND.O"300") / O"100") .AND. O"77"
      CALL PUTC(TOCHAR(CHKSUM),STDOUT)
      CALL PUTC(REOLCH,STDOUT)
      IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN
         CALL PUTC(RSYNC,DEBUGFD)
         IF(LONGPAK) THEN
            CALL PUTC(TOCHAR(0), DEBUGFD)
         ELSE
            CALL PUTC(TOCHAR(LEN+3), DEBUGFD)
         ENDIF
         CALL PUTC(TOCHAR(NUM),DEBUGFD)
         CALL PUTC(TYPE,DEBUGFD)
         IF(LONGPAK) THEN
            CALL PUTC(LENX1, DEBUGFD)
            CALL PUTC(LENX2, DEBUGFD)
            CALL PUTC(HCHKSUM, DEBUGFD)
         ENDIF
         IF (LEN .GT. 0) CALL PUTSTR(DEBUGFD,DATA)
         CALL PUTC(TOCHAR(CHKSUM),DEBUGFD)
         CALL PUTC(REOLCH,DEBUGFD)
         CALL PUTC(NEL,DEBUGFD)
      ENDIF
 
*     ADD A NOS ZERO BYTE EOL AND FLUSH THE BUFFER
*     (NOTE: PUTC XORS THE HIGH BIT OF EACH 12 BIT BYTE FOR CONNECTED
*     FILES, SO TO GET A ZERO BYTE WE PUTC 4000B)
 
      CALL PUTC(O"4000",STDOUT)
      CALL FFLUSH(STDOUT)
 
*     UPDATE THE STATISTICS
 
      NCH = RPADCT+5+LEN+1
      IF(LONGPAK) THEN
         NCH = NCH + 3
      ENDIF
      SCHCNT = SCHCNT+NCH
      SCHOVRH = SCHOVRH+NCH-LEN
 
 
      RETURN
      END
      SUBROUTINE SNDPAR(TYPE,PDATA,LEN)
 
***   SNDPAR - SET UP PARAMETERS TO SEND TO OTHER KERMIT.
*
*     ENTRY    (TYPE) = TYPE OF BLOCK WE ARE GENERATING PARAMETERS FOR.
*                     = *Y* IF AN ACK (REPLY) PACKET.
*                     = *S* IF A SEND-INIT (INITIAL) PACKET.
*
*     EXIT     (PDATA) = UNPACKED ASCII BUFFER WITH
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      BOOLEAN PDATA(*)
 
*CALL COMXKER
 
 
*     SEND WHAT WE WANT
 
      PDATA(1)  = TOCHAR(MIN0(IPKSIZE, SPKSIZE))
      PDATA(2)  = TOCHAR(STIMOUT)
      PDATA(3)  = TOCHAR(SPADCT)
      PDATA(4)  = CTL(SPADCH)
      PDATA(5)  = TOCHAR(SEOLCH)
      PDATA(6)  = SCQUOTE
      PDATA(7)  = S8QUOTE
      PDATA(8)  = SCHKTYP
 
      IF (TYPE .EQ. Y) THEN
 
*        R8QUOTE HAS BEEN SET TO THE 8-BIT QUOTE CHARACTER FROM THE
*        THE SENDER'S SEND-INIT PACKET, OR IS *N* BY DEFAULT.
*        THE FOLLOWING DECISION IS MADE IN ORDER TO SET *Q8CH*
*        FOR LATER USE IN *BUFEMP* -
*
*        IF A Y, WE WILL SEND BACK THE CHARACTER WE WANT HIM TO USE
*        (I8QUOTE) AND PUT THAT CHARACTER IN Q8CH.
*
*        IF AN N, NO QUOTING WILL BE DONE, SO SET Q8CH = 0.
*
*        OTHERWISE, HE SENT US HIS QUOTE CHARACTER, SO AGREE TO IT
*        AND PUT THAT CHARACTER IN Q8CH.
 
         IF (R8QUOTE .EQ. Y) THEN
            PDATA(7) = I8QUOTE
            Q8CH = I8QUOTE
         ELSE IF (R8QUOTE .EQ. N) THEN
            PDATA(7) = N
            Q8CH = 0
         ELSE
            PDATA(7) = Y
            Q8CH = R8QUOTE
         ENDIF
 
*        SET THE REPEAT PREFIX AND ECHO WHAT THE SENDER REQUESTED
*
*        WE ALSO SET REPCH FOR LATER USE IN ROUTINE *BUFEMP*.
 
         PDATA(9) = RRPTPFX
         IF (RRPTPFX .EQ. BLANK) THEN
            REPCH = 0
         ELSE
            REPCH = RRPTPFX
         ENDIF
 
*        WE CAN TAKE EXTENDED PACKETS IF *SPKSIZE* ALLOWS.
 
         IF(SPKSIZE .GT. IPKSIZE) THEN
            PDATA(10) = TOCHAR(CAPAS5)
            PDATA(11) = TOCHAR(0)
            PDATA(12) = TOCHAR(SPKSIZE/95)
            PDATA(13) = TOCHAR(MOD(SPKSIZE,95))
            PDATA(14) = 0
            LEN = 13
         ELSE
            PDATA(10) = 0
            LEN = 9
         ENDIF
 
      ELSE
         PDATA(7)  = S8QUOTE
         PDATA(9)  = SRPTPFX
 
*        WE CAN SEND EXTENDED PACKETS IF *DPKSIZE* ALLOWS.
 
         IF(DPKSIZE .GT. IPKSIZE) THEN
            PDATA(10) = TOCHAR(CAPAS5)
            PDATA(11) = TOCHAR(0)
            PDATA(12) = TOCHAR(DPKSIZE/95)
            PDATA(13) = TOCHAR(MOD(DPKSIZE,95))
            PDATA(14) = 0
            LEN = 13
         ELSE
            PDATA(10) = 0
            LEN = 9
         ENDIF
 
      ENDIF
 
 
 
      RETURN
      END
      SUBROUTINE SPRINTF(STR,FMT,I1,I2,I3,I4)
 
***   SPRINTF - POOR ATTEMPT AT DOING INTERNAL FORMATTED I/O.
*
*     SPRINTF IS THE SAME AS FPRINTF EXCEPT THAT IT WRITES TO
*     AND ASCII STRING BUFFER INSTEAD.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER*(*) FMT
      BOOLEAN STR(*)
 
 
      CALL DOPRNT(0,STR,2,FMT,I1,I2,I3,I4)
 
 
      RETURN
      END
      SUBROUTINE STRCPY(S1,S2)
 
***   STRCPY - COPY ONE ASCII STRING TO ANOTHER
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      BOOLEAN S1(*),S2(*)
 
 
      I1 = 1
10    S2(I1) = S1(I1)
      IF (S1(I1) .NE. 0) THEN
         I1 = I1+1
         GOTO 10
      ENDIF
 
 
      RETURN
      END
      SUBROUTINE STTY(MODE,VALUE)
 
***   STTY - SET A TERMINAL MODE.
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      CHARACTER*(*) MODE
      INTEGER VALUE
 
 
*     DUPLEX (ECHOPLEX)
 
      IF (MODE .EQ. 'DUPLEX') THEN
         IF (VALUE .EQ. HALFDUP) THEN
            DUPLEX = HALFDUP
            FCHBUF(1,STDOUT) = O"0016 4061 4000 0000 0000"
         ELSE
            DUPLEX = FULLDUP
            FCHBUF(1,STDOUT) = O"0016 4061 4001 0000 0000"
         ENDIF
         FNWDS(STDOUT) = 1
         CALL FFLUSH(STDOUT)
 
*     RECEIVE-FILE-CONFIGURATION = ON
 
      ELSE IF (MODE .EQ. 'RCV-ON') THEN
         FCSET(STDIN) = CSTXP
         FCHBUF(1,STDOUT) = O"0016 4070 4001 4071 4017"
         FCHBUF(2,STDOUT) = O"4072 4376 4073 4015 4074"
         FCHBUF(3,STDOUT) = O"4000 4106 4001 4061 4000"
         FCHBUF(4,STDOUT) = O"4064 4001 4036 4007 4037"
         FCHBUF(5,STDOUT) = O"4370 0000 0000 0000 0000"
         FNWDS(STDOUT) = 5
         CALL FFLUSH(STDOUT)
 
*     RECEIVE-FILE-CONFIGURATION = OFF
 
      ELSE IF (MODE .EQ. 'RCV-OFF') THEN
         FCSET(STDIN) = CS612
         IF (VALUE .EQ. HALFDUP) THEN
            FCHBUF(1,STDOUT) = O"0016 4064 4000 0000 0000"
            FNWDS(STDOUT) = 1
         ELSE
            FCHBUF(1,STDOUT) = O"0016 4061 4001 4064 4000"
            FCHBUF(2,STDOUT) = O"0000 0000 0000 0000 0000"
            FNWDS(STDOUT) = 2
         ENDIF
         CALL FFLUSH(STDOUT)
 
*     INVALID MODE
 
      ELSE
         CALL DISPLA(' STTY - INVALID MODE ',BOOL(MODE))
         CALL ABORT
 
      ENDIF
 
 
      RETURN
      END
      SUBROUTINE TXTMCMD
 
***   TXTMCMD - PERFORM A SET TEXT-MODE XXXX COMMAND
*
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
      LOGICAL CONFIRM
      PARAMETER (TSIZE=4)
      CHARACTER*10 MODETYP(TSIZE)
      DATA MODETYP / 'AUTO', 'DISPLAY', '6/12-ASCII', '8/12-ASCII'/
 
*     MATCH THE PARAMETER
 
      INDX = MATCH(MODETYP,TSIZE,.FALSE.)
      IF (INDX .LE. 0) RETURN
      IF (.NOT. CONFIRM(CMDFD)) RETURN
 
*     TAKE THE APPROPRIATE ACTION
 
      GO TO (10, 20, 30, 40), INDX
 
*     SET AUTO
 
 10   TXTMODE = CSNONE
      RETURN
 
*     SET DISPLAY CODE
 
 20   TXTMODE = CSDSP
      RETURN
 
*     SET 6/12 ASCII
 
 30   TXTMODE = CS612
      RETURN
 
*     SET 8/12 ASCII
 
 40   TXTMODE = CS812
      RETURN
 
      END
      SUBROUTINE UNGETC(FD,CH)
 
***   UNGETC - PUT A CHARACTER BACK INTO THE INPUT STREAM.
*
*     UNGETC CAN ONLY PUT BACK A SINGLE CHARACTER.
 
      IMPLICIT INTEGER (A-Z)
      PARAMETER (COMLIS = 0)
 
*CALL COMCKER
 
 
      FUNGTCH(FD) = CH
 
 
      RETURN
      END
          IDENT  UVAMISC
          TITLE  UVAMISC - MISCELANEOUS NOS HELPER ROUTINES
          COMMENT  UVAMISC - MISCELANEOUS NOS HELPER ROUTINES
          B1=1
          SST
 UVAMISC  SPACE  4,10
***       UVAMISC - MISCELANEOUS NOS HELPER ROUTINES.
*
*         MISCELLANEOUS ROUTINES REQUIRED FOR USE OF KERMIT UNDER NOS.
          SPACE  3
          USE /BMESAGE/      BOOLEAN MESSAGE TEXT COMMON BLOCK
 DATE8    MICRO  2,8,$"DATE"$
 VERSDAT  DATA   10H("DATE8") VERSION ASSEMBLE DATE
 VERSSTR  BSS    11           STRING VERSION OF ABOVE
          USE    *
 USTART   SPACE  4,10
          ENTRY  USTART
***       USTART - INITIALIZE TERMINAL PARAMETERS.
*
*         ENTRY  NONE.
*
*         EXIT   (X6) = 0 IF JOB IS *IAOT*.
 
 USTART   SUBR               ENTRY/EXIT
          CSET   ASCII
          PROMPT OFF
          GETJO  EXITFLG
          SA1    EXITFLG
          SX6    X1-IAOT
          EQ     USTARTX     RETURN
 NODROP   SPACE  4,10
          ENTRY  NODROP
***       NODROP - SET FILE STATUS TO AUTO-DROP.
*
*         SET AUTO-DROP STATUS ON A FILE.  THIS CLEARS SSST STATUS
*         WHICH IS SET FOR EVERY FILE CREATED BY AN SSJ= BLOCK PROGRAM.
*         SSST CAUSES FILES TO BE DROPPED AT END OF JOB STEP.
*
*         ENTRY  (X1) = FWA OF FET.
*
*         EXIT   NONE.
 
 NODROP   SUBR               ENTRY/EXIT
          BX5    X1
          SETFS  X5,AD
          EQ     NODROPX     RETURN
 MFS>     SPACE  4,10
          ENTRY  MFS>
***       MFS> - MAKEFET HELPER.
*
*         ENTRY  (X1) = SOURCE ADDRESS.
*                (B6) = DESTINATION ADDRESS.
*
*         EXIT   NONE.
 
 MFS>     SUBR               ENTRY/EXIT
          SA1    X1
          BX6    X1
          SA6    B6
          SB6    B6+1        REQUIRED BY MAKEFET
          EQ     MFS>X       RETURN
 BTZ>     SPACE  4,10
          ENTRY  BTZ>
***       BTZ> - CONVERT BLANKS TO ZEROS.
*
*         ENTRY  (X1) = WORD TO CONVERT.
*
*         EXIT   (X6) = CONVERTED WORD.
 
 BTZ>     SUBR               ENTRY/EXIT
          SB1    1
          SA2    =10H
          BX4    X1          SAVE INPUT WORD
          SA2    =10H
          BX1    X1-X2       CONVERT BANKS TO ZEROS
          RJ     =XZTB=      (X7) = MASK WITH 77B IN NON-BLANKS
          BX6    X7*X4
          EQ     BTZ>X       RETURN
 RETFILE  SPACE  4,10
          ENTRY  RETFILE
***       RETFILE - RETURN A FILE.
*
*         ENTRY  (X1) = FWA OF FILE NAME.
*
*         EXIT   NONE.
 
 RETFILE  SUBR               ENTRY/EXIT
          SA1    X1          LFN
          RJ     BTZ>
          SX1    B1
          BX6    X6+X1
          SA6    FET
          RETURN FET,R
          EQ     RETFILEX    RETURN
 
 FET      FILEB  RETFILE,1   DUMMY FET
 WAITINP  SPACE  4,8
 
***       LOGICAL FUNCTION WAITINP(ITIME)
*
*         ROUTINE WAITS FOR UP TO *ITIME* SECONDS FOR INPUT TO BE
*         ENTERED AT THE TERMINAL. RETURNS .FALSE. IF ROUTINE TIMES OUT.
*
          ENTRY  WAITINP
 
 WAITMS   =      25          WAIT INCREMENT, IN MILLISECONDS.
 NOSLVL   =      "NOSLVL"    OPERATING SYSTEM LEVEL, FROM NOSTEXT.
 
 WAITINP  EQ     *+40000B
          SB1    1
          SX2    1000        CONVERT TO MILLISECONDS
          SA1    X1          GET TIMER VALUE
          IX1    X1*X2
          SX2    WAITMS
          IX5    X1/X2       CHECK/WAIT LOOP COUNTER
 
 WAIT1    WAIT   WAITMS      WAIT A BIT BEFORE CHECKING
          IFGE   NOSLVL,602,1      OLD SYSTEMS DON'T HAVE THIS.
          SYSTEM TLX,R,WAITA,1600B  CHECK TYPE-AHEAD BUFFER
          SA1    WAITA
          SX5    X5-1
          MX6    59          FLAG TRUE
          NZ,X1  WAITINP     GOT INPUT, RETURN
          PL,X5  WAIT1       TRY AGAIN
          MX6    0
          EQ     WAITINP     TIMED OUT
 
 WAITA    CON    1           TYPE-AHEAD PRESENT FLAG (TRUE FOR PRE-602)
 SX12A8   SPACE  4,10
          ENTRY  SX12A8
          ENTRY  DPCA8
***       SX12A8 - CONVERT 6/12 TO 8/12.
*         DPCA8 - CONVERT DISPLAY CODE TO 8/12.
*
*         CONVERT THE 6/12 ASCII DATA IN THE SOURCE WSA (SWSA) TO
*         8/12 ASCII IN THE DESTINATION WSA (DWSA), STOPPING AT
*         AN EOL OR THE END OF SWSA OR END OF DWSA.
*         IT IS ASSUMED THAT SWSA AND DWSA ARE THE SAME LENGTH,
*         FOR SIMPLICITY.  IN FACT, THE CALLER MUST INSURE THIS.
*         TWO WORDS FROM THE WSA ARE MANIPULATED AT ONCE.
*         WD1 IS READ FIRST, FOLLOWED BY WD2.  IF WD2 IS ZERO,
*         THEN A COLON AS THE LAST CHARACTER OF WD1 INDICATES A 66-BIT E
*         WHEN WD1 HAS BEEN PROCESSED, WD2 REPLACES IT AND A NEW WD2
*         IS READ FROM THE WSA.
*         ON ENTRY, STATUS CONTAINS A READC
*         RETURN CODE - 0 FOR TRANSFER COMPLETE (1 LINE READ
*         OR, APPARENTLY, WSA FULL), NEGATIVE IF EOF/EOI, LWA+1
*         OF DATA IF EOR. READC GUARANTEES AN EOL BYTE EVEN
*         IF DATA IN THE LAST BYTE OF THE WSA MUST BE CLOBBERED.
*         ON EXIT, STATUS=0 IF IT WAS ZERO ON ENTRY, OTHERWISE
*         LWA+1 OF DATA IN DWSA.  IF DWSA IS FILLED COMPLETELY,
*         AN EOL BYTE IS NOT GUARANTEED.
*
*         CALL SX12A8(SWSA,DWSA,WSAL,STATUS)
*
*         THE CALLING SEQUENCE FOR *DPCA8* IS THE SAME, BUT A DIFFERENT
*         CONVERSION TABLE IS USED.
*
*         REGISTER ASSIGNMENTS -
*
*         B2     ESCFLAG (74 OR 76 ESCAPE TABLE ADDRESS)
*         B3     CT (CHARACTER COUNTER)
*         B4     OUT12 BYTE SHIFT COUNT
*         B5     ADDRESS FOR NEXT WORD IN DWSA
*         B6     LWA+1 OF DWSA
*         X1     WD1
*         X2     WD2
*         A2     ADDRESS OF WD2
*         X4     OUT12 WORD UNDER CONSTRUCTION
*
*
*
*         CHARACTER TRANSLATION TABLES.
*
          USE    /CHARCOM/
ASC612    BSS    128
DPCTBL    BSS    128
LASCII    BSS    64
SX1274    BSS    64
SX1276    BSS    64
UASCII    BSS    64
          USE    *
 
SX12A8    SUBR               ENTRY/EXIT
          SB2    B0          PRESET ESCFLAG FOR 6/12 CONVERSION
          RJ     SXXXA8      PERFORM CONVERSION
          EQ     SX12A8X     RETURN
 
 DPCA8    SUBR               ENTRY/EXIT
          SB2    UASCII      PRESET ESCFLAG FOR DPC CONVERSION
          RJ     SXXXA8      PERFORM CONVERSION
          EQ     DPCA8       RETURN
 
 
 SXXXA8   PS                 INTERNAL ENTRY/EXIT
          SB1    1
          MX6    0
          SA6    EXITFLG
          BX7    X1          SAVE FWA OF SWSA FOR A MOMENT
          SA1    A1+B1
          SB5    X1          FWA OF DWSA
          SA1    A1+B1
          SA2    X1          LENGTH OF SWSA/DWSA
          BX6    X2
          SX6    X6-1
          SA6    SWSAREM     INITIALIZE WORDS REMAINING -1
          SB6    X2+B5       SET LWA+1 OF DWSA
          SA1    A1+B1
          BX6    X1
          SA6    STATADR     ADDRESS OF STATUS PARAMETER
          SA2    X7          A2=SOURCE WORD ADDRESS
          BX1    X2          X1=FIRST WD1
          SB4    48          OUT12 SHIFT COUNT
          MX4    0           OUT12 ACCUMULATOR
          SA3    X6          STATUS
          ZR     X3,S1       IF STATUS=0 ON ENTRY
          IX3    X7-X3       - (STATUS-LOCF(SWSA))
          SX6    B5          FWA DWSA
          PL     X3,S16      IF .GE. 0, RETURN STATUS=LOCF(DWSA)
          BX6    -X3         WORD COUNT OF VALID DATA
          SX6    X6-1        ACCOUNT FOR WORD ALREADY PICKED UP
          SA6    SWSAREM
          BX2    X1
S15       BX1    X2          WD1=WD2
S1        SA3    SWSAREM
          ZR     X3,S2       IF NO MORE IN SWSA
          SX6    X3-1
          SA6    A3
          SA2    A2+B1       READ NEXT WD2
          NG     X2,S4       IF COULD BE ALL ONES
          ZR     X2,S3       IF WD2=0
S4        MX0    -12
          BX3    -X0*X1      BYTE 4 OF WD1
          ZR     X3,S3       IF Z-BYTE TERMINATOR IN WD1
          SB3    10          DO 10 CHARACTERS
 
*         WHETHER WD1 CONTAINS AN EOL OR NOT, CT (B3) IS
*         NOW THE NUMBER OF LEFTMOST CHARACTERS IN WD1
*         TO CONVERT.  IF THIS IS THE LAST WORD IN
*         SWSA (NO WD2), OR IF WD1 CONTAINS AN EOL, THE
*         EXIT FLAG HAS BEEN SET TO CAUSE AN EXIT
*         AS SOON AS WD1 IS FINISHED.
 
S8        LX1    6
          MX0    -6
          BX3    -X0*X1      NEXT WD1 CHAR
          NE     B2,S9       IF ESCFLAG<>0
          SX5    X3-76B
          ZR     X5,S10      IF 76B ESCAPE LEADIN
          SX5    X3-74B
          ZR     X5,S11      IF 74B ESCAPE LEADIN
          SA3    UASCII+X3   CONVERT TO 8/12
 
*         X3 IS THE 8/12 ASCII BYTE TO OUTPUT. THE FOLLOWING
*         CODE (CALLED OUT12 JUST TO IDENTIFY IT AS A LOGICAL
*         UNIT) PUTS THE BYTE INTO DWSA.
 
S13       LX3    X3,B4
          BX4    X4+X3       PUT INTO WORD UNDER CONSTRUCTION
          SB4    B4-12
          PL     B4,S14      IF OUT12 WORD NOT FULL
          BX6    X4
          SA6    B5          STORE IN DWSA
          SB5    B5+B1
          EQ     B5,B6,S12   IF DWSA NOW FULL
          MX4    0
          SB4    48          START OVER WITH NEXT WORD
S14       SB3    B3-B1
S7        NE     B3,S8
          SA3    EXITFLG
          ZR     X3,S15      IF NOT TIME TO QUIT
          BX6    X4
          SA6    B5          FINISH LAST WORD
S12       SA1    STATADR
          SA1    X1
          ZR     X1,SXXXA8   IF ZERO ON ENTRY
          SX6    B5
S16       SA1    STATADR
          SA6    X1
          EQ     SXXXA8
 
*         ESCFLAG CONTAINS THE ADDRESS OF THE 74 OR 76 TRANSLATION
*         TABLE, SO LOOK UP THE TRANSLATED CHARACTER AND
*         INDICATE THAT THE ESCAPE SEQUENCE IS DONE BY
*         SETTING ESCFLAG BACK TO ZERO, UNLESS WE ARE DOING DPC
*         CONVERSION.
 
S9        SA3    B2+X3
          SB7    UASCII      CHECK FOR DPC CONVERSION
          EQ     B2,B7,S13   DPC CONVERSION.  DON'T RESET ESCFLAG
          SB2    B0          ESCFLAG=0
          EQ     S13
 
*         IF A 74B IS FOUND, SET ESCFLAG TO THE 74 TRANSLATION TABLE
*         FWA. SIMILARLY FOR 76B.
 
S10       SB2    SX1276
          EQ     S14
S11       SB2    SX1274
          EQ     S14
S2        SX6    B1
          SA6    EXITFLG
          EQ     S4
 
*         WE HAVE FOUND AN EOL. COUNT THE NUMBER OF
*         LEADING NON-ZERO CHARACTERS IN WD1.
 
S3        SX6    B1
          SA6    EXITFLG
          BX5    X1          WD1
          SB7    10          MAX LOOP COUNT
          SB3    B7          INITIALIZE COUNT
          MX0    -6
S6        BX3    -X0*X5      RIGHTMOST WD1 CHAR
          NZ     X3,S7       IF NON-ZERO CHAR
          SB3    B3-B1       COUNT A ZERO CHAR (NEGATIVELY)
          LX5    -6
          SB7    B7-B1
          NE     B7,S6
          EQ     S7
 
EXITFLG   BSS    1           NZ IF TO QUIT AFTER DOING THIS WD1
SWSAREM   BSS    1           WORDS REMAINING TO BE DONE IN SWSA
STATADR   BSS    1           ADDRESS OF STATUS PARAMETER
 A8SX12   SPACE  4,10
          ENTRY  A8SX12
          ENTRY  A8DPC
***       A8SX12 - CONVERT 8/12 TO 6/12.
*         A8DPC - CONVERT 8/12 TO DISPLAY CODE
*
*         CONVERT THE 8/12 ASCII DATA IN SRC TO 6/12 ASCII
*         OR DISPLAY CODE IN THE SAME BUFFER.
*
*         REGISTER ASSIGNMENTS -
*         X0    - MASK(-7)
*         A1/X1 - CURRENT SOURCE WORD
*         X5    - LAST CHARACTER OUTPUT
*         X6    - CURRENT DESTINATION WORD
*         B2    - NUMBER OF BYTES LEFT IN X1
*         B3    - NUMBER OF WORDS REMAINING IN SRC
*         B5    - OUTPUT WORD BYTE SHIFT COUNT
*         B6    - DESTINATION ADDRESS
*         B7    - CONVERSION TABLE ADDRESS
 
A8SX12    SUBR               ENTRY/EXIT
          SB7    ASC612      CONVERT TO 6/12
          RJ     A8XXXX
          EQ     A8SX12      RETURN
 
 A8DPC    SUBR
          SB7    DPCTBL      CONVERT TO DISPLAY CODE
          RJ     A8XXXX
          EQ     A8DPC       RETURN
 
 
 A8XXXX   PS                 INTERNAL ENTRY/EXIT
          SB1    1
          SB6    X1          SRC
          SA1    A1+B1
          SA1    X1
          SB3    X1          N
          EQ     B3,A8XXXX   IF NOTHING TO DO
          SA1    B6          A1=SRC
          SB5    54
          MX6    0           INITIALIZE DESTINATION WORD
          MX0    -7
L2        SB2    5
L1        LX1    12
          BX2    -X0*X1
          ZR     X2,L5
 L11      SA3    B7+X2       CONVERT CHARACTER
          SB4    X3-100B
          PL     B4,L3
L4        RJ     OUT6
          SB2    B2-B1
          NE     B2,L1
L9        SB3    B3-B1
          EQ     B3,EXIT
          SA1    A1+B1
          EQ     L2
 
*         THE TABLE ENTRY INDICATES THE NEED FOR AN
*         ESCAPE SEQUENCE.
 
L3        BX4    X3          SAVE TABLE ENTRY
          AX3    6
          SX3    X3          LEADING CHARACTER (74B OR 76B)
          RJ     OUT6
          MX3    -6
          BX3    -X3*X4      SECOND CHARACTER
          EQ     L4
 
*         CHECK FOR A POSSIBLE EOL BYTE.
 
L5        MX4    -12
          BX4    -X4*X1      ALL 12 BITS OF BYTE
          NZ     X4,L11      IF NOT A 12-BIT ZERO
          RJ     EOL
          EQ     L9
 
EXIT      RJ     EOL
          EQ     A8XXXX
 
*         PUT AN EOL IN THE OUTPUT.
 
EOL       BSS    1
          NZ     X5,EOL1
 
*         THE LAST CHARACTER OUTPUT WAS A COLON. PROTECT IT
*         BY OUTPUTTING A BLANK AFTER IT.
 
          SX3    1R
          RJ     OUT6
EOL1      EQ     B5,L6       IF 66-BIT EOL NEEDED
          SB5    B5-54
          EQ     B5,L7       IF 60-BIT EOL NEEDED
 
*         THE EOL IS OK AS IS IN THE OUTPUT WORD.
 
          EQ     L10
L6        SA6    B6
          SB6    B6+B1
L7        MX6    0
L10       SA6    B6
          SB6    B6+B1
          SB5    54
          EQ     EOL
 
*         PUT A 6-BIT CHAR INTO THE OUTPUT WORD
 
OUT6      BSS    1
          BX5    X3
          LX3    X3,B5
          BX6    X6+X3
          SB5    B5-6
          PL     B5,OUT6
          SA6    B6
          SB6    B6+B1
          SB5    54
          MX6    0
          EQ     OUT6
          END
      LOGICAL FUNCTION WILDMAT(NAME)
 
      CHARACTER NAME*(*)
      INTEGER SEGM(7)
 
*     START OF COMMON BLOCK FOR WILDCARD ROUTINES
 
      COMMON /WILD/ WSEGC, WSEGL(1:7), WFFIX, WLFIX, WCOM
      INTEGER WSEGC, WSEGL
      LOGICAL WFFIX, WLFIX, WCOM
      COMMON /WILDC/ WSEG(1:7)
      CHARACTER WSEG*7
 
*     END OF COMMON BLOCK FOR WILDCARD ROUTINES
 
*
*     DETERMINE FILE NAME STRING LENGTH, CHECK FOR ALL BLANK STRING.
*
      L = INDEX(NAME, ' ')-1
      IF(L .EQ. 0) THEN
         WILDMAT = WCOM
         RETURN
      ELSE IF(L .EQ. -1) THEN
         L = LEN(NAME)
      ENDIF
 
      IPOS = 1
*
*     LOOK FOR FIRST MATCH OF SEGMENT 'ISEG' IN 'NAME'.
*
      DO 10 ISEG = 1, WSEGC
20    CONTINUE
*
*     LOOK FOR MATCH IN 'NAME' FOLLOWING THIS POINT.  IF FAILURE, BUT
*     WE HAVEN'T RUN OUT OF 'NAME' YET, BUMP STARTING POINT AND
*     TRY AGAIN.
*
      SEGM(ISEG) = IPOS
      DO 30 I = 1, WSEGL(ISEG)
      IF((WSEG(ISEG)(I:I).EQ. '?') .OR.
     +   (WSEG(ISEG)(I:I).EQ.NAME(IPOS:IPOS))) THEN
*        PRINT *, 'OK',ISEG, I, IPOS
         IPOS = IPOS + 1
         IF((IPOS.GT.L) .AND. ((ISEG.NE.WSEGC) .OR.
     +      (I.NE.WSEGL(ISEG)))) THEN
            WILDMAT = WCOM
            RETURN
         ENDIF
      ELSE
*        PRINT *, 'NO',ISEG, I, IPOS
         IPOS = SEGM(ISEG)+1
         IF(IPOS .GT. L) THEN
            WILDMAT = WCOM
            RETURN
         ENDIF
         GO TO 20
      ENDIF
30    CONTINUE
*
*     AT THIS POINT, SEGMENT 'ISEG' MATCHES.
*     IF WFFIX, ENSURE FIRST SEGMENT MATCH IS AT START OF NAME.
*     IF WLFIX, ENSURE LAST SEGMENT IS AT END; IF NOT TRY IT.
*
      IF((ISEG.EQ.1) .AND. WFFIX .AND. (SEGM(1).NE.1)) THEN
         WILDMAT = WCOM
         RETURN
      ENDIF
      IF((ISEG.EQ.WSEGC) .AND. WLFIX .AND. (IPOS.NE.L+1)) THEN
         IPOS = L-WSEGL(WSEGC)+1
*        PRINT *, 'LAST SEG RESTART.'
         GOTO 20
      ENDIF
10    CONTINUE
      WILDMAT = (.NOT.WCOM)
*
*     WE HAVE A MATCH.  RETURN.
*
*     PRINT *,WILDMAT,' MATCH ',(SEGM(I),I=1, WSEGC)
      RETURN
      END
      LOGICAL FUNCTION WILDSET(WILDNAM)
 
      CHARACTER *(*) WILDNAM, C*1
      LOGICAL BREAK
      INTEGER SEGS(1:7), SEGE(1:7)
 
*     START OF COMMON BLOCK FOR WILDCARD ROUTINES
 
      COMMON /WILD/ WSEGC, WSEGL(1:7), WFFIX, WLFIX, WCOM
      INTEGER WSEGC, WSEGL
      LOGICAL WFFIX, WLFIX, WCOM
      COMMON /WILDC/ WSEG(1:7)
      CHARACTER WSEG*7
 
*     END OF COMMON BLOCK FOR WILDCARD ROUTINES
 
 
      WSEGC = 0
      BREAK = .TRUE.
      WFFIX = .FALSE.
      WLFIX = .FALSE.
*
*     DETERMINE WILDCARD STRING LENGTH, CHECK FOR ALL BLANK STRING
*
      L = INDEX(WILDNAM, ' ')-1
      IF(L .EQ. -1) L = LEN(WILDNAM)
      WCOM = (WILDNAM(L:L) .EQ. '-')
      IF(WCOM) L = L - 1
      IF(L .EQ. 0) THEN
         WILDSET = .FALSE.
         RETURN
      ENDIF
*
*     EXAMINE WILDCARD STRING.  BREAK INTO SEGMENTS CONSISTING OF
*     A-Z,0-9,? STRINGS, TERMINATING WITH *.
*     IF FIRST PIECE OF STRING IS SEGMENT (NO LEADING *), SET WFFIX.
*     IF LAST PIECE IS SEGMENT, SET WLFIX.
*
      DO 10 I=1, L
      C = WILDNAM(I:I)
      IF(C .EQ. '*') THEN
         BREAK = .TRUE.
      ELSE IF((C.GE.'A'.AND.C.LE.'Z').OR.(C.GE.'0'.AND.C.LE.'9')
     +        .OR. C.EQ.'?') THEN
         IF(I .EQ. 1) WFFIX = .TRUE.
         IF(I .EQ. L) WLFIX = .TRUE.
         IF(BREAK) THEN
            BREAK = .FALSE.
            IF(WSEGC.LT.7) WSEGC = WSEGC+1
            SEGS(WSEGC) = I
            SEGE(WSEGC) = I
         ELSE
            SEGE(WSEGC) = I
         ENDIF
      ELSE
         WILDSET = .FALSE.
         RETURN
      ENDIF
10    CONTINUE
 
*     PRINT *,WSEGC, WFFIX, WLFIX
*
*     KEEP SEGMENTS AND THEIR LENGTHS FOR ROUTINE 'WILDMAT'.
*
      DO 20 I=1, WSEGC
      WSEG(I) = WILDNAM(SEGS(I):SEGE(I))
      WSEGL(I) = SEGE(I)-SEGS(I)+1
*     PRINT '(2I5,2X,A,I5)', SEGS(I), SEGE(I), WSEG(I), WSEGL(I)
20    CONTINUE
 
      WILDSET = .TRUE.
      RETURN
      END
      INTEGER FUNCTION XVFN(LFN)
      CHARACTER LFN*(*)
 
***   XVFN - VERIFY CORRECT FORMAT FOR FILE NAME.
*
*     ON ENTRY, LFN CONTAINS THE FILE NAME LEFT-JUSTIFIED
*     IN DISPLAY CODE AND BLANK-FILLED.
*
*     CALLED ONLY BY SNDFILE AND SERVER.
 
 
      XVFN=0
 
 
      RETURN
      END
