home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / gould2 / gm2kerm.f77 < prev    next >
Text File  |  2020-01-01  |  141KB  |  5,100 lines
  1.       PROGRAM KERMIT
  2.            IMPLICIT NONE
  3. C
  4. C= File transfer program using kermit protocol
  5. C
  6. C
  7. C                  REVISION LIST
  8. C
  9. C     1.0  This Kermit was the direct implemention of the Cyber-170
  10. C          version, University of Texas.  L. Tate, SAI, Sept. 1985.
  11. C
  12. C     2.0  Added the CONNECT, GET, FINISH, BYE commands.  This required
  13. C          significant changes to the io interface.  The local on/off
  14. C          option was also part of this.  L. Tate, SAI, Nov. 1985.
  15. C
  16. C     2.1  Correct bug in SUDT.  When use the SVC 1,X'27' which
  17. C          set full duplex on a terminal it previously used a trashed
  18. C          file control block.  This had caused unpredicatable results
  19. C          in alot of the io including 2 reads pending at once.
  20. C          Correcting this problem allowed removal of HIOALL routine.
  21. C          Files to be read are opened with OPENMODE='R' and files to
  22. C          be written are opened with OPENMODE='U'.  Also added the
  23. C          TAKE command.   L. Tate, SAI, Mar. 1986.
  24. C
  25. C     2.2  Improved receive/get reliablity by moving the terminal
  26. C          reporting to before the ACK/NAK is sent.  The problem seems
  27. C          to have been during the reporting time, the sending flooded
  28. C          the 8-line buffer and caused a break, losing data.  Also
  29. C          corrected error in printl routine which wrote to stdout
  30. C          instead of the parameter fd. L. Tate, SAI, Mar. 1986.
  31. C
  32. C     2.3  Added to SERVER the ability to recognize the I packet.
  33. C          This packet is used by advanced Kermits (2.27 at least)
  34. C          to initialize the Server.
  35. C          Changed the method by which nowait is established so that
  36. C          if ECHO was off for the terminal before kermit operation,
  37. C          it will remain so afterwards.  Good for network operation.
  38. C          Corrected the error reporting code such that now the error
  39. C          messages are produced.  However, they can be very cryptic.
  40. C          What is needed is a general method of handling text, like
  41. C          help messages and error messages, such that memory is not
  42. C          filled but ready access is available.
  43. C          L. TATE, SAI, MAY 1986.
  44. C
  45. C     AS IN TO LFC=UT
  46. C     AS OUT TO LFC=UT
  47. C
  48. C
  49. C
  50.       INCLUDE      'KVER.INS'
  51.       INCLUDE      'KDEF.INS'
  52.       INCLUDE      'KPROT.COM'
  53.       INCLUDE      'KMSG.COM'
  54.       INCLUDE      'KDBUG.COM'
  55. C
  56.       INTEGER      NCMD            ;PARAMETER (NCMD=15)
  57.       CHARACTER*10 CMD(NCMD)       !commands
  58.      $   /'BYE', 'CONNECT','EXIT','FINISH','GET','HELP',
  59.      $    'QUIT','RECEIVE','SEND','SERVER',
  60.      $    'SET', 'SHOW', 'STATUS','TAKE', 'X'/
  61.       INTEGER      NNOLOCAL        ;PARAMETER (NNOLOCAL =  3)
  62.       CHARACTER*63 NOLOCAL (NNOLOCAL)
  63.      $/'This KERMIT does not support the following commands; BYE,',
  64.      $ 'CONNECT, FINISH, and GET.  These commands require KERMIT',
  65.      $ 'to be installed on MPX3.2B or greater.'/
  66.       INTEGER      IDX             !current command
  67.       CHARACTER*80 CMDLIN          !command line that started program
  68.       INTEGER      IOS
  69. C
  70.       INTEGER      MATCH           !get and match command
  71.       INTEGER      OPEN
  72. C
  73.       CALL SLINE(CMDLIN)           !get startup command line
  74.       CALL INIT(CMDLIN)            !pass to initialize
  75. C
  76.       IOS = OPEN('STDIN','R')
  77.       IF (IOS .NE. STDIN) THEN
  78.         CALL PRTMSG(' Cannot open standard input', -IOS)
  79.         STOP
  80.       ENDIF
  81.       IOS = OPEN('STDOUT','W')
  82.       IF (IOS .NE. STDOUT) THEN
  83.         CALL PRTMSG(' Cannot open standard output',-IOS)
  84.         STOP
  85.       ENDIF
  86. C
  87. C initializing program
  88. C
  89.       INPUTFD = OPEN('KERMIT.INI', 'R')
  90.       IF (INPUTFD .LE. 0) INPUTFD = STDIN
  91. C
  92.       CALL PRINTL(STDOUT, VERSION)
  93.       DO, BEGIN
  94.         IF (INPUTFD .EQ. STDIN) THEN
  95.           CALL PUTSTR(STDOUT, PROMPT)
  96.           CALL FLUSH(STDOUT)
  97.         ENDIF
  98.         CALL FLUSH(INPUTFD)
  99.         IDX = MATCH(CMD, NCMD, .TRUE.)
  100.         IF (IDX .EQ. ERROR .OR. IDX .EQ. 0) GOTO 200
  101.         IF (IDX .EQ. EOF) THEN
  102.           IF (INPUTFD .NE. STDIN) THEN
  103.             CALL TAKEDONE
  104.             GOTO 200
  105.           ELSE
  106.             CALL EXITPGM
  107.           ENDIF
  108.         ENDIF
  109.         GOTO (130, 40, 50, 140, 20, 90, 50, 30, 10, 80, 100,
  110.      $        110, 120, 60, 50) IDX
  111. C
  112.  10     CONTINUE                   !send
  113.           CALL SNDFILE
  114.           GOTO 200
  115.  20     CONTINUE                   !get
  116.           IF (.NOT. LOCALON) GOTO 190
  117.           CALL GETFROM
  118.           GOTO 200
  119.  30     CONTINUE                   !receive
  120.           CALL RCVFILE
  121.           GOTO 200
  122.  40     CONTINUE                   !connect
  123.           IF (.NOT. LOCALON) GOTO 190
  124.           CALL CONNECT
  125.           GOTO 200
  126.  50     CONTINUE                   !exit
  127.           CALL EXITPGM
  128.  60     CONTINUE                   !take
  129.           CALL TAKE
  130.           GOTO 200
  131.  80     CONTINUE                   !server
  132.           CALL SERVER
  133.           GOTO 200
  134.  90     CONTINUE                   !help
  135.           CALL HELP
  136.           GOTO 200
  137.  100    CONTINUE                   !set
  138.           CALL SET
  139.           GOTO 200
  140.  110    CONTINUE                   !show
  141.           CALL SHOW
  142.           GOTO 200
  143.  120    CONTINUE                   !status
  144.           CALL STATUS
  145.           GOTO 200
  146.  130    CONTINUE                   !bye
  147.           IF (.NOT. LOCALON) GOTO 190
  148.           CALL BYE
  149.           GOTO 200
  150.  140    CONTINUE                   !finish
  151.           IF (.NOT. LOCALON) GOTO 190
  152.           CALL FINISH
  153.           GOTO 200
  154.  190    CONTINUE                   !no local
  155.           CALL OUTTBL(NOLOCAL, 1, NNOLOCAL)
  156.           GOTO 200
  157.  200    CONTINUE
  158.       ENDDO
  159.       END
  160.       SUBROUTINE INIT(COMLIN)
  161.            IMPLICIT NONE
  162.            CHARACTER*80  COMLIN    !command line of program
  163. C
  164. C= initializes all kermit context
  165. C
  166.       INCLUDE      'KVER.INS'
  167.       INCLUDE      'KDEF.INS'
  168.       INCLUDE      'KDBUG.COM'
  169.       INCLUDE      'KPROT.COM'
  170.       INCLUDE      'KPACK.COM'
  171.       INCLUDE      'KMSG.COM'
  172. C
  173.       INTEGER      I               !index
  174.       CHARACTER*2  MACH            !machine type code
  175. C
  176.       INTEGER      LASTCHR         !last non blank character
  177.       INTEGER      ICHAR           !character to int
  178.       INTEGER      MATCH
  179.       INTEGER      OPEN
  180. C
  181. C dbugcom
  182. C
  183.       CALL M_UPRIV
  184.       CALL BREAKR
  185. C
  186.       DEBUG = .FALSE.              !no debug on
  187.       DBGFD = 0                    !standoutput
  188.       DBGFILE = 'L.KERMLOG'        !standoutput
  189. C
  190. C protcom
  191. C
  192.       PACKET = 0
  193.       RECPACK = 0
  194.       FILESTR = 0
  195.       PSIZE = 0
  196.       PACKNUM = 0
  197.       NUMTRY = 0
  198.       MAXRTRY = MAXTRY
  199.       MAXRINI = MAXINIT
  200.       STATE = C
  201.       IFD = STDIN
  202.       OFD = STDOUT
  203.       COMPORT = 'UT'
  204.       FFD = 0
  205.       DELAYFP =  0
  206.       STARTIM = 0
  207.       ENDTIM = 0
  208.       SCHCNT = 0
  209.       RCHCNT = 0
  210.       SCHOVRH = 0
  211.       RCHOVRH = 0
  212.       ECHO = .FALSE.
  213.       ESCCHR = 29                  ! CONTROL-]
  214.       LOG = .FALSE.
  215.       LFD = 0
  216.       LOGFILE = 'L.SESSION'
  217.       INSTACK = 0                  !initialize stack pointer
  218.       INSTKFD = 0                  !zero stack for good measure
  219. C
  220. C packcom
  221. C
  222.       SYNC = SNDSYNC = SOH
  223.       PACKSIZ = SPKSIZ = MAXPACK
  224.       TIMEOUT = STIMOUT = MYTIME
  225.       NPAD = SPAD = MYPAD
  226.       PADCH = SPADCH = MYPADCH
  227.       EOLCH = SPEOL = MYEOL
  228.       QUOTECH = SPQUOTE = MYQUOTE
  229.       QUOTE8 = S8QUOTE = QUOT8CH
  230.       CHKTYP = SCHKTYP = MYCKTYP
  231.       RESERVE  = UNUSED = 0
  232.       RPREFIX = SREPEAT = PREFXCH
  233. C
  234. C msgcom
  235. C
  236.       IF (LOCALON) THEN
  237.         VERSION = 'Gould KERMIT version 2.3, Local/Remote enabled'
  238.       ELSE
  239.         VERSION = 'Gould KERMIT version 2.3, Local/Remote disabled'
  240.       ENDIF
  241.       CALL GETMACH(MACH)
  242.       PROMPT(1) = NEL
  243.       CALL DPC2AS('kermit-'//MACH//'>', PROMPT(2), 19)
  244.       I = LASTCHR(COMLIN)
  245.       IF (I .GT. 18  ) I = 18
  246.       IF (I .GT. 0) CALL DPC2AS(COMLIN(:I)//'>', PROMPT(2), I+1)
  247. CLT 2.3  FIXED THE LOGIC FOR LNAME
  248.       I = 2
  249.       LNAME = 0
  250.       DO WHILE (PROMPT(I) .NE. ICHAR('>') .AND. I .LT. 21)
  251.         LNAME = LNAME + 1
  252.         NAME(LNAME) = PROMPT(I)
  253.         I = I + 1
  254.       ENDDO
  255. C
  256.       CALL BREAKR
  257.       CALL X:SYNCH
  258. C
  259.       RETURN
  260.       END
  261.       SUBROUTINE EXITPGM
  262.            IMPLICIT NONE
  263. C
  264. C= Exit kermit
  265. C
  266.       INTEGER      I               !index
  267. C
  268.       DO I=1, 10
  269.         CALL CLOSE(I)
  270.       ENDDO
  271.       STOP
  272.       END
  273.       SUBROUTINE RCVFILE
  274.            IMPLICIT NONE
  275. C
  276. C= Top level subroutine to start receive state.
  277. C
  278.       INCLUDE      'KDEF.INS'
  279.       INCLUDE      'KPROT.COM'
  280.       INCLUDE      'KPACK.COM'
  281. C
  282.       INTEGER      RECEIVE         !receive file
  283.       INTEGER      GTTY            !get tty status
  284.       LOGICAL      CONFIRM         !confirm input
  285. C
  286.       IF (.NOT. CONFIRM(INPUTFD)) RETURN
  287. C
  288. C receive file
  289. C
  290.       CALL STTY(IFD, 'BINARY', ON)
  291.       CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
  292.       CALL STTY(IFD, 'NOWAIT', ON)
  293.       IF (INPUTFD .NE. STDIN .AND. OFD .NE. STDOUT) THEN
  294.         CALL PRINTL(STDOUT, 'Receiving file ')
  295.         CALL PUTSTR(STDOUT, FILESTR)
  296.         CALL FLUSH(STDOUT)
  297.       ENDIF
  298.       IF (RECEIVE(R) .EQ. OK) THEN
  299.         CALL PRINTL(STDOUT, 'Receive complete.')
  300.       ELSE
  301.         CALL PRINTL(STDOUT, 'Received failed.')
  302.       ENDIF
  303.       CALL STTY(IFD, 'NOWAIT', OFF)
  304.       CALL STTY(IFD, 'TIMEOUT', 0)
  305.       CALL STTY(IFD, 'BINARY', OFF)
  306.       RETURN
  307.       END
  308.       SUBROUTINE SNDFILE
  309.            IMPLICIT NONE
  310. C
  311. C= Sends a file to other kermit
  312. C
  313.       INCLUDE      'KDEF.INS'
  314.       INCLUDE      'KPROT.COM'
  315.       INCLUDE      'KPACK.COM'
  316. C
  317.       CHARACTER*16 FNAME           !name of file to send
  318.       INTEGER      IRET            !return status
  319. C
  320.       LOGICAL      ISFILE
  321.       INTEGER      SEND
  322. C
  323. C pick up file name and save it for opening later
  324. C
  325.       CALL SETVAL(FILESTR, 'S', IRET, 16, 0, 0,
  326.      $  'Filename to send', .TRUE.)
  327.       IF (IRET .EQ. ERROR) RETURN
  328. C
  329. C check to make sure it's there to send
  330. C
  331.       CALL AS2DPC(FILESTR, FNAME)
  332.       IF (.NOT. ISFILE(FNAME)) THEN
  333.         CALL PRINTL(STDOUT, '?File ')
  334.         CALL PUTSTR(STDOUT, FILESTR)
  335.         CALL PRINT(STDOUT,' is not found.')
  336.         CALL PUTC(STDOUT, NEL)
  337.         RETURN
  338.       ENDIF
  339. C
  340.       CALL STTY(IFD, 'BINARY', ON)
  341.       CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
  342.       CALL STTY(IFD, 'NOWAIT', ON)
  343. C
  344. C delay the first packet
  345. C
  346.       IF (DELAYFP .GT. 0) CALL SLEEP(DELAYFP)
  347. C
  348. C start sending packet
  349. C
  350.       IF (INPUTFD .NE. STDIN .AND. OFD .NE. STDOUT) THEN
  351.         CALL PRINTL(STDOUT, 'Sending file ')
  352.         CALL PUTSTR(STDOUT, FILESTR)
  353.         CALL FLUSH(STDOUT)
  354.       ENDIF
  355.       PACKNUM = 0
  356.       IF (SEND() .EQ. OK) THEN
  357.         CALL PRINTL(STDOUT, 'Send complete.')
  358.       ELSE
  359.         CALL PRINTL(STDOUT, 'Send failed.')
  360.       ENDIF
  361.       CALL STTY(IFD, 'NOWAIT', OFF)
  362.       CALL STTY(IFD, 'TIMEOUT', 0)
  363.       CALL STTY(IFD, 'BINARY', OFF)
  364.       RETURN
  365.       END
  366.       SUBROUTINE SERVER
  367.            IMPLICIT NONE
  368. C
  369. C= Start kermit server routine
  370. C
  371. C     The server currently knows about the send and receive packets
  372. C     and also the generic kermit packets logout and finish.
  373. C
  374.       INCLUDE      'KDEF.INS'
  375.       INCLUDE      'KDBUG.COM'
  376.       INCLUDE      'KPROT.COM'
  377.       INCLUDE      'KPACK.COM'
  378. C
  379.       INTEGER      PTYP
  380.       INTEGER      I
  381.       INTEGER      NUM             !packet number
  382.       INTEGER      RECSTAT         !receive status
  383.       INTEGER      SNDSTAT         !send status
  384.       CHARACTER*72 SRVMES (4 )
  385.      $ /'[Kermit server running on Gould host.  Please type your',
  386.      $  'escape sequence to return to your local machine.  Shut',
  387.      $  'down server by typing the Kermit BYE command on your',
  388.      $  'local machine.]'/
  389.       CHARACTER*56    FILENAME
  390. C
  391.       LOGICAL CONFIRM
  392.       INTEGER      RDPACK          !read a packet
  393.       INTEGER      SNDPAR          !build init packet
  394.       INTEGER      GTTY            !get terminal stuff
  395.       INTEGER      RECEIVE         !receive file
  396.       INTEGER      SEND            !send file
  397.       INTEGER      LASTCHR         !last non-blank character
  398.       INTEGER      MAX
  399.       INTEGER      SLEN            !string length
  400.       LOGICAL*1    ISFILE          !does file exist
  401. C
  402.       IF (.NOT. CONFIRM(INPUTFD)) RETURN
  403. C
  404. C initialize msg #, say no tries yet
  405. C
  406.       PACKNUM = 0
  407.       NUMTRY = 0
  408.       CALL OUTTBL(SRVMES, 1, 4)
  409. C
  410.       CALL STTY(IFD, 'BINARY', ON)
  411.       CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
  412.       CALL STTY(IFD, 'NOWAIT', ON)
  413. C
  414.  10   CONTINUE
  415.       PTYP = RDPACK(LEN, NUM, RECPACK)
  416.       IF (PTYP .EQ. S) THEN
  417.         PACKNUM = NUM
  418.         CALL RDPARAM(RECPACK)
  419.         I = SNDPAR(PACKET)
  420.         CALL SNDPACK(Y, PACKNUM, I, PACKET)
  421.         NUMTRY = 0
  422.         PACKNUM = MOD(PACKNUM+1, 64)
  423.         RECSTAT = RECEIVE(F)
  424.         IF (DEBUG(DBGON)) THEN
  425.           IF (RECSTAT .EQ. ERROR) THEN
  426.             CALL PRINTL(DBGFD, 'Receive failed.')
  427.           ELSE
  428.             CALL PRINTL(DBGFD, 'Receive completed.')
  429.           ENDIF
  430.         ENDIF
  431.       ELSE IF (PTYP .EQ. R) THEN
  432.         I = 0
  433.         CALL STRCPY(RECPACK, FILESTR)
  434.         CALL AS2DPC(FILESTR, FILENAME)
  435.         CALL FILCHK(FILENAME)
  436. C
  437. CLT 2.3 5/12/86 CHECK TO SEE IF FILE EXISTS
  438. C
  439.         IF (ISFILE(FILENAME)) THEN
  440.           CALL DPC2AS(FILENAME, FILESTR, MAX(1,LASTCHR(FILENAME)))
  441.           SNDSTAT = SEND()
  442.           PACKNUM = 0
  443.           IF (DEBUG(DBGON)) THEN
  444.             IF (SNDSTAT .EQ. ERROR) THEN
  445.               CALL PRINTL(DBGFD, 'Send failed.')
  446.             ELSE
  447.               CALL PRINTL(DBGFD, 'Send completed.')
  448.             ENDIF
  449.           ENDIF
  450. CLT 2.3 5/12/86 SEND ERROR PACKET IF NOT FOUND
  451.         ELSE
  452.           CALL DPC2AS('? FILE ', PACKET, 7)
  453.           I = LASTCHR(FILENAME)
  454.           CALL DPC2AS(FILENAME, PACKET(8), I)
  455.           CALL DPC2AS(' NOT FOUND', PACKET(I+8), 10)
  456.           CALL SNDPACK(E, PACKNUM, SLEN(PACKET), PACKET)
  457.         ENDIF
  458.       ELSE IF (PTYP .EQ. G) THEN
  459.         IF (RECPACK(1) .EQ. L) THEN
  460.           CALL SNDPACK(Y, NUM, 0, 0)
  461.           CALL STTY(IFD, 'NOWAIT', OFF)
  462.           CALL STTY(IFD, 'TIMEOUT', 0)
  463.           CALL STTY(IFD, 'BINARY', OFF)
  464.           CALL EXITPGM   !LOGOUT
  465.         ELSE IF (RECPACK(1) .EQ. F) THEN
  466.           CALL SNDPACK(Y, NUM, 0, 0)
  467.           CALL STTY(IFD, 'NOWAIT', OFF)
  468.           CALL STTY(IFD, 'TIMEOUT', 0)
  469.           CALL STTY(IFD, 'BINARY', OFF)
  470.           CALL EXITPGM
  471. C
  472. CLT 2.3 5/12/86 SEND ERROR MESSAGE FOR UNSUPPORTED COMMAND
  473. C
  474.         ELSE
  475.           CALL DPC2AS('? UNSUPPORTED SERVER COMMAND', PACKET, 28)
  476.           CALL SNDPACK(E, PACKNUM, SLEN(PACKET), PACKET)
  477.         ENDIF
  478. C
  479. CLT 2.3 5/8/86 RECEIVE SERVER INIT PACKET
  480. C
  481.       ELSE IF (PTYP .EQ. ITYP) THEN
  482.         PACKNUM = NUM
  483.         CALL RDPARAM(RECPACK)
  484.         I = SNDPAR(PACKET)
  485.         CALL SNDPACK(Y, PACKNUM, I, PACKET)
  486. C
  487. CLT END
  488. C
  489.       ELSE
  490. CLT 2.3 5/12/86 Added error message for unrecognized packet
  491.         CALL DPC2AS('? UNRECOGNIZED SERVER PACKET',PACKET,28)
  492.         CALL SNDPACK(E,PACKNUM, SLEN(PACKET), PACKET)
  493.         IF (DEBUG(DBGON)) THEN
  494.           CALL PRINTL(DBGFD, 'server: invalid packet type: ')
  495.           CALL PUTINT(DBGFD, PTYP, 1)
  496.           CALL FLUSH(DBGFD)
  497.         ENDIF
  498.       ENDIF
  499.       GOTO 10
  500.       END
  501.       SUBROUTINE SET
  502.            IMPLICIT NONE
  503. C
  504. C= Set some attributes.
  505. C
  506.       INCLUDE      'KVER.INS'
  507.       INCLUDE      'KDEF.INS'
  508.       INCLUDE      'KPROT.COM'
  509.       INCLUDE      'KPACK.COM'
  510. C
  511.       INTEGER      TSIZE           !set commands
  512.         PARAMETER (TSIZE = 10)
  513.       CHARACTER*10 SETTYP(TSIZE)
  514.      $ /'DEBUG','DELAY','ECHO', 'ESCAPE',
  515.      $          'INIT-RETRY','LOG','PORT','RECEIVE','RETRY','SEND'/
  516.       INTEGER      NNOLOCAL        ;PARAMETER (NNOLOCAL = 3 )
  517.       CHARACTER*63 NOLOCAL (NNOLOCAL)
  518.      $/'This KERMIT does not support the following SET commands;',
  519.      $ 'PORT and LOG.  These commands require KERMIT to be installed',
  520.      $ 'on MPX3.2B or greater.'/
  521.       INTEGER      INDX
  522.       INTEGER      ESIZE           ;PARAMETER (ESIZE = 2)
  523.         CHARACTER*3 ECHOTYP(ESIZE) /'OFF','ON'/
  524.       CHARACTER*63 HLPASCH/
  525.      $'Decimal, octal (O), or hexidecimal (H) code for ASCII character'
  526.      $/
  527. C
  528.       INTEGER      MATCH
  529. C
  530.       INDX = MATCH (SETTYP, TSIZE, .FALSE.)
  531.       IF (INDX .LE. 0) RETURN
  532.       GOTO (10, 20, 23, 27, 30, 80, 70, 40, 50, 60) INDX
  533. C
  534. C set debugging modes
  535. C
  536.  10   CONTINUE                     !debug
  537.       CALL DBUGCMD
  538.       RETURN
  539. C
  540.  20   CONTINUE                     !set first packet delay
  541.       CALL SETVAL(DELAYFP,'I',0,60,0,60,
  542.      $ 'Number of seconds to delay first packet', .TRUE.)
  543.       RETURN
  544. C
  545.  23   CONTINUE                     !set echo on/off
  546.       INDX = MATCH(ECHOTYP, ESIZE, .TRUE.)
  547.       IF (INDX .LE. 0) RETURN
  548.       ECHO = INDX .EQ. 2
  549.       RETURN
  550. C
  551.  27   CONTINUE                     !escape
  552.       CALL SETVAL(ESCCHR, 'I', 0, 31, 0, 31, HLPASCH, .TRUE.)
  553.       RETURN
  554. C
  555.  30   CONTINUE                     ! set initial packet retry count
  556.       CALL SETVAL(MAXRINI,'I',1,50,1,50,
  557.      $   'Initial packet retry count', .TRUE.)
  558.       RETURN
  559. C
  560.  40   CONTINUE                     !set receive packet attributes
  561.       CALL SETPACK(PACKSIZ)
  562.       RETURN
  563. C
  564.  50   CONTINUE                     !set packet retry count
  565.       CALL SETVAL(MAXRTRY, 'I',1,50,1,50,
  566.      $  'Packet retry count', .TRUE.)
  567.       RETURN
  568. C
  569.  60   CONTINUE                     !set send packet attributes
  570.       CALL SETPACK(SPKSIZ)
  571.       RETURN
  572. C
  573.  70   CONTINUE                     !set port
  574.       IF (.NOT. LOCALON) GOTO 90
  575.       CALL PORTCMD
  576.       RETURN
  577. C
  578.  80   CONTINUE                     !set log
  579.       IF (.NOT. LOCALON) GOTO 90
  580.       CALL LOGGER
  581.       RETURN
  582. C
  583.  90   CONTINUE                     !no local
  584.       CALL OUTTBL(NOLOCAL, 1, NNOLOCAL)
  585.       RETURN
  586.       END
  587.       SUBROUTINE SHOW
  588.            IMPLICIT NONE
  589. C
  590. C= Show the current program settings
  591. C
  592.       INCLUDE      'KVER.INS'
  593.       INCLUDE      'KDEF.INS'
  594.       INCLUDE      'KPROT.COM'
  595.       INCLUDE      'KPACK.COM'
  596.       INCLUDE      'KDBUG.COM'
  597.       INCLUDE      'KMSG.COM'
  598. C
  599.       INTEGER      MM,DD,YY,HR,MIN,SEC
  600. C
  601.       INTEGER      CTL
  602.       LOGICAL      CONFIRM
  603. C
  604.       IF (.NOT. CONFIRM(INPUTFD)) RETURN
  605.       CALL PRINTL(STDOUT, VERSION)
  606. C
  607. C display current date and time
  608. C
  609.       CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
  610.       CALL PUTC(STDOUT, NEL)
  611.       CALL PUTDAY(STDOUT, MM, DD, YY)
  612.       CALL PRINT(STDOUT,', ')
  613.       CALL PUTMNTH(STDOUT,MM)
  614.       CALL PUTC(STDOUT,' ')
  615.       CALL PUTINT(STDOUT,DD, 1)
  616.       CALL PRINT(STDOUT,', ')
  617.       CALL PUTINT(STDOUT,YY, 1)
  618.       CALL PUTC(STDOUT,' ')
  619.       IF (HR .LT. 10) CALL PRINT(STDOUT,'0')
  620.       CALL PUTINT(STDOUT,HR,1)
  621.       CALL PUTC(STDOUT,':')
  622.       IF (MIN .LT. 10) CALL PRINT(STDOUT,'0')
  623.       CALL PUTINT(STDOUT,MIN,1)
  624.       CALL PUTC(STDOUT,':')
  625.       IF (SEC .LT. 10) CALL PRINT(STDOUT,'0')
  626.       CALL PUTINT(STDOUT,SEC,1)
  627. C
  628. C display current debug modes
  629. C
  630.       CALL PRINTL(STDOUT,'Debugging: ')
  631.       IF (DEBUG(DBGSTAT)) CALL PRINT(STDOUT,'States ')
  632.       IF (DEBUG(DBGPACK)) CALL PRINT(STDOUT,'Packets ')
  633.       IF (.NOT. DEBUG(DBGON)) CALL PRINT(STDOUT,'Off ')
  634.       IF (DEBUG(DBGON)) THEN
  635.         CALL PRINT(STDOUT,'  Debug log file: '//DBGFILE)
  636.       ENDIF
  637. C
  638. C session log
  639. C
  640.       IF (LOCALON) THEN
  641.         CALL PRINTL(STDOUT, 'Session log: ')
  642.         IF (LOG) THEN
  643.           CALL PRINT(STDOUT, 'ON')
  644.         ELSE
  645.           CALL PRINT(STDOUT, 'OFF')
  646.         ENDIF
  647.         IF (LOGFILE .NE. ' ') THEN
  648.           CALL PRINT( STDOUT, '  Session log file: ')
  649.           CALL PRINT(STDOUT, LOGFILE)
  650.         ENDIF
  651.       ENDIF
  652. C
  653. C display current port
  654. C
  655.       IF (LOCALON) THEN
  656.         CALL PRINTL(STDOUT, 'Selected Communications port: ')
  657.         CALL PRINT (STDOUT, COMPORT)
  658.         CALL PRINTL(STDOUT, 'Connection escape character: ^')
  659.         CALL PUTC(STDOUT, CTL(ESCCHR))
  660.         CALL PRINTL(STDOUT, 'Local echo: ')
  661.         IF (ECHO) THEN
  662.           CALL PRINT(STDOUT, 'ON')
  663.         ELSE
  664.           CALL PRINT(STDOUT, 'OFF')
  665.         ENDIF
  666.       ENDIF
  667. C
  668. C display packet settings
  669. C
  670.       CALL PRINTL(STDOUT,'Packet Parameters')
  671.       CALL PRINTL(STDOUT,
  672.      $   '                    Receive   Send')
  673.       CALL PRINTL(STDOUT,'  Size:             ')
  674.       CALL PUTINT(STDOUT,PACKSIZ,10)
  675.       CALL PUTINT(STDOUT,SPKSIZ,10)
  676.       CALL PRINTL(STDOUT,'  Timeout:          ')
  677.       CALL PUTINT(STDOUT,TIMEOUT,10)
  678.       CALL PUTINT(STDOUT,STIMOUT,10)
  679.       CALL PRINTL(STDOUT,'  Padding:          ')
  680.       CALL PUTINT(STDOUT,NPAD,10)
  681.       CALL PUTINT(STDOUT,SPAD,10)
  682.       CALL PRINTL(STDOUT,'  Pad character:    ')
  683.       CALL PUTC(STDOUT,'^')
  684.       CALL PUTC(STDOUT,CTL(PADCH))
  685.       CALL PRINT(STDOUT,'        ')
  686.       CALL PUTC(STDOUT,'^')
  687.       CALL PUTC(STDOUT,CTL(SPADCH))
  688.       CALL PRINTL(STDOUT,'  End-of-Line:      ')
  689.       CALL PUTC(STDOUT,'^')
  690.       CALL PUTC(STDOUT,CTL(EOLCH))
  691.       CALL PRINT(STDOUT,'        ')
  692.       CALL PUTC(STDOUT,'^')
  693.       CALL PUTC(STDOUT,CTL(SPEOL))
  694.       CALL PRINTL(STDOUT,'  Control quote:    ')
  695.       CALL PUTC(STDOUT,QUOTECH)
  696.       CALL PRINT(STDOUT,'         ')
  697.       CALL PUTC(STDOUT,SPQUOTE)
  698.       CALL PRINTL(STDOUT,'  Start-of-Packet:  ')
  699.       CALL PUTC(STDOUT,'^')
  700.       CALL PUTC(STDOUT,CTL(SYNC))
  701.       CALL PRINT(STDOUT,'        ')
  702.       CALL PUTC(STDOUT,'^')
  703.       CALL PUTC(STDOUT,CTL(SNDSYNC))
  704. C
  705. C display protocol stuff
  706. C
  707.       CALL PRINTL(STDOUT,'Delay before sending first packet: ')
  708.       CALL PUTINT(STDOUT,DELAYFP,1)
  709.       CALL PRINTL(STDOUT,'Init packet retry count: ')
  710.       CALL PUTINT(STDOUT,MAXRINI,1)
  711.       CALL PRINTL(STDOUT,'Packet retry count: ')
  712.       CALL PUTINT(STDOUT,MAXRTRY,1)
  713.       CALL PUTC(STDOUT,NEL)
  714.       RETURN
  715.       END
  716.       SUBROUTINE STATUS
  717.            IMPLICIT NONE
  718. C
  719. C= Tell how long last transfer took.
  720. C
  721.       INCLUDE      'KVER.INS'
  722.       INCLUDE      'KDEF.INS'
  723.       INCLUDE      'KPROT.COM'
  724.       INCLUDE      'KPACK.COM'
  725.       INCLUDE      'KTIME.COM'
  726. C
  727.       INTEGER      HR,MIN,SEC
  728.       INTEGER      NSEC
  729. C
  730.       LOGICAL      CONFIRM
  731. C
  732. C confirm the command
  733. C
  734.       IF (.NOT. CONFIRM(INPUTFD)) RETURN
  735. C
  736.       CALL PRINTL(STDOUT,'Max characters in packet: ')
  737.       CALL PUTINT(STDOUT, PACKSIZ, 1)
  738.       CALL PRINT(STDOUT,' received; ')
  739.       CALL PUTINT(STDOUT, SPKSIZ, 1)
  740.       CALL PRINT(STDOUT,' sent')
  741.       CALL PUTC(STDOUT,NEL)
  742.       IF (ENDTIM .LT. STARTIM) ENDTIM = ENDTIM + 86400
  743.       NSEC = ENDTIM - STARTIM
  744.       HR = NSEC / 3600
  745.       NSEC = NSEC - (HR * 3600)
  746.       MIN = NSEC / 60
  747.       NSEC = NSEC - (MIN * 60)
  748.       CALL PRINTL(STDOUT,'Number of characters transmitted in ')
  749.       IF (HR .GT. 0) THEN
  750.         CALL PUTINT(STDOUT,HR,1)
  751.         CALL PRINT(STDOUT,' hours ')
  752.       ENDIF
  753.       IF (MIN .GT. 0 .OR. HR .GT. 0) THEN
  754.         CALL PUTINT(STDOUT,MIN,1)
  755.         CALL PRINT(STDOUT,' minutes ')
  756.       ENDIF
  757.       CALL PUTINT(STDOUT,NSEC,1)
  758.       CALL PRINT(STDOUT,' seconds')
  759.       CALL PRINTL(STDOUT,'             Sent:  ')
  760.       CALL PUTINT(STDOUT, SCHCNT, 20)
  761.       CALL PRINT(STDOUT,' Overhead:  ')
  762.       CALL PUTINT(STDOUT, SCHOVRH, 1)
  763.       CALL PRINTL(STDOUT,'         Received:  ')
  764.       CALL PUTINT(STDOUT, RCHCNT, 20)
  765.       CALL PRINT(STDOUT,' Overhead:  ')
  766.       CALL PUTINT(STDOUT, RCHOVRH, 1)
  767.       CALL PRINTL(STDOUT,'Total Transmitted:  ')
  768.       CALL PUTINT(STDOUT, RCHCNT+SCHCNT, 20)
  769.       CALL PRINT(STDOUT,' Overhead:  ')
  770.       CALL PUTINT(STDOUT, RCHOVRH+SCHOVRH, 1)
  771.       CALL PUTC(STDOUT, NEL)
  772.       CALL PRINTL(STDOUT,'Total characters transmitted per sec: ')
  773.       CALL PUTINT(STDOUT,(SCHCNT+RCHCNT)/(ENDTIM-STARTIM),1)
  774.       CALL PRINTL(STDOUT,'Effective data rate: ')
  775.       CALL PUTINT(STDOUT,((SCHCNT+RCHCNT)-(SCHOVRH+RCHOVRH)) /
  776.      $                    (ENDTIM-STARTIM) * 10, 1)
  777.       CALL PRINT(STDOUT,' baud')
  778.       CALL FLUSH(STDOUT)
  779.       IF (STATE .NE. C) THEN
  780.         CALL GETEMSG(PACKET)
  781.         CALL PRINTL(STDOUT,'?Kermit:  ')
  782.         CALL PUTSTR(STDOUT, PACKET)
  783.         CALL FLUSH(STDOUT)
  784.       ENDIF
  785. C
  786. C timing
  787. C
  788.       IF (LOCALON) THEN
  789.         CALL PRINTL(STDOUT, 'Connect timing averages: ')
  790.         CALL PRINT(STDOUT, 'GETC ')
  791.         CALL PUTINT(STDOUT, GETIME/GETCOUNT, 5)
  792.         CALL PRINT(STDOUT, ' PUTC ')
  793.         CALL PUTINT(STDOUT, PUTIME/PUTCOUNT, 5)
  794.         CALL PRINT(STDOUT, ' WAIT ')
  795.         CALL PUTINT(STDOUT, WAITIME/WAITCNT, 5)
  796.         CALL PRINT(STDOUT, ' TOTAL ')
  797.         CALL PUTINT(STDOUT, TOTIME, 5)
  798.       ENDIF
  799.       RETURN
  800.       END
  801.       SUBROUTINE DBUGCMD
  802.            IMPLICIT NONE
  803. C
  804. C= Set the debugging modes.
  805. C
  806.       INCLUDE      'KDEF.INS'
  807.       INCLUDE      'KPROT.COM'
  808.       INCLUDE      'KDBUG.COM'
  809. C
  810.       INTEGER      DEBUGFN(17)     !file name
  811.       INTEGER      TSIZE           ;PARAMETER (TSIZE = 5)
  812.       CHARACTER*10 DBGTYP(TSIZE)
  813.      $ /'ALL','LOG-FILE','OFF','PACKETS','STATES'/
  814.       INTEGER      INDX
  815.       INTEGER      IRET
  816. C
  817.       INTEGER      MATCH
  818.       LOGICAL      CONFIRM
  819.       INTEGER      OPEN
  820. C
  821.       INDX = MATCH(DBGTYP, TSIZE, .FALSE.)
  822.       IF (INDX .LE. 0) RETURN
  823.       GOTO (10, 20, 30, 40, 50) INDX
  824. C
  825.  10   CONTINUE                     !set all debug modes
  826.       DEBUG = .TRUE.
  827.       GOTO 100
  828. C
  829.  20   CONTINUE                     !set logfile
  830.       CALL SETVAL(DEBUGFN, 'S', IRET, 16, 0, 0,
  831.      $       'Debug output logfile specification', .TRUE.)
  832.       IF (IRET .EQ. OK) THEN
  833.         CALL AS2DPC(DEBUGFN, DBGFILE)
  834.         IF (DBGFD .NE. 0) THEN
  835.           CALL CLOSE(DBGFD)
  836.           DBGFD = 0
  837.         ENDIF
  838.         GOTO 100
  839.       ENDIF
  840.       RETURN
  841. C
  842.  30   CONTINUE                     !turn off all debugging
  843.         DEBUG = .FALSE.
  844.         RETURN
  845. C
  846.  40   CONTINUE                     !toggle debug packets
  847.         IF (.NOT. CONFIRM(INPUTFD))RETURN
  848.         DEBUG(DBGPACK) = .NOT. DEBUG(DBGPACK)
  849.         DEBUG(DBGON) = DEBUG(DBGPACK) .OR. DEBUG(DBGSTAT)
  850.         GOTO 100
  851. C
  852.  50   CONTINUE                     !toggle debug states
  853.         IF (.NOT. CONFIRM(INPUTFD)) RETURN
  854.         DEBUG(DBGSTAT) = .NOT. DEBUG(DBGSTAT)
  855.         DEBUG(DBGON) = DEBUG(DBGPACK) .OR. DEBUG(DBGSTAT)
  856.         GOTO 100
  857. C
  858.  100  CONTINUE                     !open the debug file in not done
  859.         IF (DBGFD .EQ. 0) THEN
  860.           DBGFD = OPEN(DBGFILE, 'W')
  861.         ENDIF
  862.       RETURN
  863.       END
  864.       SUBROUTINE SETPACK(ATTR)
  865.            IMPLICIT NONE
  866.            INTEGER  ATTR(12)       !attributes
  867. C
  868. C= Set packet send or receive attributes.
  869. C
  870. C  Setpack will wet the attributes of the passed attribute list.
  871. C  This subroutine will set the appropriate packet parameter.
  872. C  The parameter to set is passed in an array and is very order
  873. C  dependent.  See common block /packet/ for the ordering.
  874. C  Note that send and receive parameter ordering and storage
  875. C  size in the common block are identical.  Keep it that way!
  876. C
  877.       INCLUDE      'KDEF.INS'
  878. C
  879.       INTEGER      TSIZE           ;PARAMETER (TSIZE=7)
  880.       CHARACTER*10 ATTRTYP(TSIZE)  !commands
  881.      $ /'EOL','PACKLEN','PADCHR','PADLEN','QUOTECHR',
  882.      $  'SYNCCHR','TIMEOUT'/
  883.       INTEGER      INDX
  884.       CHARACTER*63 HLPASCH/
  885.      $'Decimal, octal (O), or hexidecimal (H) code for ASCII character'
  886.      $/
  887. C
  888.       INTEGER      MATCH
  889.       LOGICAL      CONFIRM
  890. C
  891.       INDX = MATCH(ATTRTYP, TSIZE, .FALSE.)
  892.       IF (INDX .LE. 0) RETURN
  893.       GOTO (10, 20, 30, 40, 50, 60, 70) INDX
  894. C
  895.  10   CONTINUE                     !set eol character
  896.       CALL SETVAL(ATTR(5), 'I',1,31,127,127,HLPASCH,.TRUE.)
  897.       RETURN
  898. C
  899.  20   CONTINUE                     !set maximum packet length
  900.       CALL SETVAL(ATTR(1), 'I',20,94,20,94,
  901.      $ 'Maximum packet length', .TRUE.)
  902.       RETURN
  903. C
  904.  30   CONTINUE                     !set pad character
  905.       CALL SETVAL(ATTR(4), 'I', 0, 31, 127, 127, HLPASCH, .TRUE.)
  906.       RETURN
  907. C
  908.  40   CONTINUE                     !set pad length
  909.       CALL SETVAL(ATTR(3), 'I', 0, 94, 0, 94,
  910.      $    'Number of pad characters to use', .TRUE.)
  911.       RETURN
  912. C
  913.  50   CONTINUE                     !set quote character
  914.       CALL SETVAL(ATTR(6), 'I',33, 62,  97, 126, HLPASCH, .TRUE.)
  915.       RETURN
  916. C
  917.  60   CONTINUE                     !set sync character
  918.       CALL SETVAL(ATTR(12),'I', 0,127,   0, 127, HLPASCH, .TRUE.)
  919.       RETURN
  920. C
  921.  70   CONTINUE                     !set timeout value
  922.       SETVAL (ATTR(2), 'I', 0, 94, 0, 94,
  923.      $ 'Number of seconds to wait before timeout', .TRUE.)
  924.       RETURN
  925.       END
  926.       SUBROUTINE PORTCMD
  927.            IMPLICIT NONE
  928. C
  929. C= Selects the port to be used.
  930. C
  931.       INCLUDE      'KDEF.INS'
  932.       INCLUDE      'KPROT.COM'
  933. C
  934.       INTEGER      PORTSTR(7)      !port string to read
  935.       CHARACTER*6  PORTNM          !char device name
  936.       CHARACTER*6  PORTWR          !write port
  937.       INTEGER      IRET            !error code
  938.       INTEGER      INEW            !new input
  939.       INTEGER      ONEW            !new output
  940. C
  941.       INTEGER      OPEN            !open port
  942.       INTEGER      XTOI            !hex ascii to integer
  943.       CHARACTER*4  ITOX            !integer to hex ascii
  944. C
  945.       CALL SETVAL(PORTSTR, 'S', IRET, 6, 0, 0,
  946.      $       'Select communication port', .TRUE.)
  947.       IF (IRET .EQ. OK) THEN
  948.         CALL AS2DPC(PORTSTR, PORTNM)
  949. C
  950.         IF (PORTNM .EQ. COMPORT) THEN      !ignore no change
  951.         ELSE
  952. C
  953. C now open
  954. C
  955.           IF (PORTNM .EQ. 'UT') THEN
  956.             IF (IFD .NE. STDIN) CALL CLOSE(IFD)
  957.             IF (OFD .NE. STDOUT) CALL CLOSE(OFD)
  958.             IFD = STDIN
  959.             OFD = STDOUT
  960.             COMPORT = PORTNM
  961.           ELSE
  962.             INEW = OPEN('@'//PORTNM,'R')
  963.             IF (INEW .LE. 0) THEN
  964.               CALL PRINTL(STDOUT, 'Failed to open read channel, code= ')
  965.               CALL PUTINT(STDOUT, -INEW, 3)
  966.               RETURN
  967.             ENDIF
  968.             PORTWR = PORTNM(1:2)
  969.             PORTWR(3:6) = ITOX(XTOI(PORTNM(3:6))+8)
  970.             ONEW = OPEN('@'//PORTWR,'W')
  971.             IF (ONEW .LE. 0) THEN
  972.               CALL CLOSE(INEW)
  973.               CALL PRINTL(STDOUT,'Failed to open write channel,code= ')
  974.               CALL PUTINT(STDOUT, -ONEW, 3)
  975.               RETURN
  976.             ENDIF
  977.             IF (IFD .NE. STDIN) CALL CLOSE(IFD)
  978.             IF (OFD .NE. STDOUT) CALL CLOSE(OFD)
  979.             COMPORT = PORTNM
  980.             IFD = INEW
  981.             OFD = ONEW
  982.           ENDIF
  983.         ENDIF
  984.       ENDIF
  985.       RETURN
  986.       END
  987.       SUBROUTINE CONNECT
  988.            IMPLICIT NONE
  989. C
  990. C= Connects stdin/stdout to in/out port
  991. C
  992.       INCLUDE      'KDEF.INS'
  993.       INCLUDE      'KPROT.COM'
  994.       INCLUDE      'KTIME.COM'
  995. C
  996.       INTEGER      BELL            ;PARAMETER (BELL = X'07')
  997.       INTEGER      ZERO            ;PARAMETER (ZERO = X'30')
  998.       INTEGER      BREAK           ;PARAMETER (BREAK = X'42')
  999.       INTEGER      CLOSE           ;PARAMETER (CLOSE = X'43')
  1000.       INTEGER      QUIT            ;PARAMETER (QUIT = X'51')
  1001.       INTEGER      RESUME          ;PARAMETER (RESUME=X'52')
  1002.       INTEGER      LOWA            ;PARAMETER (LOWA = X'61')
  1003.       INTEGER      LOWZ            ;PARAMETER (LOWZ = X'7A')
  1004.       INTEGER      LOW2UP          ;PARAMETER (LOW2UP = X'20')
  1005.       INTEGER      INCHR           !char from stdin
  1006.       INTEGER      TTCHR           !char from port
  1007.       CHARACTER*10 CNUM            !character
  1008.       CHARACTER*10 CNUM2
  1009.       INTEGER      STIME
  1010.       INTEGER      FTIME
  1011. CLT   LOGICAL      PAUSER                                          !XXX
  1012. CLT   LOGICAL      DUMPER                                          !XXX
  1013. C
  1014.       INTEGER      GETC            !get character
  1015.       LOGICAL      CONFIRM         !confirm connect
  1016.       INTEGER      CTL             !convert ctl to non-control
  1017.       CHARACTER*(*)ITOA
  1018. CLT   LOGICAL      OPTION                                          !XXX
  1019. C
  1020.       IF (.NOT. CONFIRM(INPUTFD)) RETURN
  1021. CLT   PAUSER = OPTION (1)                                          !XXX
  1022. CLT   DUMPER = OPTION (2)                                          !XXX
  1023. C
  1024.       IF (IFD .EQ. STDIN .OR. OFD .EQ. STDOUT) THEN
  1025.         CALL PRINTL(STDOUT, '?No external port selected.')
  1026.         RETURN
  1027.       ENDIF
  1028. C
  1029.       CALL PUTC(STDOUT, NEL)
  1030.       CALL PRINT(STDOUT, '[Connecting to port, type ^')
  1031.       CALL PUTC(STDOUT, CTL(ESCCHR))
  1032.       CALL PRINT(STDOUT, ' C to return to local]')
  1033.       CALL PUTC(STDOUT, NEL)
  1034.       CALL PUTC(STDOUT, NEL)
  1035. C
  1036.       CALL STTY(STDIN, 'BINARY', ON)
  1037.       CALL STTY(STDIN, 'SIZE', 1)
  1038.       CALL STTY(STDOUT, 'SIZE', 1)
  1039.       CALL STTY(STDIN, 'NOWAIT', ON)
  1040.       CALL STTY(STDOUT, 'NOWAIT', ON)
  1041.       CALL STTY(IFD, 'BINARY', ON)
  1042.       CALL STTY(IFD, 'SIZE', 1)
  1043.       CALL STTY(OFD, 'SIZE', 1)
  1044.       CALL STTY(IFD, 'NOWAIT', ON)
  1045.       CALL STTY(OFD, 'NOWAIT', ON)
  1046.       GETIME = PUTIME = 0
  1047.       GETCOUNT = PUTCOUNT = 0
  1048.       WAITIME = WAITCNT = 0
  1049.       CALL MSEC(TOTIME)
  1050. C
  1051.       DO, BEGIN
  1052. CLT     IF (DUMPER) CALL DUMPF('BEGIN')                            !XXX
  1053. CLT     IF (PAUSER) PAUSE BEGIN                                    !XXX
  1054.         CALL MSEC(STIME)
  1055.         INCHR = GETC(STDIN, INCHR)
  1056.         CALL MSEC(FTIME)
  1057. CLT     IF (DUMPER) CALL DUMPF('AFTER STDIN')                      !XXX
  1058.         GETCOUNT = GETCOUNT + 1
  1059.         GETIME = FTIME - STIME + GETIME
  1060.         CALL MSEC(STIME)
  1061.         TTCHR = GETC(IFD, TTCHR)
  1062.         CALL MSEC(FTIME)
  1063.         GETCOUNT = GETCOUNT + 1
  1064.         GETIME = FTIME - STIME + GETIME
  1065. C
  1066. CLT     IF (INCHR .NE. ERROR .OR. TTCHR .NE. ERROR) THEN
  1067. CLT       CNUM = ITOA(INCHR)
  1068. CLT       CNUM2 = ITOA(TTCHR)
  1069. CLT       CALL DISPLAY('KERMIT/CONNECT - PARSE CHARACTER'//CNUM//CNUM2)
  1070. CLT     ENDIF
  1071.         IF (INCHR .EQ. EOF) THEN
  1072. CLT       CALL DISPLAY('KERMIT/CONNECT - EOF')
  1073.           LEAVE
  1074.         ELSE IF (INCHR .EQ. ERROR) THEN
  1075.           CONTINUE
  1076.         ELSE IF (INCHR .EQ. ESCCHR) THEN
  1077.  10       CONTINUE
  1078. CLT       CALL DISPLAY('KERMIT/CONNECT - WAIT FOR NON-ERROR')
  1079.           DO WHILE (GETC(STDIN, INCHR) .EQ. ERROR)
  1080.             CALL IOWAIT(50 )
  1081.           ENDDO
  1082.           IF (INCHR .GE. LOWA .AND. INCHR .LE. LOWZ)
  1083.      $       INCHR = INCHR - LOW2UP
  1084.           CNUM = ITOA(INCHR)
  1085. CLT       CALL DISPLAY('KERMIT/CONNECT - NON-ERROR ='//CNUM)
  1086.           IF (INCHR .EQ. CLOSE) THEN
  1087.             LEAVE
  1088.           ELSE IF (INCHR .EQ. BREAK) THEN
  1089.             CALL SENDBRK(OFD)
  1090.           ELSE IF (INCHR .EQ. ZERO) THEN
  1091.             CALL PUTC(OFD, 0)
  1092.           ELSE IF (INCHR .EQ. QUIT) THEN
  1093.             LOG = .FALSE.
  1094.           ELSE IF (INCHR .EQ. RESUME) THEN
  1095.             IF (FFD .NE. 0) LOG = .TRUE.
  1096.           ELSE IF (INCHR .EQ. ESCCHR) THEN
  1097.             CALL PUTC(OFD, ESCCHR)
  1098.           ELSE IF (INCHR .EQ. QMARK) THEN
  1099.             CALL STTY(STDOUT, 'SIZE', -1)
  1100.             CALL STTY(STDOUT, 'NOWAIT', OFF)
  1101.             CALL PRINTL(STDOUT,'0   Send NULL')
  1102.             CALL PRINTL(STDOUT,'B   Send BREAK')
  1103.             CALL PRINTL(STDOUT,'C   Close connection')
  1104.             CALL PRINTL(STDOUT,'Q   Quit logging')
  1105.             CALL PRINTL(STDOUT,'R   Resume logging')
  1106.             CALL PUTC(STDOUT, NEL)
  1107.             CALL PRINT(STDOUT, '^')
  1108.             CALL PUTC(STDOUT, CTL(ESCCHR))
  1109.             CALL PRINT(STDOUT,'  Send this character')
  1110.             CALL PRINTL(STDOUT,'?   This message')
  1111.             CALL PRINTL(STDOUT,'Command>')
  1112.             CALL STTY(STDOUT, 'NOWAIT', ON)
  1113.             CALL STTY(STDOUT, 'SIZE', 1)
  1114.             GOTO 10
  1115.           ELSE
  1116.             CALL PUTC(STDOUT, BELL)
  1117.           ENDIF
  1118.         ELSE
  1119. CLT       CALL DISPLAY('KERMIT/CONNECT - PUTC OFD')
  1120.           CALL MSEC(STIME)
  1121.           CALL PUTC(OFD, INCHR)
  1122.           CALL MSEC(FTIME)
  1123.           PUTCOUNT = PUTCOUNT + 1
  1124.           PUTIME = PUTIME + FTIME - STIME
  1125.           IF (ECHO) CALL PUTC(STDOUT, INCHR)
  1126.         ENDIF
  1127. C
  1128.         IF (TTCHR .EQ. EOF) THEN
  1129.           CALL PRINTL(STDOUT, '?EOF on port connection')
  1130.           LEAVE
  1131.         ELSE IF (TTCHR .EQ. ERROR) THEN
  1132.           CONTINUE
  1133.         ELSE
  1134. CLT       CALL DISPLAY('KERMIT/CONNECT - PUTC STDOUT')
  1135.           CALL MSEC(STIME)
  1136.           CALL PUTC(STDOUT, TTCHR)
  1137.           CALL MSEC(FTIME)
  1138.           PUTIME = PUTIME + FTIME - STIME
  1139.           PUTCOUNT = PUTCOUNT + 1
  1140.           IF (LOG) THEN
  1141.             IF (TTCHR .GE. BLANK .AND. TTCHR .LT. DEL) THEN
  1142.               CALL PUTC(LFD, TTCHR)
  1143.             ELSE IF (TTCHR .EQ. CR) THEN
  1144.               CALL PUTC(LFD, NEL)
  1145.             ENDIF
  1146.           ENDIF
  1147.         ENDIF
  1148. C
  1149.         CALL MSEC(STIME)
  1150.         IF (TTCHR .EQ. ERROR .AND. INCHR .EQ. ERROR) THEN
  1151.           CALL IOWAIT(50 )
  1152.         ENDIF
  1153.         CALL MSEC(FTIME)
  1154.         WAITIME = WAITIME + FTIME - STIME
  1155.         WAITCNT = WAITCNT + 1
  1156. C
  1157.       ENDDO
  1158. CLT   IF (DUMPER) CALL DUMPF('ENDDO')                              !XXX
  1159. CLT   IF (PAUSER) PAUSE ENDDO                                      !XXX
  1160. C
  1161.       CALL MSEC(FTIME)
  1162.       TOTIME = FTIME - TOTIME
  1163.       CALL FLUSH(IFD)
  1164.       CALL FLUSH(STDIN)
  1165.       CALL STTY(STDIN, 'BINARY', OFF)
  1166.       CALL STTY(STDIN, 'SIZE', 80)
  1167.       CALL STTY(STDOUT, 'SIZE', -1)
  1168.       CALL STTY(STDIN, 'NOWAIT', OFF)
  1169.       CALL STTY(STDOUT, 'NOWAIT', OFF)
  1170.       CALL STTY(IFD, 'BINARY', OFF)
  1171.       CALL STTY(IFD, 'SIZE', -1)
  1172.       CALL STTY(OFD, 'SIZE', -1)
  1173.       CALL STTY(IFD, 'NOWAIT', OFF)
  1174.       CALL STTY(OFD, 'NOWAIT', OFF)
  1175. CLT   IF (DUMPER) CALL DUMPF('EXIT CONNECT')                       !XXX
  1176. C
  1177.       RETURN
  1178.       END
  1179.       SUBROUTINE LOGGER
  1180.            IMPLICIT NONE
  1181. C
  1182. C= Performs log command
  1183. C
  1184.       INCLUDE      'KDEF.INS'
  1185.       INCLUDE      'KPROT.COM'
  1186. C
  1187.       INTEGER      NCMD            ;PARAMETER (NCMD = 3)
  1188.       CHARACTER*8  CMD(NCMD)
  1189.      $   /'LOG-FILE', 'OFF', 'ON'/
  1190.       INTEGER      IRET
  1191.       INTEGER      TSTR(17)     !temp file string
  1192.       INTEGER      INDX
  1193. C
  1194.       INTEGER      MATCH
  1195.       INTEGER      OPEN            !open file
  1196. C
  1197.       INDX = MATCH(CMD, NCMD, .FALSE.)
  1198.       IF (INDX .LE. 0) RETURN
  1199. C
  1200.       GOTO (10, 20, 30) INDX
  1201. C
  1202.  10   CONTINUE
  1203.         CALL SETVAL(TSTR, 'S', IRET, 16, 0, 0,
  1204.      $       'Session log filename', .TRUE.)
  1205.         IF (IRET .EQ. OK) THEN
  1206.           CALL AS2DPC(TSTR, LOGFILE)
  1207.           LFD = OPEN(LOGFILE, 'W')
  1208.           IF (LFD .LE. 0) THEN
  1209.             CALL PRINTL(STDOUT, '?Failed to open session log file ')
  1210.             CALL PUTINT(STDOUT, -LFD, 3)
  1211.             LOG = .FALSE.
  1212.           ELSE
  1213.             LOG = .TRUE.
  1214.           ENDIF
  1215.         ENDIF
  1216.         GOTO 100
  1217. C
  1218.  20   CONTINUE
  1219.         LOG = .FALSE.
  1220.         IF (LFD .GT. 0) CALL CLOSE(LFD)
  1221.         GOTO 100
  1222. C
  1223.  30   CONTINUE
  1224.         IF (LFD .EQ. 0) THEN
  1225.           LFD = OPEN(LOGFILE, 'W')
  1226.           IF (LFD .EQ. ERROR)
  1227.      $      CALL PRINTL(STDOUT, '?Failed to open session log file')
  1228.         ENDIF
  1229.         LOG = LFD .GT. 0
  1230.         GOTO 100
  1231. C
  1232.  100  CONTINUE
  1233.       RETURN
  1234.       END
  1235.       SUBROUTINE FINISH
  1236.           IMPLICIT NONE
  1237. C
  1238. C= Sends finish command to target port
  1239. C
  1240.       INCLUDE      'KDEF.INS'
  1241.       INCLUDE      'KPROT.COM'
  1242.       INCLUDE      'KPACK.COM'
  1243. C
  1244.       INTEGER      PTYP, LEN, NUM
  1245. C
  1246.       LOGICAL      CONFIRM
  1247.       INTEGER      RDPACK
  1248. C
  1249.       IF (.NOT. CONFIRM(INPUTFD)) RETURN
  1250. C
  1251.       IF (IFD .EQ. STDIN ) THEN
  1252.         CALL PRINTL(STDOUT, '?No communication port selected.')
  1253.         RETURN
  1254.       ENDIF
  1255. C
  1256.       CALL STTY(IFD, 'BINARY', ON)
  1257.       CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
  1258.       CALL STTY(IFD, 'NOWAIT', ON)
  1259.       NUMTRY = 0
  1260.       PACKET(1) = F                !f is constant , fort codes as halfw.
  1261.       DO WHILE (NUMTRY .LE. MAXTRY)
  1262.         NUMTRY = NUMTRY + 1
  1263.         CALL SNDPACK(G, 0, 1, PACKET)
  1264.         PTYP = RDPACK(LEN, NUM, RECPACK)
  1265.         IF (PTYP .EQ. Y) LEAVE
  1266.       ENDDO
  1267.       CALL STTY(IFD, 'NOWAIT', OFF)
  1268.       CALL STTY(IFD, 'TIMEOUT', 0)
  1269.       CALL STTY(IFD, 'BINARY', OFF)
  1270.       RETURN
  1271.       END
  1272.       SUBROUTINE BYE
  1273.            IMPLICIT NONE
  1274. C
  1275. C= Sends bye to remote and exits kermit
  1276. C
  1277.       INCLUDE      'KDEF.INS'
  1278.       INCLUDE      'KPROT.COM'
  1279.       INCLUDE      'KPACK.COM'
  1280. C
  1281.  
  1282.       INTEGER      PTYP            !packet type
  1283.       INTEGER      LEN, NUM
  1284. C
  1285.       LOGICAL      CONFIRM
  1286.       INTEGER      RDPACK
  1287. C
  1288.       IF (.NOT. CONFIRM(INPUTFD)) RETURN
  1289. C
  1290.       CALL STTY(IFD, 'BINARY', ON)
  1291.       CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
  1292.       CALL STTY(IFD, 'NOWAIT', ON)
  1293.       IF (IFD .EQ. STDIN ) THEN
  1294.         CALL PRINTL(STDOUT, '?No communication port selected.')
  1295.         RETURN
  1296.       END IF
  1297. C
  1298.       PACKET(1) = L
  1299.       NUMTRY = 0
  1300.       DO WHILE (NUMTRY .LE. MAXTRY)
  1301.         NUMTRY = NUMTRY + 1
  1302.         CALL SNDPACK(G, 0, 1, PACKET)
  1303.         PTYP = RDPACK(LEN, NUM, RECPACK)
  1304.         IF (PTYP .EQ. Y) LEAVE
  1305.       ENDDO
  1306.       CALL STTY(IFD, 'NOWAIT', OFF)
  1307.       CALL STTY(IFD, 'TIMEOUT', 0)
  1308.       CALL STTY(IFD, 'BINARY', OFF)
  1309.       CALL EXITPGM
  1310.       END
  1311.       SUBROUTINE GETFROM
  1312.            IMPLICIT NONE
  1313. C
  1314. C= Get file from remote server
  1315. C
  1316.       INCLUDE      'KDEF.INS'
  1317.       INCLUDE      'KPROT.COM'
  1318.       INCLUDE      'KPACK.COM'
  1319. C
  1320.       INTEGER      IRET            !return status
  1321.       INTEGER      PTYP            !packet type
  1322.       INTEGER      LEN
  1323.       INTEGER      NUM
  1324. C
  1325.       INTEGER      SLEN            !length of string
  1326.       INTEGER      RECEIVE
  1327.       INTEGER      MOD
  1328.       INTEGER      RDPACK          !read packet
  1329.       INTEGER      SNDPAR          !pack send parameters
  1330. C
  1331.       CALL SETVAL(FILESTR, 'S', IRET, 16, 0, 0,
  1332.      $   'Filename to get', .TRUE.)
  1333.       IF (IRET .EQ. ERROR) RETURN
  1334. C
  1335.       IF (IFD .EQ. STDIN) THEN
  1336.         CALL PRINTL(STDOUT, '?No communication port selected.')
  1337.         RETURN
  1338.       END IF
  1339. C
  1340.       IF (INPUTFD .NE. STDIN .AND. OFD .NE. STDOUT) THEN
  1341.         CALL PRINTL(STDOUT, 'Getting file ')
  1342.         CALL PUTSTR(STDOUT, FILESTR)
  1343.         CALL FLUSH(STDOUT)
  1344.       ENDIF
  1345. C
  1346.       CALL STTY(IFD, 'BINARY', ON)
  1347.       CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
  1348.       CALL STTY(IFD, 'NOWAIT', ON)
  1349. C
  1350.       NUMTRY = 0
  1351.       DO WHILE (NUMTRY .LE. MAXRINI)
  1352.         NUMTRY = NUMTRY + 1
  1353.         CALL SNDPACK(R, 0, SLEN(FILESTR), FILESTR)
  1354.         PTYP = RDPACK(LEN, NUM, RECPACK)
  1355.         IF (PTYP .EQ. S) THEN
  1356.           PACKNUM = NUM
  1357.           CALL RDPARAM(RECPACK)
  1358.           LEN = SNDPAR(PACKET)
  1359.           CALL SNDPACK(Y, PACKNUM, LEN, PACKET)
  1360.           NUMTRY = 0
  1361.           PACKNUM = MOD(PACKNUM+1, 64)
  1362.           IF (RECEIVE(F) .EQ. OK) THEN
  1363.             CALL PRINTL(STDOUT, 'Receive complete.')
  1364.           ELSE
  1365.             CALL PRINTL(STDOUT, 'Receive failed.')
  1366.           ENDIF
  1367.           LEAVE
  1368.         ENDIF
  1369.       ENDDO
  1370.       CALL STTY(IFD, 'NOWAIT', OFF)
  1371.       CALL STTY(IFD, 'TIMEOUT', 0)
  1372.       CALL STTY(IFD, 'BINARY', OFF)
  1373.       RETURN
  1374.       END
  1375.       SUBROUTINE TAKE
  1376.            IMPLICIT NONE
  1377. C
  1378. C Provides a means to redirect input to file.
  1379. C
  1380.       INCLUDE      'KDEF.INS'
  1381.       INCLUDE      'KPROT.COM'
  1382. C
  1383.       INTEGER      TAKEFILE(17)    !take file input name
  1384.       CHARACTER*16 CTAKEFIL        !input file name
  1385.       INTEGER      IRET            !return code
  1386.       INTEGER      TAKEFD          !file desc to take from
  1387. C
  1388.       LOGICAL      ISFILE          !check for file existence
  1389.       INTEGER      OPEN
  1390. C
  1391. C
  1392.       CALL SETVAL(TAKEFILE, 'S', IRET, 16, 0, 0,
  1393.      $    'Filename to take commands from',.TRUE.)
  1394.       IF (IRET .EQ. ERROR) RETURN
  1395. C
  1396. C check to make sure it's there
  1397. C
  1398.       CALL AS2DPC(TAKEFILE, CTAKEFIL)
  1399.       IF (.NOT. ISFILE(CTAKEFIL)) THEN
  1400.         CALL PRINTL(STDOUT, '?File ')
  1401.         CALL PUTSTR(STDOUT, TAKEFILE)
  1402.         CALL PRINT(STDOUT, ' is not found.')
  1403.         CALL PUTC(STDOUT, NEL)
  1404.         RETURN
  1405.       ENDIF
  1406. C
  1407. C open file
  1408. C
  1409.       IF (INSTACK .GE. MAXINSTK) THEN
  1410.         CALL PRINTL(STDOUT, '?Exceed input TAKE stack depth.')
  1411.         RETURN
  1412.       ENDIF
  1413.       TAKEFD = OPEN(CTAKEFIL, 'R')
  1414.       IF (TAKEFD .EQ. ERROR) THEN
  1415.         CALL PRINTL(STDOUT, '?Cannot open ')
  1416.         CALL PUTSTR(STDOUT, TAKEFILE)
  1417.         CALL PRINT(STDOUT, '.')
  1418.         CALL PUTC(STDOUT, NEL)
  1419.         RETURN
  1420.       ENDIF
  1421. C
  1422. C remember where was
  1423. C
  1424.       INSTACK = INSTACK + 1
  1425.       INSTKFD(INSTACK) = INPUTFD
  1426. C
  1427. C redirect
  1428. C
  1429.       INPUTFD = TAKEFD
  1430.       RETURN
  1431.       END
  1432.       SUBROUTINE TAKEDONE
  1433.            IMPLICIT NONE
  1434. C
  1435. C= Returns to next level of input file.
  1436. C
  1437.       INCLUDE      'KDEF.INS'
  1438.       INCLUDE      'KPROT.COM'
  1439. C
  1440.       IF (INPUTFD .NE. STDIN) CALL CLOSE(INPUTFD)
  1441.       IF (INSTACK .LE. 0) THEN
  1442.         INSTACK = 0
  1443.         INPUTFD = STDIN
  1444.       ELSE
  1445.         INPUTFD = INSTKFD(INSTACK)
  1446.         INSTACK = INSTACK - 1
  1447.       ENDIF
  1448.       RETURN
  1449.       END
  1450.       INTEGER FUNCTION MATCH (TABLE, TABLEN, NELOK)
  1451.            IMPLICIT NONE
  1452.            CHARACTER*(*) TABLE(*)  !table of commands
  1453.            INTEGER       TABLEN    !number of elements
  1454.            LOGICAL       NELOK
  1455. C
  1456. C= Decides which input came in, handles ? help
  1457. C
  1458.       INCLUDE      'KDEF.INS'
  1459.       INCLUDE      'KPROT.COM'
  1460. C
  1461.       CHARACTER*40  WORD           !word to input
  1462.       INTEGER       ASTR(41)       !ascii string
  1463.       INTEGER      LEN             !length of word
  1464.       INTEGER      T1, T2          !internal indexes
  1465.       INTEGER      CHP             !character pointer
  1466. C
  1467.       INTEGER      GETWORD         !get word from input
  1468. C
  1469.       LEN = GETWORD(INPUTFD, ASTR, 40)
  1470.       IF (LEN .EQ. 0 .OR. LEN .EQ. EOF) THEN
  1471.         MATCH = LEN
  1472.         IF (LEN .EQ. 0 .AND. .NOT. NELOK) THEN
  1473.           MATCH = ERROR
  1474.           CALL PRINTL(STDOUT, '? Null switch or keyword given')
  1475.         ENDIF
  1476.         RETURN
  1477.       ENDIF
  1478.       CALL AS2DPC(ASTR, WORD)
  1479. C
  1480. C begin matching
  1481. C
  1482.       T1 = 1
  1483.       T2 = TABLEN
  1484.       CHP = 1
  1485.       DO WHILE (CHP .LE. LEN)
  1486. C
  1487. C if we find a ?, the give the possiblities
  1488. C
  1489.         IF (WORD(CHP:CHP) .EQ. '?') THEN
  1490.           CALL PRINTL(STDOUT, 'One of the following:')
  1491.           CALL OUTTBL(TABLE, T1, T2)
  1492.           MATCH = ERROR
  1493.           RETURN
  1494.         ENDIF
  1495. C
  1496. C while word is less than lower table entry
  1497. C
  1498.         DO WHILE (WORD(CHP:CHP) .GT. TABLE(T1)(CHP:CHP) .AND.
  1499.      $            T1 .LE. T2)
  1500.           T1 = T1 + 1
  1501.         ENDDO
  1502. C
  1503. C while word is greater than upper table entry
  1504.         DO WHILE (WORD(CHP:CHP) .LT. TABLE(T2)(CHP:CHP) .AND.
  1505.      $           T2 .GE. T1)
  1506.           T2 = T2 - 1
  1507.         ENDDO
  1508. C
  1509. C if we know we have a mismatch
  1510. C
  1511.         IF (T2 .LT. T1) THEN
  1512.           CALL PRINTL(STDOUT, '? Does not match switch or keyword - '//
  1513.      $                WORD)
  1514.           MATCH = ERROR
  1515.           RETURN
  1516.         ENDIF
  1517.         CHP = CHP + 1
  1518.       ENDDO
  1519. C
  1520. C after looking at the whole word, is it still ambiguous
  1521. C
  1522.       IF (T1 .NE. T2) THEN
  1523.         CALL PRINTL(STDOUT, '? Ambigious - '//WORD)
  1524.         MATCH = ERROR
  1525.       ELSE
  1526.         MATCH = T1
  1527.       ENDIF
  1528.       RETURN
  1529.       END
  1530.       SUBROUTINE OUTTBL(TABLE, START, FIN)
  1531.            IMPLICIT NONE
  1532.            CHARACTER*(*) TABLE (*)  !table to output
  1533.            INTEGER  START          !start of table
  1534.            INTEGER FIN             !end of table
  1535. C
  1536. C= Outputs table in table format
  1537. C
  1538.       INCLUDE      'KDEF.INS'
  1539. C
  1540.       INTEGER      ICOL            !column
  1541.       CHARACTER*80 LINE            !output line
  1542.       INTEGER      NCOLS           !number of columns
  1543.       INTEGER      IPOS
  1544.       INTEGER      I
  1545.       INTEGER      COLWID          !width of column
  1546.       INTEGER      NL              !last character in line
  1547.       INTEGER      LINECNT         !count of lines output
  1548. C
  1549.       INTEGER      LASTCHR         !last non-blank character in line
  1550.       LOGICAL      MORE            !continue on
  1551. C
  1552.       LINECNT = 0
  1553.       COLWID = LEN(TABLE) + 2
  1554.       NCOLS = 80 / COLWID
  1555.       LINE = ' '
  1556.       ICOL = 1
  1557.       DO I=START, FIN
  1558.         IPOS = (ICOL - 1) * COLWID + 1
  1559.         LINE (IPOS:) = TABLE(I)
  1560.         ICOL = ICOL + 1
  1561.         IF (ICOL .GT. NCOLS .OR. I .EQ. FIN) THEN
  1562.           NL = LASTCHR(LINE)
  1563.           IF (NL .LE. 0) NL = 1
  1564.           LINECNT = LINECNT + 1
  1565.           IF (LINECNT .GE. 23) THEN
  1566.             IF (.NOT. MORE()) RETURN
  1567.             LINECNT = 0
  1568.           ENDIF
  1569.           CALL PRINTL(STDOUT, LINE(:NL))
  1570.           LINE = ' '
  1571.           ICOL = 1
  1572.         ENDIF
  1573.       ENDDO
  1574.       RETURN
  1575.       END
  1576.       LOGICAL FUNCTION CONFIRM (FD)
  1577.            IMPLICIT NONE
  1578.            INTEGER    FD   !file device
  1579. C
  1580. C= Looks for a newline to confirm command
  1581. C
  1582. C  Confirm will expect that the next token of input be a
  1583. C  newline for confirmation to be true.  If the next token
  1584. C  is a question mark, then confirmation is false and a
  1585. C  "confirm with a carriage return" message will be displayed'
  1586. C  any other text will cause a 'not confirmed text message
  1587. C  to be displayed and confirm will return false
  1588. C
  1589.       INCLUDE      'KDEF.INS'
  1590. C
  1591.       INTEGER      CH              !character input
  1592. C
  1593.       INTEGER      GETC            !get character
  1594. C
  1595.       CONFIRM = .FALSE.
  1596.  10   CONTINUE
  1597.       IF (GETC(FD, CH) .EQ. NEL) THEN
  1598.         CONFIRM = .TRUE.
  1599.       ELSE IF (CH .EQ. EOF) THEN
  1600.         RETURN
  1601.       ELSE IF (CH .EQ. BLANK .OR. CH .EQ. TAB) THEN
  1602.         GOTO 10
  1603.       ELSE IF (CH .EQ. QMARK) THEN
  1604.         CALL PRINTL(STDOUT, 'Confirm with a carriage return')
  1605.       ELSE
  1606.         CALL PRINTL(STDOUT, '? Not confirmed - ')
  1607.  20     CONTINUE
  1608.         CALL PUTC(STDOUT, CH)
  1609.         CH = GETC(FD, CH)
  1610.         IF (CH .NE. NEL .AND. CH .NE. EOF) GOTO 20
  1611.         CALL PUTC(STDOUT, NEL)
  1612.       ENDIF
  1613.       RETURN
  1614.       END
  1615.       SUBROUTINE SETVAL(VAR, VTYP, MN1, MX1, MN2, MX2, HLPMSG,
  1616.      $                   CONFRM)
  1617.            IMPLICIT NONE
  1618.            INTEGER    VAR(41)  !string to fill
  1619.            CHARACTER*1  VTYP    !type of input (s, i)
  1620.            INTEGER      MN1     !error code         minimum value
  1621.            INTEGER      MX1     !length of string   maximum value
  1622.            INTEGER      MN2     !                   minimum value
  1623.            INTEGER      MX2     !                   maximum value
  1624.            CHARACTER*(*) HLPMSG    !help message to output
  1625.            LOGICAL      CONFRM     !must confirm
  1626. C
  1627. C= Reads input of specified type within range of parameters for int.
  1628. C
  1629.       INCLUDE      'KDEF.INS'
  1630.       INCLUDE      'KPROT.COM'
  1631. C
  1632.       INTEGER      STR(41)         !input string
  1633.       INTEGER      LEN
  1634.       INTEGER      I
  1635. C
  1636.       LOGICAL      CONFIRM         !confirm input
  1637.       INTEGER      CTOI            !character to integer
  1638.       INTEGER      GETWORD         !get a word from input
  1639. C
  1640.       LEN = GETWORD(INPUTFD, STR, 40)
  1641.       IF (LEN .EQ. 0 .OR. LEN .EQ. EOF) THEN
  1642.         IF (VTYP .EQ. 'I') THEN
  1643.           CALL PRINTL(STDOUT,'First nonspace character is not a digit')
  1644.         ELSE
  1645.           CALL PRINTL(STDOUT,'Invalid, Missing parameter')
  1646.           MN1 = ERROR
  1647.         ENDIF
  1648.         RETURN
  1649.       ENDIF
  1650.       IF (STR(1) .EQ. QMARK) THEN
  1651.         CALL PRINTL(STDOUT, HLPMSG)
  1652.         CALL FLUSH(INPUTFD)
  1653.         IF (VTYP .EQ. 'S') MN1 = ERROR
  1654.         RETURN
  1655.       ENDIF
  1656. C
  1657. C confirm the request if necessary
  1658. C
  1659.       IF (CONFRM) THEN
  1660.         IF (.NOT. CONFIRM(INPUTFD)) THEN
  1661.           IF (VTYP .EQ. 'S') MN1 = ERROR
  1662.           RETURN
  1663.         ENDIF
  1664.       ENDIF
  1665. C
  1666. C go ahead and set variable
  1667. C
  1668.       IF (VTYP .EQ. 'I') THEN
  1669.         I = CTOI(STR)
  1670.         IF (I .GE. MN1 .AND. I .LE. MX1) THEN
  1671.           VAR(1) = I
  1672.         ELSE IF (I .GE. MN2 .AND. I .LE. MX2) THEN
  1673.           VAR(2) = I
  1674.         ELSE
  1675.           CALL PRINTL(STDOUT, '? Value is not within range of ')
  1676.           CALL PUTINT(STDOUT, MN1, 1)
  1677.           CALL PRINT(STDOUT, '-')
  1678.           CALL PUTINT(STDOUT, MX1, 1)
  1679.           CALL PRINT(STDOUT, ', or ')
  1680.           CALL PUTINT(STDOUT, MN2, 1)
  1681.           CALL PRINT(STDOUT, '-')
  1682.           CALL PUTINT(STDOUT, MX2, 1)
  1683.         ENDIF
  1684.       ELSE
  1685.         DO I=1, LEN
  1686.           VAR(I) = STR(I)
  1687.         ENDDO
  1688.         VAR(LEN+1) = 0
  1689.         MN1 = OK
  1690.       ENDIF
  1691.       RETURN
  1692.       END
  1693.       SUBROUTINE HELP
  1694.            IMPLICIT NONE
  1695. C
  1696. C= Prints help messages
  1697. C
  1698.       INCLUDE      'KVER.INS'
  1699.       INCLUDE      'KDEF.INS'
  1700. C
  1701.       INTEGER      MAXHLPS         ;PARAMETER   (MAXHLPS = 16)
  1702.       CHARACTER*10 HLPCMDS(MAXHLPS)
  1703.      $ /'BYE','CONNECT','EXIT','FINISH','GET','HELP','KERMIT','QUIT',
  1704.      $  'RECEIVE','SEND','SERVER','SET','SHOW','STATUS','TAKE','X'/
  1705. C
  1706. C help send
  1707. C
  1708.       INTEGER      LMES10          ;PARAMETER (LMES10 = 5)
  1709.       CHARACTER*63 MES10  (LMES10)
  1710.      $ /' ' ,
  1711.      $ 'SEND local-filename',
  1712.      $ ' ',
  1713.      $ 'Sends file to remote KERMIT.',
  1714.      $ ' '/
  1715. C
  1716. C help get
  1717. C
  1718.       INTEGER      LMES20          ;PARAMETER (LMES20 = 5)
  1719.       CHARACTER*63 MES20 (LMES20)
  1720.      $ /' ',
  1721.      $ 'GET remote-filename',
  1722.      $ ' ',
  1723.      $ 'Tells a user Kermit to send a file.',
  1724.      $ ' '/
  1725. C
  1726. C help receive
  1727. C
  1728.       INTEGER      LMES30          ;PARAMETER (LMES30 = 5)
  1729.       CHARACTER*63 MES30(LMES30)
  1730.      $ /' ',
  1731.      $ 'RECEIVE',
  1732.      $ ' ',
  1733.      $ 'Expects one or more files to arrive.',
  1734.      $ ' '/
  1735. C
  1736. C help connect
  1737. C
  1738.       INTEGER      LMES40          ;PARAMETER (LMES40 = 17)
  1739.       CHARACTER*63 MES40 (LMES40)
  1740.      $ /' ',
  1741.      $ 'CONNECT',
  1742.      $ ' ',
  1743.      $ 'Enter terminal emulation mode; presents the illusion of',
  1744.      $ 'being directly connected as a terminal to the remote',
  1745.      $ 'system.  When escape character is typed, interprets next',
  1746.      $ 'character as follows:',
  1747.      $ '  0        (zero) Transmits a NUL',
  1748.      $ '  B        Transmits a BREAK',
  1749.      $ '  C        Close a connection, return to local KERMIT',
  1750.      $ '  Q        Quit logging (if logging is being done)',
  1751.      $ '  R        Resume logging',
  1752.      $ '  ?        Show available arguments to the escape character',
  1753.      $ '  (escape character again):  Transmit the escape character',
  1754.      $ '           itself',
  1755.      $ 'Invalid arguements are beeped and reenters connect mode.',
  1756.      $ ' '/
  1757. C
  1758. C help kermit
  1759. C
  1760.       INTEGER      LMES50          ;PARAMETER (LMES50 = 19)
  1761.       CHARACTER*63 MES50(LMES50)
  1762.      $ /' ',
  1763.      $ 'Kermit is a file transfer protocol for use over an',
  1764.      $ 'asynchronous serial telecommunication line.  Files are',
  1765.      $ 'broken up into ""packets"" with checksums and other control',
  1766.      $ 'information to ensure (with high probability) error-free',
  1767.      $ 'and complete transmission.',
  1768.      $ ' ',
  1769.      $ 'This implementation of Kermit is for the GOULD concept32',
  1770.      $ 'computers.  It may be run remotely using a micro or if',
  1771.      $ 'the os is MPX3.2B or greater, may be run locally as a',
  1772.      $ 'terminal emulator',
  1773.      $ ' ',
  1774.      $ 'Commands are: SEND, GET, RECEIVE, CONNECT, EXIT, X, QUIT,',
  1775.      $ 'BYE, FINISH, SERVER, SET, SHOW, STATUS',
  1776.      $ ' ',
  1777.      $ 'For further information, type ""HELP"" for any of the above',
  1778.      $ 'e.g.  ""HELP RECEIVE"" or see the Kermit Users Guide and',
  1779.      $ 'Kermit Protocol manual.',
  1780.      $ ' '/
  1781. C
  1782. C help exit, quit, x
  1783. C
  1784.       INTEGER      LMES60          ;PARAMETER (LMES60 = 3)
  1785.       CHARACTER*63 MES60  (LMES60)
  1786.      $ /' ',
  1787.      $  'Exit from Kermit.',
  1788.      $  ' '/
  1789. C
  1790. C help take
  1791. C
  1792.       INTEGER      LMES70          ;PARAMETER (LMES70 = 5)
  1793.       CHARACTER*63 MES70 (LMES70)
  1794.      $ /' ',
  1795.      $ 'TAKE local-filename',
  1796.      $ ' ',
  1797.      $ 'Read and execute Kermit commands from a local file.',
  1798.      $ ' '/
  1799. C
  1800. C help server
  1801. C
  1802.       INTEGER      LMES90          ;PARAMETER (LMES90=16)
  1803.       CHARACTER*63 MES90 (LMES90)
  1804.      $ /' ',
  1805.      $ 'SERVER',
  1806.      $ ' ',
  1807.      $ 'Act as a server for another Kermit.  Take all further',
  1808.      $ 'commands only from the other Kermit.  After issuing',
  1809.      $ 'this command, escape back to your local system and issue',
  1810.      $ 'SEND or GET, BYE, or other server-oriented',
  1811.      $ 'commands from there.  If your local Kermit does not have',
  1812.      $ 'a BYE command, it does not have the full ability to',
  1813.      $ 'communicate with a Kermit server (in which case you can',
  1814.      $ 'only use the SEND command).  If your local Kermit does',
  1815.      $ 'have a BYE command, use it to shut down and log out',
  1816.      $ 'the Kermit server when you are done with it; otherwise,',
  1817.      $ 'connect back to the Gould, type several Control-C''s to',
  1818.      $ 'stop the server, and logout.',
  1819.      $ ' '/
  1820. C
  1821. C help set
  1822. C
  1823.       INTEGER      LMES100         ;PARAMETER (LMES100=122)
  1824.       CHARACTER*63 MES100(LMES100)
  1825.      $/' ',
  1826.      $ 'SET',
  1827.      $ ' ',
  1828.      $ '  Establish system-dependent parameters.  You can examine',
  1829.      $ 'their values with the SHOW command.  Numeric values may be',
  1830.      $ 'decimal, octal (postfixed with a O), or hexadecimal (post-',
  1831.      $ 'fixed with an H).  The following may be SET:',
  1832.      $ ' ',
  1833.      $ ' DEBUG options',
  1834.      $ '   Show packet traffic explicitly.  Options are:',
  1835.      $ '   ALL      Set all debug options.',
  1836.      $ '   LOG-FILE Log states and packets to the specified file.',
  1837.      $ '            The default log-file is file L.KERMLOG',
  1838.      $ '   OFF      Don''t display debugging information. (this is',
  1839.      $ '            the default).  If debugging was in effect, turn',
  1840.      $ '            it off and close any log file.',
  1841.      $ '   PACKETS  Display each incoming and outgoing packet',
  1842.      $ '            (lengthy)',
  1843.      $ '   STATES   Show kermit state transitions and packet numbers',
  1844.      $ '            (brief).',
  1845.      $ ' ',
  1846.      $ ' LOG options',
  1847.      $ '   Log all inputs from remote port during connection.',
  1848.      $ '   Options are:',
  1849.      $ '   LOG-FILE Log inputs to specified file.  The default',
  1850.      $ '            log-file is file L.SESSION',
  1851.      $ '   OFF      Turn off the session logging',
  1852.      $ '   ON       Turn on the session logging',
  1853.      $ ' ',
  1854.      $ ' PORT terminal-address',
  1855.      $ '   Sets the communicaton port; to which connect, send,',
  1856.      $ '   receive and server interact with.  Any MPX terminal ',
  1857.      $ '   address may be used.  Examples: TY7EC0, U17CC4, or UT.',
  1858.      $ '   Default is UT',
  1859.      $ ' ',
  1860.      $ ' ESCAPE decimal-number',
  1861.      $ '   Control character used to escape from connect mode.',
  1862.      $ '   Default is 29, (^])',
  1863.      $ ' ',
  1864.      $ ' ECHO on/off',
  1865.      $ '   Turns on or off the echo by kermit during connect mode.',
  1866.      $ ' ',
  1867.      $ ' DELAY decimal-number',
  1868.      $ '   How many seconds to wait before sending the first',
  1869.      $ '   packet.  This gives you time to ""escape"" back and',
  1870.      $ '   issue a RECEIVE command.',
  1871.      $ ' ',
  1872.      $ ' INIT-RETRY decimal-number',
  1873.      $ '   Set the maximum number of retries allowed for the',
  1874.      $ '   initial connection before giving up.',
  1875.      $ ' ',
  1876.      $ ' RETRY decimal-number',
  1877.      $ '   Set the maximum number of retries allowed for sending',
  1878.      $ '   a particular packet.',
  1879.      $ ' ',
  1880.      $ ' SEND parameter',
  1881.      $ '   Parameters for outgoing packets as follows:',
  1882.      $ ' ',
  1883.      $ '   EOLCHR  octal-number',
  1884.      $ '     The octal value of the ASCII character to be used',
  1885.      $ '     as a line terminator for packets, if one is required',
  1886.      $ '     by the other system.  Carriage return (15B) by default.',
  1887.      $ ' ',
  1888.      $ '   PACKLEN decimal-number',
  1889.      $ '     Maximum packet length to send, decimal number, between',
  1890.      $ '     20 and 94, 94 by default.',
  1891.      $ ' ',
  1892.      $ '   PADCHR octal-number',
  1893.      $ '     Character to use for padding.  Default is NUL.',
  1894.      $ ' ',
  1895.      $ '   PADLEN decimal-number',
  1896.      $ '     How much padding to send before a packet.  Default',
  1897.      $ '     is no padding.',
  1898.      $ ' ',
  1899.      $ '   QUOTECHR octal-number',
  1900.      $ '     What printable character to use for quoting of control',
  1901.      $ '     characters.  The default is ''#'' (43B).  There should',
  1902.      $ '     be no reason to change this.',
  1903.      $ ' ',
  1904.      $ '   SYNCCHR octal-number',
  1905.      $ '     The control character that marks the beginning of the',
  1906.      $ '     packet.  Normally SOH (Control-A, ASCII 1).  There',
  1907.      $ '     should be no reason to change this.',
  1908.      $ ' ',
  1909.      $ '   TIMEOUT decimal-number',
  1910.      $ '     How many seconds the other Kermit wants before being',
  1911.      $ '     asked for retransmission.',
  1912.      $ ' ',
  1913.      $ ' RECEIVE parameter',
  1914.      $ '   Parameters to request or expect for incoming packets,',
  1915.      $ '   as follows:',
  1916.      $ ' ',
  1917.      $ '   EOLCHR  octal-number',
  1918.      $ '     The octal value of the ASCII character to be used',
  1919.      $ '     as a line terminator for packets, if one is required',
  1920.      $ '     by the other system.  Carriage return (15B) by default.',
  1921.      $ ' ',
  1922.      $ '   PACKLEN decimal-number',
  1923.      $ '     Maximum packet length to send, decimal number, between',
  1924.      $ '     20 and 94, 94 by default.',
  1925.      $ ' ',
  1926.      $ '   PADCHR octal-number',
  1927.      $ '     Character to use for padding.  Default is NUL.',
  1928.      $ ' ',
  1929.      $ '   PADLEN decimal-number',
  1930.      $ '     How much padding to send before a packet.  Default',
  1931.      $ '     is no padding.',
  1932.      $ ' ',
  1933.      $ '   QUOTECHR octal-number',
  1934.      $ '     What printable character to use for quoting of control',
  1935.      $ '     characters.  The default is ''#'' (43B).  There should',
  1936.      $ '     be no reason to change this.',
  1937.      $ ' ',
  1938.      $ '   SYNCCHR octal-number',
  1939.      $ '     The control character that marks the beginning of the',
  1940.      $ '     packet.  Normally SOH (Control-A, ASCII 1).  There',
  1941.      $ '     should be no reason to change this.',
  1942.      $ ' ',
  1943.      $ '   TIMEOUT decimal-number',
  1944.      $ '     How many seconds the other Kermit wants before being',
  1945.      $ '     asked for retransmission.',
  1946.      $ ' '/
  1947. C
  1948. C help show
  1949. C
  1950.       INTEGER LMES110              ;PARAMETER (LMES110= 4 )
  1951.       CHARACTER*63 MES110(LMES110) !show help
  1952.      $/' ',
  1953.      $ 'Display current SET parameters, version of Kermit, and',
  1954.      $ 'other info.',
  1955.      $ ' '/
  1956. C
  1957. C help status
  1958. C
  1959.       INTEGER      LMES120         ;PARAMETER (LMES120= 3)
  1960.       CHARACTER*63 MES120(LMES120)
  1961.      $/' ',
  1962.      $ 'Give statistics about the most recent file transfer.',
  1963.      $ ' '/
  1964. C
  1965. C help help
  1966. C
  1967.       INTEGER      LMES130         ;PARAMETER (LMES130=16)
  1968.       CHARACTER*63 MES130 (LMES130)
  1969.      $/' ',
  1970.      $ 'HELP [topic]',
  1971.      $ ' ',
  1972.      $ 'Typing HELP alone prints a brief summary of Kermit',
  1973.      $ 'and its commands.  You can also type',
  1974.      $ ' ',
  1975.      $ '   HELP command',
  1976.      $ ' ',
  1977.      $ 'for any Kermit command, e.g. ""HELP SEND"", to get more',
  1978.      $ 'detailed information about a specific command.  Type',
  1979.      $ ' ',
  1980.      $ '   HELP ?',
  1981.      $ ' ',
  1982.      $ 'to see a list of all the available help commands, or',
  1983.      $ 'consult the Kermit Users Guide.',
  1984.      $ ' '/
  1985.       INTEGER      LMES140         ;PARAMETER (LMES140 =  6 )
  1986.       CHARACTER*63 MES140(LMES140)
  1987.      $ /' ',
  1988.      $  'BYE',
  1989.      $ ' ',
  1990.      $ 'This command sends a message to the remote server to log',
  1991.      $ 'itself out',
  1992.      $ ' '/
  1993.       INTEGER      LMES150         ;PARAMETER (LMES150 =  6 )
  1994.       CHARACTER*63 MES150 (LMES150)
  1995.      $/' ',
  1996.      $ 'FINISH',
  1997.      $ ' ',
  1998.      $ 'This command causes the remote server to shut itself down',
  1999.      $ 'leaving the local KERMIT at KERMIT command level.',
  2000.      $ ' '/
  2001.       INTEGER      LMES160         ;PARAMETER (LMES160 =3 )
  2002.       CHARACTER*63 MES160 (LMES160)
  2003.      $/' ',
  2004.      $ 'This command is cannot be used on this version of KERMIT.',
  2005.      $ ' '/
  2006.       INTEGER      IDX             !index of code
  2007. C
  2008.       INTEGER      MATCH           !command parser
  2009. C
  2010.       IDX = MATCH(HLPCMDS,MAXHLPS,.TRUE.)
  2011.       IF (IDX .EQ. EOF .OR. IDX .EQ. ERROR) RETURN
  2012.       IF (IDX .EQ. 0) GOTO 50
  2013.       GOTO ( 140,40, 60, 150,20, 130, 50, 60, 30, 10, 90,
  2014.      $      100, 110, 120, 70, 60) IDX
  2015.  10   CONTINUE                     !send
  2016.         CALL OUTTBL(MES10, 1, LMES10)
  2017.         GOTO 200
  2018.  20   CONTINUE                     !get
  2019.         IF (.NOT. LOCALON) GOTO 160
  2020.         CALL OUTTBL(MES20, 1, LMES20)
  2021.         GOTO 200
  2022.  30   CONTINUE                     !receive
  2023.         CALL OUTTBL(MES30, 1, LMES30)
  2024.         GOTO 200
  2025.  40   CONTINUE                     !connect
  2026.         IF (.NOT. LOCALON) GOTO 160
  2027.         CALL OUTTBL(MES40, 1, LMES40)
  2028.         GOTO 200
  2029.  50   CONTINUE                     !kermit
  2030.         CALL OUTTBL(MES50, 1, LMES50)
  2031.         GOTO 200
  2032.  60   CONTINUE                     !exit
  2033.         CALL OUTTBL(MES60, 1, LMES60)
  2034.         GOTO 200
  2035.  70   CONTINUE                     !take
  2036.         CALL OUTTBL(MES70, 1, LMES70)
  2037.         GOTO 200
  2038.  90   CONTINUE                     !server
  2039.         CALL OUTTBL(MES90, 1, LMES90)
  2040.         GOTO 200
  2041.  100  CONTINUE                     !set
  2042.         CALL OUTTBL(MES100, 1, LMES100)
  2043.         GOTO 200
  2044.  110  CONTINUE                     !show
  2045.         CALL OUTTBL(MES110, 1, LMES110)
  2046.         GOTO 200
  2047.  120  CONTINUE                     !status
  2048.         CALL OUTTBL(MES120, 1, LMES120)
  2049.         GOTO 200
  2050.  130  CONTINUE                     !help
  2051.         CALL OUTTBL(MES130, 1, LMES130)
  2052.         GOTO 200
  2053.  140  CONTINUE                     !bye
  2054.         IF (.NOT. LOCALON) GOTO 160
  2055.         CALL OUTTBL(MES140, 1, LMES140)
  2056.         GOTO 200
  2057.  150  CONTINUE                     !finish
  2058.         IF (.NOT. LOCALON) GOTO 160
  2059.         CALL OUTTBL(MES150, 1, LMES150)
  2060.         GOTO 200
  2061.  160  CONTINUE                     !no local
  2062.         CALL OUTTBL(MES160, 1, LMES160)
  2063.         GOTO 200
  2064.  200  CONTINUE
  2065.       RETURN
  2066.       END
  2067.       LOGICAL FUNCTION MORE()
  2068.            IMPLICIT NONE
  2069. C
  2070. C= Returns true if continue, else false
  2071. C
  2072.       INCLUDE      'KDEF.INS'
  2073. C
  2074.       INTEGER      INCHR
  2075. C
  2076.       INTEGER      GETC
  2077. C
  2078.       CALL FLUSH(STDIN)
  2079.       CALL STTY(STDIN, 'READSIZE', 1)
  2080.       CALL PRINTL(STDOUT, 'Enter CR for more')
  2081.       MORE = GETC(STDIN, INCHR) .EQ. NEL
  2082.       CALL STTY(STDIN, 'READSIZE', 80)
  2083.       RETURN
  2084.       END
  2085.       INTEGER FUNCTION RECEIVE(ISTATE)
  2086.             IMPLICIT NONE
  2087.             INTEGER    ISTATE      !state to start at
  2088. C
  2089. C= Receive a file state switching routine.
  2090. C
  2091.       INCLUDE      'KDEF.INS'
  2092.       INCLUDE      'KDBUG.COM'
  2093.       INCLUDE      'KPROT.COM'
  2094.       INCLUDE      'KPACK.COM'
  2095.       INCLUDE      'KMSG.COM'
  2096. C
  2097.       INTEGER      MM,DD,YY, HR, MIN, SEC
  2098.       INTEGER      MSG(MAXPACK)
  2099.       INTEGER      I
  2100. C
  2101.       INTEGER      RINIT
  2102.       INTEGER      RDATA
  2103.       INTEGER      RFILE
  2104.       INTEGER      SLEN            !length of string
  2105.       INTEGER      ICHAR           !character to integer
  2106. C
  2107. C
  2108. C initialize statistics variables
  2109. C
  2110.       CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
  2111.       STARTIM = HR*3600 + MIN*60 + SEC
  2112.       SCHCNT = 0
  2113.       RCHCNT = 0
  2114.       SCHOVRH = 0
  2115.       RCHOVRH = 0
  2116.       TOTSDRC = 0
  2117.       TOTRTRY = 0
  2118. CLT 2.3 ZERO ALL PREVIOUS ABORTS
  2119.       ABORTYP = .FALSE.
  2120.       IF (IFD .NE. STDIN) CALL PUTC(STDOUT, NEL)
  2121. C
  2122. C set packet retry count & current state
  2123. C
  2124.       NUMTRY = 0
  2125.       STATE = ISTATE
  2126. C
  2127. C take appropriate action for the current state
  2128. C
  2129.       CALL MONSDRC(STATE)
  2130.  10   CONTINUE
  2131.       IF (STATE .EQ. D) THEN
  2132.         STATE = RDATA()
  2133.       ELSE IF (STATE .EQ. F) THEN
  2134.         STATE = RFILE()
  2135.       ELSE IF (STATE .EQ. R) THEN
  2136.         STATE = RINIT()
  2137.       ELSE IF (STATE .EQ. C) THEN
  2138.         CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
  2139.         ENDTIM = HR * 3600 + MIN * 60 + SEC
  2140.         RECEIVE = OK
  2141.         GOTO 90
  2142.       ELSE IF (STATE .EQ. A) THEN
  2143.         CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
  2144.         ENDTIM = HR * 3600 + MIN * 60 + SEC
  2145.         RECEIVE = ERROR
  2146.         IF (FFD .NE. 0) CALL CLOSE(FFD)
  2147. CLT 2.3 SHORTEN MESSAGE
  2148.         CALL GETEMSG(MSG)
  2149.         CALL SNDPACK(E, PACKNUM, SLEN(MSG), MSG)
  2150.         GOTO 90
  2151.       ELSE
  2152.         CALL PRTMSG(' Receive - state error = ',STATE)
  2153.         IF (FFD .NE. 0) CALL CLOSE(FFD)
  2154.         RECEIVE = ERROR
  2155.         GOTO 90
  2156.       ENDIF
  2157.       IF (DEBUG(DBGSTAT)) THEN
  2158.         CALL PUTC(DBGFD, STATE)
  2159.         CALL PUTINT(DBGFD, PACKNUM, 1)
  2160.         CALL PUTC(DBGFD, BLANK)
  2161.         IF (MOD(PACKNUM+1, 16) .EQ. 0) CALL PUTC(DBGFD, NEL)
  2162.       ENDIF
  2163.       GOTO 10
  2164.  90   CONTINUE                     !return
  2165.       CALL MONSDRC(STATE)
  2166.       RETURN
  2167.       END
  2168.       INTEGER FUNCTION RINIT()
  2169.            IMPLICIT NONE
  2170. C
  2171. C= Receive a send-init packet
  2172. C
  2173.       INCLUDE      'KDEF.INS'
  2174.       INCLUDE      'KDBUG.COM'
  2175.       INCLUDE      'KPROT.COM'
  2176. C
  2177.       INTEGER      PTYP
  2178.       INTEGER      NUM
  2179. C
  2180.       INTEGER      RDPACK
  2181.       INTEGER      SNDPAR
  2182. C
  2183.       IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
  2184.       NUMTRY = NUMTRY + 1
  2185.       IF (NUMTRY .GT. MAXRINI) THEN
  2186.         RINIT = A
  2187.         ABORTYP(TOOMANY) = .TRUE.
  2188.         ABORTYP(READING) = .TRUE.
  2189.         ABORTYP(INITERR) = .TRUE.
  2190.         RETURN
  2191.       ENDIF
  2192. C
  2193. C read a packet and hope for best
  2194. C
  2195.       PTYP = RDPACK(LEN, NUM, PACKET)
  2196. C
  2197. C is it a valid packet type
  2198. C
  2199.       IF (PTYP .EQ. S) THEN
  2200.         TOTSDRC = TOTSDRC + 1
  2201.         NUMTRY = 0
  2202.         CALL MONSDRC(F)
  2203.         PACKNUM = NUM
  2204.         CALL RDPARAM(PACKET)
  2205.         LEN = SNDPAR(PACKET)
  2206.         CALL SNDPACK(Y, NUM, LEN, PACKET)
  2207.         PACKNUM = MOD(PACKNUM+1, 64)
  2208.         RINIT = F
  2209. C
  2210. C did we get a checksum error
  2211. C
  2212.       ELSE IF (PTYP .EQ. ERROR) THEN
  2213.         RINIT = STATE
  2214.         CALL MONSDRC(STATE)
  2215.         CALL SNDPACK(N, NUM, 0, 0)
  2216.       ELSE
  2217.         RINIT = A
  2218.         ABORTYP(INVALID) = .TRUE.
  2219.         ABORTYP(READING) = .TRUE.
  2220.         ABORTYP(INITERR) = .TRUE.
  2221.       ENDIF
  2222.       RETURN
  2223.       END
  2224.       INTEGER FUNCTION RFILE()
  2225.             IMPLICIT NONE
  2226. C
  2227. C= Read a filename packet
  2228. C
  2229. C  Rfile expects to see a filename (type f) packet.  However it may
  2230. C  find a send-init retry, end-of-file retry or break packet.
  2231. C
  2232.       INCLUDE      'KDEF.INS'
  2233.       INCLUDE      'KDBUG.COM'
  2234.       INCLUDE      'KPROT.COM'
  2235. C
  2236.       INTEGER      PTYP
  2237.       INTEGER      NUM
  2238. C
  2239.       INTEGER      RDPACK
  2240.       INTEGER      SNDPAR
  2241.       INTEGER      GETFILE
  2242. C
  2243.       IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
  2244.       NUMTRY = NUMTRY + 1
  2245.       IF (NUMTRY .GT. MAXRTRY) THEN
  2246.         RFILE = A
  2247.         ABORTYP(TOOMANY) = .TRUE.
  2248.         ABORTYP(READING) = .TRUE.
  2249.         ABORTYP(FILERR) = .TRUE.
  2250.         RETURN
  2251.       ENDIF
  2252. C
  2253. C read a packet
  2254. C
  2255.       PTYP = RDPACK(LEN, NUM, PACKET)
  2256. C
  2257. C is it a filename packet?
  2258. C
  2259.       IF (PTYP .EQ. F) THEN
  2260.         IF (NUM .NE. PACKNUM) THEN
  2261.           RFILE = A
  2262.           ABORTYP(SEQERR) = .TRUE.
  2263.           ABORTYP(READING) = .TRUE.
  2264.           ABORTYP(FILERR) = .TRUE.
  2265.           RETURN
  2266.         ENDIF
  2267.         IF (DEBUG(DBGON)) THEN
  2268.           CALL PRINTL(DBGFD, 'Receiving file ')
  2269.           CALL PUTSTR(DBGFD, PACKET)
  2270.           CALL FLUSH(DBGFD)
  2271.         ENDIF
  2272.         FFD = GETFILE(PACKET)
  2273.         IF (FFD .LE. 0) THEN
  2274.           FFD = 0
  2275.           RFILE = A
  2276.           ABORTYP(LCLFILE) = .TRUE.
  2277.           ABORTYP(READING) = .TRUE.
  2278.           ABORTYP(FILERR) = .TRUE.
  2279.         ELSE
  2280.           NUMTRY = 0
  2281.           TOTSDRC = TOTSDRC + 1
  2282.           CALL MONSDRC(D)
  2283.           CALL STRCPY(PACKET, FILESTR)
  2284.           CALL SNDPACK(Y, NUM, 0, 0)
  2285.           PACKNUM = MOD(PACKNUM+1, 64)
  2286.           RFILE = D
  2287.         ENDIF
  2288. C
  2289. C is it an old send-init packet?
  2290. C
  2291.       ELSE IF (PTYP .EQ. S) THEN
  2292.         IF (MOD(NUM+1, 64) .EQ. PACKNUM) THEN
  2293.           NUMTRY = 0
  2294.           TOTSDRC = TOTSDRC + 1
  2295.           CALL MONSDRC(STATE)
  2296.           LEN = SNDPAR(PACKET)
  2297.           CALL SNDPACK(Y, NUM, LEN, PACKET)
  2298.           RFILE = STATE
  2299.         ELSE
  2300.           RFILE = A
  2301.           ABORTYP(SEQERR) = .TRUE.
  2302.           ABORTYP(READING) = .TRUE.
  2303.           ABORTYP(INITERR) = .TRUE.
  2304.         ENDIF
  2305. C
  2306. C is it an old eof packet
  2307. C
  2308.       ELSE IF (PTYP .EQ. Z) THEN
  2309.         IF (MOD(NUM+1, 64) .EQ. PACKNUM) THEN
  2310.           NUMTRY = 0
  2311.           TOTSDRC = TOTSDRC + 1
  2312.           CALL MONSDRC(STATE)
  2313.           CALL SNDPACK(Y, NUM, 0, 0)
  2314.           RFILE = STATE
  2315.         ELSE
  2316.           RFILE = A
  2317.           ABORTYP(SEQERR) = .TRUE.
  2318.           ABORTYP(READING) = .TRUE.
  2319.           ABORTYP(INITERR) = .TRUE.
  2320.         ENDIF
  2321. C
  2322. C is it a break packet?
  2323. C
  2324.       ELSE IF (PTYP .EQ. B) THEN
  2325.         IF (NUM .NE. PACKNUM) THEN
  2326.           RFILE = A
  2327.           ABORTYP(SEQERR) = .TRUE.
  2328.           ABORTYP(READING) = .TRUE.
  2329.           ABORTYP(BRKERR) = .TRUE.
  2330.         ELSE
  2331.           NUMTRY = 0
  2332.           TOTSDRC = TOTSDRC + 1
  2333.           CALL MONSDRC(C)
  2334.           CALL SNDPACK(Y, PACKNUM, 0, 0)
  2335.           RFILE = C
  2336.         ENDIF
  2337. C
  2338. C did we get a checksum error
  2339. C
  2340.       ELSE IF (PTYP .EQ. ERROR) THEN
  2341.         RFILE = STATE
  2342.         CALL MONSDRC(STATE)
  2343.         CALL SNDPACK(N, NUM, 0, 0)
  2344. C
  2345. C invalid packet type
  2346. C
  2347.       ELSE
  2348.         RFILE = A
  2349.         ABORTYP(INVALID) = .TRUE.
  2350.         ABORTYP(READING) = .TRUE.
  2351.         ABORTYP(FILERR) = .TRUE.
  2352.       ENDIF
  2353.       RETURN
  2354.       END
  2355.       INTEGER FUNCTION RDATA()
  2356.            IMPLICIT NONE
  2357. C
  2358. C= Read a data packet
  2359. C
  2360.       INCLUDE      'KDEF.INS'
  2361.       INCLUDE      'KDBUG.COM'
  2362.       INCLUDE      'KPROT.COM'
  2363. C
  2364. C
  2365. C check retry count
  2366. C
  2367.       INTEGER      PTYP
  2368.       INTEGER      NUM
  2369. C
  2370.       INTEGER      RDPACK
  2371. C
  2372.       IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
  2373.       NUMTRY = NUMTRY + 1
  2374.       IF (NUMTRY .GT. MAXRTRY) THEN
  2375.         RDATA = A
  2376.         ABORTYP(TOOMANY) = .TRUE.
  2377.         ABORTYP(READING) = .TRUE.
  2378.         ABORTYP(DATAERR) = .TRUE.
  2379.         RETURN
  2380.       ENDIF
  2381. C
  2382. C read a packet
  2383. C
  2384.       PTYP = RDPACK(LEN, NUM, PACKET)
  2385. C
  2386. C did we get a data packet
  2387. C
  2388.       IF (PTYP .EQ. D) THEN
  2389.         IF (NUM .NE. PACKNUM) THEN
  2390.           IF (MOD(NUM+1, 64) .EQ. PACKNUM) THEN
  2391.             CALL MONSDRC(STATE)
  2392.             CALL SNDPACK(Y, NUM, 0, 0)
  2393.             RDATA = STATE
  2394.           ELSE
  2395.             RDATA = A
  2396.             ABORTYP(SEQERR) = .TRUE.
  2397.             ABORTYP(READING) = .TRUE.
  2398.             ABORTYP(DATAERR) = .TRUE.
  2399.           ENDIF
  2400.         ELSE
  2401.           TOTSDRC = TOTSDRC + 1
  2402.           CALL MONSDRC(STATE)
  2403.           CALL BUFEMP(PACKET, FFD, LEN)
  2404.           CALL SNDPACK(Y, PACKNUM, 0, 0)
  2405.           NUMTRY = 0
  2406.           PACKNUM = MOD(PACKNUM+1, 64)
  2407.           RDATA = STATE
  2408.         ENDIF
  2409. C
  2410. C is it an old filename packet
  2411. C
  2412.       ELSE IF (PTYP .EQ. F) THEN
  2413.         IF (MOD(NUM+1, 64) .EQ. PACKNUM) THEN
  2414.           TOTSDRC = TOTSDRC + 1
  2415.           CALL MONSDRC(STATE)
  2416.           CALL SNDPACK(Y, NUM, 0, 0)
  2417.           NUMTRY = 0
  2418.           RDATA = STATE
  2419.         ELSE
  2420.           RDATA = A
  2421.           ABORTYP(SEQERR) = .TRUE.
  2422.           ABORTYP(READING) = .TRUE.
  2423.           ABORTYP(FILERR ) = .TRUE.
  2424.         ENDIF
  2425. C
  2426. C is it an eof packet
  2427. C
  2428.       ELSE IF (PTYP .EQ. Z) THEN
  2429.         IF (NUM .NE. PACKNUM) THEN
  2430.           RDATA = A
  2431.           ABORTYP(SEQERR) = .TRUE.
  2432.           ABORTYP(READING) = .TRUE.
  2433.           ABORTYP(EOFERR ) = .TRUE.
  2434.         ELSE
  2435.           TOTSDRC = TOTSDRC + 1
  2436.           CALL MONSDRC(F)
  2437.           CALL SNDPACK(Y, PACKNUM, 0, 0)
  2438.           CALL CLOSE(FFD)
  2439.           FFD =  0
  2440.           PACKNUM = MOD(PACKNUM+1,64)
  2441.           NUMTRY = 0
  2442.           RDATA = F
  2443.         ENDIF
  2444.       ELSE IF (PTYP .EQ. ERROR) THEN
  2445.         RDATA = STATE
  2446.         CALL MONSDRC(STATE)
  2447.         CALL SNDPACK(N, NUM, 0, 0)
  2448.       ELSE
  2449.         RDATA = A
  2450.         ABORTYP(INVALID) = .TRUE.
  2451.         ABORTYP(READING) = .TRUE.
  2452.         ABORTYP(DATAERR) = .TRUE.
  2453.       ENDIF
  2454.       RETURN
  2455.       END
  2456.       INTEGER FUNCTION SEND()
  2457.            IMPLICIT NONE
  2458. C
  2459. C= Send file state swithcing routine
  2460. C
  2461.       INCLUDE      'KDEF.INS'
  2462.       INCLUDE      'KDBUG.COM'
  2463.       INCLUDE      'KPROT.COM'
  2464.       INCLUDE      'KPACK.COM'
  2465.       INCLUDE      'KMSG.COM'
  2466. C
  2467.       INTEGER      MM,DD,YY, HR, MIN, SEC
  2468.       INTEGER      I
  2469.       INTEGER      MSG(MAXPACK)
  2470. C
  2471.       INTEGER      SLEN
  2472.       INTEGER      SDATA
  2473.       INTEGER      SFILE
  2474.       INTEGER      SEOF
  2475.       INTEGER      SBREAK
  2476.       INTEGER      SINIT
  2477.       INTEGER      ICHAR
  2478. C
  2479. C
  2480. C initialize statics variables
  2481. C
  2482.       CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
  2483.       STARTIM = HR * 3600 + MIN * 60 + SEC
  2484.       SCHCNT = 0
  2485.       RCHCNT = 0
  2486.       SCHOVRH = 0
  2487.       RCHOVRH = 0
  2488.       STATE = S
  2489.       NUMTRY = 0
  2490.       TOTSDRC = 0
  2491.       TOTRTRY = 0
  2492. CLT 2.3 CLEAR ALL PREVIOUS ABORT MESSAGES
  2493.       ABORTYP = .FALSE.
  2494.       IF (IFD .NE. STDIN) CALL PUTC(STDOUT, NEL)
  2495. C
  2496. C take appropriate action for the current state
  2497. C
  2498.  10   CONTINUE
  2499.       CALL MONSDRC(STATE)
  2500.       IF (STATE .EQ. D) THEN
  2501.         STATE = SDATA()
  2502.       ELSE IF (STATE .EQ. F) THEN
  2503.         STATE = SFILE()
  2504.       ELSE IF (STATE .EQ. Z) THEN
  2505.         STATE = SEOF()
  2506.       ELSE IF (STATE .EQ. S) THEN
  2507.         STATE = SINIT()
  2508.       ELSE IF (STATE .EQ. B) THEN
  2509.         STATE = SBREAK()
  2510.       ELSE IF (STATE .EQ. C) THEN
  2511.         CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
  2512.         ENDTIM = HR * 3600 + MIN * 60 + SEC
  2513.         SEND = OK
  2514.         GOTO 90
  2515.       ELSE IF (STATE .EQ. A) THEN
  2516.         CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
  2517.         ENDTIM = HR * 3600 + MIN * 60 + SEC
  2518.         SEND = ERROR
  2519.         IF (FFD .NE. 0) CALL CLOSE(FFD)
  2520. CLT 2.3 SHORTEN ABORT MESSAGE
  2521.         CALL GETEMSG(MSG)
  2522.         CALL SNDPACK(E, PACKNUM, SLEN(MSG), MSG)
  2523.         GOTO 90
  2524.       ELSE
  2525.         CALL PRTMSG('Send - state error = ',STATE)
  2526.         SEND = ERROR
  2527.         IF (FFD .NE. 0) CALL CLOSE(FFD)
  2528.         GOTO 90
  2529.       ENDIF
  2530.       IF (DEBUG(DBGSTAT)) THEN
  2531.         CALL PUTC(DBGFD, STATE)
  2532.         CALL PUTINT(DBGFD, PACKNUM, 1)
  2533.         CALL PUTC(DBGFD, BLANK)
  2534.         IF (MOD(PACKNUM+1, 16) .EQ. 0) CALL PUTC(DBGFD, NEL)
  2535.       ENDIF
  2536.       GOTO 10
  2537.  90   CONTINUE
  2538.       CALL MONSDRC(STATE)
  2539.       RETURN
  2540.       END
  2541.       INTEGER FUNCTION SINIT()
  2542.            IMPLICIT NONE
  2543. C
  2544. C= send the send-init packet and wait for reply
  2545. C
  2546.       INCLUDE      'KDEF.INS'
  2547.       INCLUDE      'KDBUG.COM'
  2548.       INCLUDE      'KPROT.COM'
  2549. C
  2550.       INTEGER      PTYP
  2551.       INTEGER      NUM
  2552.       INTEGER      LEN
  2553.       CHARACTER*16 FILENAM
  2554. C
  2555.       INTEGER      OPEN
  2556.       INTEGER      RDPACK
  2557.       INTEGER      SNDPAR
  2558. C
  2559.       IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
  2560.       NUMTRY = NUMTRY + 1
  2561.       IF (NUMTRY .GT. MAXRINI) THEN
  2562.         SINIT = A
  2563.         ABORTYP(TOOMANY) = .TRUE.
  2564.         ABORTYP(SENDING) = .TRUE.
  2565.         ABORTYP(INITERR) = .TRUE.
  2566.         RETURN
  2567.       ENDIF
  2568. C
  2569. C send the send-init packet with the right info
  2570. C
  2571.       LEN = SNDPAR(PACKET)
  2572.       CALL SNDPACK(S, PACKNUM, LEN, PACKET)
  2573. C
  2574. C pick up and process reply
  2575. C
  2576.       PTYP = RDPACK(LEN, NUM, RECPACK)
  2577.       IF (PTYP .EQ. N) THEN
  2578.         SINIT = STATE
  2579.         RETURN
  2580.       ELSE IF (PTYP .EQ. Y) THEN
  2581.         IF (PACKNUM .NE. NUM) THEN
  2582.           SINIT = STATE
  2583.           RETURN
  2584.         ENDIF
  2585.         CALL RDPARAM(RECPACK)
  2586.         TOTSDRC = TOTSDRC + 1
  2587.         NUMTRY = 0
  2588.         PACKNUM = MOD(PACKNUM+1,64)
  2589.         CALL AS2DPC (FILESTR, FILENAM)
  2590.         CALL FILCHK(FILENAM)
  2591.         FFD = OPEN(FILENAM, 'R')
  2592. CLT 2.3 FLAG UNABLE TO OPEN FILE
  2593.         IF (FFD .LE. 0) THEN
  2594.           SINIT = A
  2595.           ABORTYP(LCLFILE) = .TRUE.
  2596.           ABORTYP(SENDING) = .TRUE.
  2597.           ABORTYP(FILERR) = .TRUE.
  2598.         ELSE
  2599.           SINIT = F
  2600.         ENDIF
  2601.       ELSE IF (PTYP .EQ. ERROR) THEN
  2602.         SINIT = STATE
  2603.       ELSE
  2604.         SINIT = A
  2605.         ABORTYP(INVALID) = .TRUE.
  2606.         ABORTYP(SENDING) = .TRUE.
  2607.         ABORTYP(INITERR) = .TRUE.
  2608.       ENDIF
  2609.       RETURN
  2610.       END
  2611.       INTEGER FUNCTION SFILE()
  2612.            IMPLICIT NONE
  2613. C
  2614. C= Send a filename packet and wait for reply
  2615. C
  2616.       INCLUDE      'KDEF.INS'
  2617.       INCLUDE      'KDBUG.COM'
  2618.       INCLUDE      'KPROT.COM'
  2619. C
  2620.       INTEGER      PTYP
  2621.       INTEGER      NUM
  2622. C
  2623.       INTEGER      RDPACK
  2624.       INTEGER      BUFFIL
  2625.       INTEGER      SLEN
  2626. C
  2627. C
  2628. C have we tried this too many times?
  2629. C
  2630.       IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
  2631.       NUMTRY = NUMTRY + 1
  2632.       IF (NUMTRY .GT. MAXRTRY) THEN
  2633.         SFILE = A
  2634.         ABORTYP (TOOMANY) = .TRUE.
  2635.         ABORTYP(SENDING) = .TRUE.
  2636.         ABORTYP(FILERR) = .TRUE.
  2637.         RETURN
  2638.       ENDIF
  2639. C
  2640. C send a filename packet
  2641. C
  2642.       CALL SNDPACK(F, PACKNUM, SLEN(FILESTR), FILESTR)
  2643. C
  2644. C check on the reply
  2645. C
  2646.       PTYP = RDPACK(LEN, NUM, RECPACK)
  2647.       IF (PTYP .EQ. N) THEN
  2648.         IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
  2649.           SFILE = STATE
  2650.           RETURN
  2651.          ELSE
  2652.           PTYP = Y
  2653.           NUM = NUM - 1
  2654.         ENDIF
  2655.       ENDIF
  2656.       IF (PTYP .EQ. Y) THEN
  2657.         IF (PACKNUM .NE. NUM) THEN
  2658.           SFILE = STATE
  2659.           RETURN
  2660.         ENDIF
  2661.         TOTSDRC = TOTSDRC + 1
  2662.         NUMTRY = 0
  2663.         PACKNUM = MOD(PACKNUM+1,64)
  2664. C
  2665. C get first packet of data from the file
  2666. C
  2667.         PSIZE = BUFFIL(FFD, PACKET)
  2668.         SFILE = D
  2669.       ELSE IF (PTYP .EQ. ERROR) THEN
  2670.         SFILE = STATE
  2671.       ELSE
  2672.         SFILE = A
  2673.         ABORTYP(INVALID) = .TRUE.
  2674.         ABORTYP(SENDING) = .TRUE.
  2675.         ABORTYP(FILERR) = .TRUE.
  2676.       ENDIF
  2677.       RETURN
  2678.       END
  2679.       INTEGER FUNCTION SDATA()
  2680.            IMPLICIT NONE
  2681. C
  2682. C= Send a data packet and wait for reply
  2683. C
  2684.       INCLUDE      'KDEF.INS'
  2685.       INCLUDE      'KDBUG.COM'
  2686.       INCLUDE      'KPROT.COM'
  2687. C
  2688.       INTEGER      PTYP
  2689.       INTEGER      NUM
  2690.       INTEGER      LEN
  2691. C
  2692.       INTEGER      RDPACK
  2693.       INTEGER      BUFFIL
  2694. C
  2695. C
  2696. C have we tried this too many times
  2697. C
  2698.       IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
  2699.       NUMTRY = NUMTRY + 1
  2700.       IF (NUMTRY .GT. MAXRTRY) THEN
  2701.         SDATA = A
  2702.         ABORTYP (TOOMANY) = .TRUE.
  2703.         ABORTYP(SENDING) = .TRUE.
  2704.         ABORTYP(DATAERR) = .TRUE.
  2705.         RETURN
  2706.       ENDIF
  2707. C
  2708. C send the current data buffer
  2709. C
  2710.       IF (PSIZE .EQ. EOF) THEN
  2711.         SDATA = Z
  2712.         RETURN
  2713.       ENDIF
  2714.       CALL SNDPACK(D, PACKNUM, PSIZE, PACKET)
  2715. C
  2716. C check on the reply
  2717. C
  2718.       PTYP = RDPACK(LEN, NUM, RECPACK)
  2719.       IF (PTYP .EQ. N) THEN
  2720.         IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
  2721.           SDATA = STATE
  2722.           RETURN
  2723.         ELSE
  2724.           PTYP = Y
  2725.           NUM = NUM - 1
  2726.         ENDIF
  2727.       ENDIF
  2728.       IF (PTYP .EQ. Y) THEN
  2729.         IF (PACKNUM .NE. NUM) THEN
  2730.           SDATA = STATE
  2731.           RETURN
  2732.         ENDIF
  2733.         TOTSDRC = TOTSDRC + 1
  2734.         NUMTRY = 0
  2735.         PACKNUM = MOD (PACKNUM+1,64)
  2736.         PSIZE = BUFFIL(FFD, PACKET)
  2737.         IF (PSIZE .EQ. EOF) THEN
  2738.           SDATA = Z
  2739.         ELSE
  2740.           SDATA = STATE
  2741.         ENDIF
  2742.       ELSE IF (PTYP .EQ. ERROR) THEN
  2743.         SDATA = STATE
  2744.       ELSE
  2745.         SDATA = A
  2746.         ABORTYP(INVALID) = .TRUE.
  2747.         ABORTYP(SENDING) = .TRUE.
  2748.         ABORTYP(DATAERR) = .TRUE.
  2749.       ENDIF
  2750.       RETURN
  2751.       END
  2752.       INTEGER FUNCTION SEOF()
  2753.            IMPLICIT NONE
  2754. C
  2755. C= Send an eof packet and wait for reply
  2756. C
  2757.       INCLUDE      'KDEF.INS'
  2758.       INCLUDE      'KDBUG.COM'
  2759.       INCLUDE      'KPROT.COM'
  2760. C
  2761.       INTEGER      PTYP
  2762.       INTEGER      NUM
  2763.       INTEGER      LEN
  2764. C
  2765.       INTEGER      RDPACK
  2766. C
  2767. C
  2768. C have we tried this too many times
  2769. C
  2770.       IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
  2771.       NUMTRY = NUMTRY + 1
  2772.       IF (NUMTRY .GT. MAXRTRY) THEN
  2773.         SEOF  = A
  2774.         ABORTYP (TOOMANY) = .TRUE.
  2775.         ABORTYP(SENDING) = .TRUE.
  2776.         ABORTYP(EOFERR) = .TRUE.
  2777.         RETURN
  2778.       ENDIF
  2779. C
  2780. C send the eof packet
  2781. C
  2782.       CALL SNDPACK(Z, PACKNUM, 0, 0)
  2783. C
  2784. C check the reply
  2785. C
  2786.       PTYP = RDPACK(LEN, NUM, RECPACK)
  2787.       IF (PTYP .EQ. N) THEN
  2788.         IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
  2789.           SEOF = STATE
  2790.           RETURN
  2791.         ELSE
  2792.           PTYP = Y
  2793.           NUM = NUM -1
  2794.         ENDIF
  2795.       ENDIF
  2796.       IF (PTYP .EQ. Y) THEN
  2797.         IF (PACKNUM .NE. NUM) THEN
  2798.           SEOF = STATE
  2799.           RETURN
  2800.         ENDIF
  2801.         TOTSDRC = TOTSDRC + 1
  2802.         NUMTRY = 0
  2803.         PACKNUM = MOD(PACKNUM+1,64)
  2804.         CALL CLOSE(FFD)
  2805.         SEOF = B
  2806.       ELSE IF (PTYP .EQ. ERROR) THEN
  2807.         SEOF = STATE
  2808.       ELSE
  2809.         SEOF = A
  2810.         ABORTYP(INVALID) = .TRUE.
  2811.         ABORTYP(SENDING) = .TRUE.
  2812.         ABORTYP(EOFERR) = .TRUE.
  2813.       ENDIF
  2814.       RETURN
  2815.       END
  2816.       INTEGER FUNCTION SBREAK()
  2817.           IMPLICIT NONE
  2818. C
  2819. C= Send the break packet and wait for reply
  2820. C
  2821.       INCLUDE      'KDEF.INS'
  2822.       INCLUDE      'KDBUG.COM'
  2823.       INCLUDE      'KPROT.COM'
  2824. C
  2825.       INTEGER      PTYP
  2826.       INTEGER      NUM
  2827.       INTEGER      LEN
  2828. C
  2829.       INTEGER      RDPACK
  2830. C
  2831. C
  2832. C have we tried this too many times
  2833. C
  2834.       IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
  2835.       NUMTRY = NUMTRY + 1
  2836.       IF (NUMTRY .GT. MAXRTRY) THEN
  2837.         SBREAK = A
  2838.         ABORTYP (TOOMANY) = .TRUE.
  2839.         ABORTYP(SENDING) = .TRUE.
  2840.         ABORTYP(BRKERR) = .TRUE.
  2841.         RETURN
  2842.       ENDIF
  2843. C
  2844. C send the break packet
  2845. C
  2846.       CALL SNDPACK(B, PACKNUM, 0, 0)
  2847. C
  2848. C check on the reply
  2849. C
  2850.       PTYP = RDPACK(LEN, NUM, RECPACK)
  2851.       IF (PTYP .EQ. N) THEN
  2852.         IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
  2853.           SBREAK = STATE
  2854.           RETURN
  2855.         ELSE
  2856.           PTYP = Y
  2857.           NUM = NUM - 1
  2858.         ENDIF
  2859.       ENDIF
  2860.       IF (PTYP .EQ. Y) THEN
  2861.         IF (PACKNUM .NE. NUM) THEN
  2862.           SBREAK = STATE
  2863.           RETURN
  2864.         ENDIF
  2865.         TOTSDRC = TOTSDRC + 1
  2866.         NUMTRY = 0
  2867.         PACKNUM = MOD(PACKNUM+1,64)
  2868.         SBREAK = C
  2869.       ELSE IF (PTYP .EQ. ERROR) THEN
  2870.         SBREAK = STATE
  2871.       ELSE
  2872.         SBREAK = A
  2873.         ABORTYP(INVALID) = .TRUE.
  2874.         ABORTYP(SENDING) = .TRUE.
  2875.         ABORTYP(BRKERR) = .TRUE.
  2876.       ENDIF
  2877.       RETURN
  2878.       END
  2879.       SUBROUTINE MONSDRC(ISTATE)
  2880.            IMPLICIT NONE
  2881.            INTEGER   ISTATE
  2882. C
  2883. C= Monitor send or receive transaction
  2884. C
  2885.       INCLUDE 'KDEF.INS'
  2886.       INCLUDE 'KPROT.COM'
  2887.       INCLUDE      'KDBUG.COM'
  2888. C
  2889.       IF (STDIN .NE. IFD) THEN
  2890.         CALL PUTC(STDOUT, CR)
  2891.         IF (DEBUG(DBGSTAT)) THEN
  2892.           CALL PRINT(STDOUT, 'State ')
  2893.           CALL PUTC(STDOUT, ISTATE)
  2894.         ENDIF
  2895.         CALL PRINT(STDOUT, ' Receive ')
  2896.         CALL PUTINT(STDOUT, TOTSDRC, 3)
  2897.         CALL PRINT(STDOUT, ' Retry ')
  2898.         CALL PUTINT(STDOUT, TOTRTRY, 3)
  2899.         CALL FLUSH(STDOUT)
  2900.       ENDIF
  2901.       RETURN
  2902.       END
  2903.       SUBROUTINE SNDPACK(TYPE, NUM, LEN, DATA)
  2904.            IMPLICIT NONE
  2905.            INTEGER   TYPE          !type of packet
  2906.            INTEGER   NUM           !packet number
  2907.            INTEGER   LEN           !length of packet
  2908.            INTEGER   DATA(LEN)     !packet to send
  2909. C
  2910. C= Send a packet down an output stream
  2911. C
  2912. C  Sndpack will send a packet of information and log it
  2913. C  if debug is turned on.  This subroutine could be made
  2914. C  more efficient by not calling a subroutine for each
  2915. C  character, but that might cause portability problems.
  2916. C
  2917.       INCLUDE      'KDEF.INS'
  2918.       INCLUDE      'KDBUG.COM'
  2919.       INCLUDE      'KPROT.COM'
  2920.       INCLUDE      'KPACK.COM'
  2921. C
  2922.       INTEGER      I
  2923.       INTEGER      CHKSUM          ! com puted checksum
  2924.       INTEGER      TMP
  2925.       INTEGER      NCH             !number of characters
  2926. C
  2927.       INTEGER      TOCHAR
  2928.       INTEGER      CHKSUMER      !find checksum
  2929. C
  2930.       IF (DEBUG(DBGPACK)) THEN
  2931.         CALL PRINTL(DBGFD, 'Sending...')
  2932.       ENDIF
  2933. C
  2934. C put out pad chars
  2935. C
  2936.       DO I=1, SPAD
  2937.         CALL PUTC(OFD, SPADCH)
  2938.         IF (DEBUG(DBGPACK)) THEN
  2939.           CALL PUTC(DBGFD, SPADCH)
  2940.         ENDIF
  2941.       ENDDO
  2942.       CALL PUTC(OFD, SNDSYNC)
  2943. C
  2944. C packet len assumes one character checksums
  2945. C
  2946.       CHKSUM = TOCHAR(LEN+3)
  2947.       CALL PUTC(OFD, CHKSUM)
  2948.       TMP = TOCHAR(NUM)
  2949.       CHKSUM = CHKSUM + TMP
  2950.       CALL PUTC(OFD, TMP)
  2951.       CHKSUM = CHKSUM + TYPE
  2952.       CALL PUTC(OFD, TYPE)
  2953.       DO I=1, LEN
  2954.         CHKSUM = CHKSUM + DATA(I)
  2955.         CALL PUTC(OFD, DATA(I))
  2956.       ENDDO
  2957.       CHKSUM = CHKSUMER(CHKSUM)
  2958.       CALL PUTC(OFD, TOCHAR(CHKSUM))
  2959.       CALL PUTC(OFD, SPEOL)
  2960.       IF (DEBUG(DBGPACK)) THEN
  2961.         CALL PUTC(DBGFD, SNDSYNC)
  2962.         CALL PUTC(DBGFD, TOCHAR(LEN+3))
  2963.         CALL PUTC(DBGFD, TOCHAR(NUM))
  2964.         CALL PUTC(DBGFD, TYPE)
  2965.         IF (LEN .GT. 0) CALL PUTSTR(DBGFD, DATA)
  2966.         CALL PUTC(DBGFD, TOCHAR(CHKSUM))
  2967.         CALL PUTC(DBGFD, SPEOL)
  2968.         CALL FLUSH(DBGFD)
  2969.       ENDIF
  2970. C
  2971. C force buffer flush since desired eol char won't
  2972. C
  2973.       CALL FLUSH(OFD)
  2974. C
  2975. C update the statistics
  2976. C
  2977.       NCH = SPAD + 5 + LEN + 1
  2978.       SCHCNT = SCHCNT + NCH
  2979.       SCHOVRH = SCHOVRH + NCH - LEN
  2980.       RETURN
  2981.       END
  2982.       INTEGER FUNCTION RDPACK(LEN, NUM, DATA)
  2983.            IMPLICIT NONE
  2984.            INTEGER   LEN           !length of packet read
  2985.            INTEGER   NUM           !packet number
  2986.            INTEGER   DATA(*)       !data read
  2987. C
  2988. C= Read a packet of information
  2989.       INCLUDE      'KDEF.INS'
  2990.       INCLUDE      'KDBUG.COM'
  2991.       INCLUDE      'KPROT.COM'
  2992.       INCLUDE      'KPACK.COM'
  2993.       LOGICAL      BREAK
  2994.       COMMON /BREAK/BREAK
  2995. C
  2996.       INTEGER      CHKSUM
  2997.       INTEGER      FIELD
  2998.       INTEGER      NCH
  2999.       INTEGER      CH
  3000.       INTEGER      TYPE
  3001.       INTEGER      I
  3002.       INTEGER      STIME           !start time
  3003.       INTEGER      FTIME           !finish time
  3004. C
  3005.       INTEGER      GETC
  3006.       INTEGER      UNCHAR
  3007.       INTEGER      CHKSUMER      !compute checksum
  3008. C
  3009. C debug
  3010. C
  3011.       IF (DEBUG(DBGPACK)) THEN
  3012.         CALL PRINTL(DBGFD, 'Reading...')
  3013.       ENDIF
  3014.       NCH = 0
  3015. C
  3016. C hunt for start of packet
  3017. C
  3018.       LEN = 0
  3019.       CHKSUM = 0
  3020.       CALL MSEC(STIME)
  3021.       BREAK = .FALSE.
  3022.  10   CONTINUE
  3023.       CALL MSEC(FTIME)
  3024.       IF ((FTIME-STIME)/1000 .GT. TIMEOUT .OR. BREAK) THEN
  3025.         IF (DEBUG(DBGPACK)) THEN
  3026.           IF (BREAK) THEN
  3027.             CALL PRINTL(DBGFD, 'BREAK TIMEOUT')
  3028.           ELSE
  3029.             CALL PRINTL(DBGFD, 'TIMEOUT')
  3030.           ENDIF
  3031.         ENDIF
  3032.         RDPACK = ERROR
  3033.         GOTO 30       !RETURN
  3034.       ENDIF
  3035.       CH = GETC(IFD, CH)
  3036.       IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, CH)
  3037.       IF (CH .EQ. ERROR) THEN
  3038.         GOTO 10
  3039.       ENDIF
  3040.       NCH = NCH + 1
  3041. CLT   IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, CH)
  3042.       IF (CH .NE. SYNC) GOTO 10
  3043. C
  3044. C parse each field of the packet
  3045. C
  3046.       FIELD = 1
  3047.  20   CONTINUE
  3048.       CALL MSEC(FTIME)
  3049.       IF ((FTIME-STIME)/1000 .GT. TIMEOUT .OR. BREAK) THEN
  3050.         RDPACK = ERROR
  3051.         GOTO 30       !RETURN
  3052.       ENDIF
  3053.       IF (FIELD .LE. 5) THEN
  3054. C
  3055. C a character read in field 4 here is the first char of the
  3056. C data field or the checksum character if the data field is
  3057. C empty
  3058. C
  3059.         IF (FIELD .NE. 5 .OR. LEN .GT. 0) THEN
  3060.           IF (GETC(IFD, CH) .EQ. SYNC) FIELD = 0
  3061.           NCH = NCH + 1
  3062.           IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, CH)
  3063.         ENDIF
  3064.         IF (FIELD .LE. 3) CHKSUM = CHKSUM + CH
  3065. C
  3066. C if resync
  3067. C
  3068.         IF (FIELD .EQ. 0) THEN
  3069.           CHKSUM = 0
  3070.           IF (DEBUG(DBGPACK)) THEN
  3071.             CALL PRINTL(DBGFD, 'Reading...')
  3072.             CALL PUTC(DBGFD, SYNC)
  3073.           ENDIF
  3074. C
  3075. C if data length
  3076. C
  3077.         ELSE IF (FIELD .EQ. 1) THEN
  3078.           LEN = UNCHAR(CH-3)
  3079. C
  3080. C if pack number
  3081. C
  3082.         ELSE IF (FIELD .EQ. 2) THEN
  3083.           NUM = UNCHAR(CH)
  3084. C
  3085. C if packet type
  3086. C
  3087.         ELSE IF (FIELD .EQ. 3) THEN
  3088.           TYPE = CH
  3089. C
  3090. C if data field is not empty
  3091. C
  3092.         ELSE IF (FIELD .EQ. 4 .AND. LEN .GT. 0) THEN
  3093. C
  3094. C read 2nd-len chars of data & checksum char
  3095. C
  3096.           DO I=1, LEN
  3097.             CALL MSEC(FTIME)
  3098.             IF ((FTIME-STIME)/1000 .GT. TIMEOUT .OR. BREAK) THEN
  3099.               RDPACK = ERROR
  3100.               GOTO 30       !RETURN
  3101.             ENDIF
  3102.             IF (I .GT. 1) THEN
  3103.               CH = GETC(IFD, CH)
  3104.               NCH = NCH + 1
  3105.               IF (CH .EQ. SYNC) THEN
  3106.                 FIELD = 0
  3107.                 GOTO 20
  3108.               ENDIF
  3109.               IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, CH)
  3110.             ENDIF
  3111.             CHKSUM = CHKSUM + CH
  3112.             DATA (I) = CH
  3113.           ENDDO
  3114. C
  3115. C if chksum char
  3116. C
  3117.         ELSE IF (FIELD .EQ. 5) THEN
  3118.           DATA(LEN+1) = 0
  3119.           CHKSUM = CHKSUMER(CHKSUM)
  3120.         ENDIF
  3121. C
  3122. C process next packet field
  3123. C
  3124.         FIELD = FIELD + 1
  3125.         GOTO 20
  3126.       ENDIF
  3127.       IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, NEL)
  3128. C
  3129. C does the checksum match
  3130. C
  3131.       IF (CHKSUM .NE. UNCHAR(CH)) THEN
  3132.         RDPACK = ERROR
  3133.         RCHOVRH = RCHOVRH + NCH
  3134.         IF (DEBUG(DBGON)) THEN
  3135.           CALL PRINTL(DBGFD, 'chksum error, found ')
  3136.           CALL PUTINT(DBGFD, UNCHAR(CH), 1)
  3137.           CALL PRINT(DBGFD, ' needed ')
  3138.           CALL PUTINT(DBGFD, CHKSUM, 1)
  3139.         ENDIF
  3140.       ELSE
  3141.         RDPACK = TYPE
  3142.         RCHOVRH = RCHOVRH + NCH - LEN
  3143.       ENDIF
  3144.       RCHCNT = RCHCNT + NCH
  3145. C
  3146. C flush any eol characters and other garbage
  3147. C
  3148.       CALL FLUSH(IFD)
  3149.  30   CONTINUE     !error exit
  3150.       IF (DEBUG(DBGON)) THEN
  3151.         CALL FLUSH(DBGFD)
  3152.       ENDIF
  3153.       RETURN
  3154.       END
  3155.       INTEGER FUNCTION BUFFIL(FD, BUFFER)
  3156.            IMPLICIT NONE
  3157.            INTEGER   FD            !file device
  3158.            INTEGER   BUFFER(*)     !buffer to fill
  3159. C
  3160. C= Get some data to send.
  3161. C
  3162. C BUFFIL READS FROM THE FILE TO SEND AND PERFORMS ALL
  3163. C THE PROPER ESCAPING OF CONTROL CHARACTERS AND MAPPING
  3164. C NEWLINES INTO CRLF SEQUENCES.  IF IT EVER GETS SMART
  3165. C ENOUGH, IT WILL ALSO DO THE 8 BIT QUOTING AND REPEAT
  3166. C COUNTS.
  3167. C
  3168. C *** NOTE: THIS ALGORTHM ASSUMES 5 OVERHEAD CHARACTERS FOR THE
  3169. C PACKET AND LEAVES 3 CHARACTERS IN CASE THE LAST CHARACTER TO
  3170. C BUFFER IS A NEL (EXPANDS TO 4 CHARACTERS).
  3171.       INCLUDE      'KDEF.INS'
  3172.       INCLUDE      'KDBUG.COM'
  3173.       INCLUDE      'KPROT.COM'
  3174.       INCLUDE      'KPACK.COM'
  3175. C
  3176.       INTEGER      I
  3177.       INTEGER      CH
  3178. C
  3179.       INTEGER      GETC
  3180.       INTEGER      CTL             !control switch
  3181. C
  3182. C
  3183. C get a packet worth of data
  3184. C
  3185.       I = 0
  3186.  10   CONTINUE
  3187.       IF (GETC(FD, CH) .NE. EOF) THEN
  3188.         IF (CH .LT. BLANK .OR. CH .EQ. DEL .OR. CH .EQ. NEL .OR.
  3189.      $      CH .EQ. SPQUOTE) THEN
  3190.           IF (CH .EQ. NEL) THEN
  3191.             BUFFER(I+1) = SPQUOTE
  3192.             BUFFER(I+2) = CTL(CR)
  3193.             I = I + 2
  3194.             CH = LF
  3195.           ENDIF
  3196.           I = I + 1
  3197.           BUFFER(I) = SPQUOTE
  3198.           IF (CH .NE. SPQUOTE) CH = CTL(CH)
  3199.         ENDIF
  3200.         I = I + 1
  3201.         BUFFER(I) = CH
  3202.         IF (I .GE. SPKSIZ-8) THEN
  3203.           BUFFIL = I
  3204.           GOTO 99
  3205.         ENDIF
  3206.         GOTO 10
  3207.       ENDIF
  3208.       IF (I .EQ. 0) THEN
  3209.         BUFFIL = EOF
  3210.       ELSE
  3211.         BUFFIL = I
  3212.       ENDIF
  3213.  99   CONTINUE
  3214.       BUFFER(I+1) = 0
  3215.       RETURN
  3216.       END
  3217.       SUBROUTINE BUFEMP( BUFFER, FD, LEN)
  3218.            IMPLICIT NONE
  3219.            INTEGER  BUFFER(*)      !buffer to empty
  3220.            INTEGER  FD             !file descriptor
  3221.            INTEGER  LEN            !length of buffer to empty
  3222. C
  3223. C= dumps a buffer to a file
  3224. C
  3225.       INCLUDE      'KDEF.INS'
  3226.       INCLUDE      'KDBUG.COM'
  3227.       INCLUDE      'KPROT.COM'
  3228.       INCLUDE      'KPACK.COM'
  3229. C
  3230.       INTEGER      I
  3231.       INTEGER      PREVCH
  3232.       INTEGER      CH
  3233. C
  3234.       INTEGER      CTL
  3235. C
  3236. C
  3237. C write the packet data to the file
  3238. C
  3239.       I = 1
  3240.  10   CONTINUE
  3241.       IF (I .LE. LEN) THEN
  3242.         CH = BUFFER(I)
  3243.         IF (CH .EQ. QUOTECH) THEN
  3244.           I = I + 1
  3245.           CH = BUFFER(I)
  3246.           IF (CH .NE. QUOTECH) CH = CTL(CH)
  3247.         ENDIF
  3248. C
  3249. C convert cr/lf pair to NEL
  3250. C
  3251.         IF (CH .EQ. LF .AND. PREVCH .EQ. CR) THEN
  3252.           CH = NEL
  3253. C
  3254. C just a lone cr
  3255. C
  3256.         ELSE IF (PREVCH .EQ. CR) THEN
  3257.           CALL PUTC(FD, PREVCH)
  3258.         ENDIF
  3259.         IF (CH .NE. CR) CALL PUTC(FD, CH)
  3260.         PREVCH = CH
  3261.         I = I + 1
  3262.         GOTO 10
  3263.       ENDIF
  3264.       RETURN
  3265.       END
  3266.       INTEGER FUNCTION CHKSUMER (SUM)
  3267.            IMPLICIT NONE
  3268.            INTEGER   SUM      !sum to find check sum of
  3269. C
  3270. C= Compute checksum for transmission
  3271. C
  3272.       INTEGER      HIGHBITS/X'C0'/  !mask for high bits
  3273.       INTEGER      SHIFTLOW /X'40'/ !make them low bits
  3274.       INTEGER      SIXBITS /X'3F'/  !return only six bits
  3275. C
  3276.       INTEGER      IAND            !and words together
  3277. C
  3278.       CHKSUMER = IAND (SUM + IAND (SUM,HIGHBITS) / SHIFTLOW,
  3279.      $           SIXBITS)
  3280.       RETURN
  3281.       END
  3282.       SUBROUTINE AS2DPC(ASTR,DSTR)
  3283.            IMPLICIT NONE
  3284.            INTEGER   ASTR(100)
  3285.            CHARACTER*(*)   DSTR
  3286.  
  3287. C= Translate ascii integer string to character string
  3288. C
  3289. C     ASCII STRING IS TERMINATED BY A ZERO BYTE.
  3290. C
  3291. C
  3292.       INTEGER            CLEN
  3293.       INTEGER      I
  3294. C
  3295.       CHARACTER*1  CHAR
  3296.       INTEGER      LEN
  3297. C
  3298.       I = 1
  3299.       CLEN = LEN(DSTR)
  3300.       DSTR = ' '
  3301. 10    IF (ASTR(I) .NE. 0 .AND. I .LE. CLEN) THEN
  3302.          DSTR(I:I) = CHAR(ASTR(I))
  3303.          I = I + 1
  3304.          GO TO 10
  3305.       ENDIF
  3306. C
  3307.       RETURN
  3308.       END
  3309.       SUBROUTINE DPC2AS(DSTR,ASTR,N)
  3310.            IMPLICIT NONE
  3311.            CHARACTER*(*) DSTR
  3312.            INTEGER       ASTR(200)
  3313.            INTEGER       N
  3314. C
  3315. C= TRANSLATE STRING OF DISPLAY CODE CHARACTERS ASCII INTEGER STRING.
  3316. C  STRING IS N CHARACTERS (WORDS) LONG.
  3317. C
  3318. C
  3319.       INTEGER      I
  3320. C
  3321.       INTEGER      ICHAR
  3322. C
  3323.       DO I=1,N
  3324.          ASTR(I) = ICHAR(DSTR(I:I))
  3325.       ENDDO
  3326. C
  3327. C     SET ASCII END-OF-STRING-BUFFER
  3328. C
  3329.       ASTR(N+1) = 0
  3330. C
  3331.       RETURN
  3332.       END
  3333.       INTEGER FUNCTION CTOI(ASTR)
  3334.           IMPLICIT NONE
  3335.           INTEGER      ASTR(200)
  3336.  
  3337. C= CONVERT CHARACTER BUFFER TO INTEGER.
  3338. C
  3339. C   MC     A SUFFIX OF H WILL CONVERT USING BASE 16 AND A SUFFIX
  3340. C     OF O WILL CONVERT USING BASE 8.  DEFAULT SUFFIX IS
  3341. C     D.
  3342. C
  3343.       INCLUDE 'KDEF.INS'
  3344.       INTEGER      DIG0, DIG7, DIG9, BIGA, BIGB, BIGD
  3345.       INTEGER      BIGF, BIGH, BIGO, LETA, LETB, LETD
  3346.       INTEGER      LETF, LETH, LETO
  3347.       PARAMETER (DIG0=48, DIG7=55, DIG9=57, BIGA=65, BIGB=66, BIGD=68)
  3348.       PARAMETER (BIGF=70, BIGH=72, BIGO=79, LETA=97, LETB=98, LETD=100)
  3349.       PARAMETER (LETF=102, LETH=104, LETO=111)
  3350.       INTEGER      BASE
  3351.       INTEGER      PTR
  3352.       INTEGER      EOD
  3353.       INTEGER      CH
  3354.       INTEGER      TOTAL
  3355.       INTEGER      ISNEG
  3356.       INTEGER      I
  3357.  
  3358.       BASE = 0
  3359.       PTR = 0
  3360. C
  3361. C     FIND LAST VALID DIGIT
  3362. C
  3363. 10    PTR = PTR + 1
  3364.       IF (ASTR(PTR) .NE. 0) GO TO 10
  3365.       PTR = PTR - 1
  3366.       IF (ASTR(PTR) .EQ. LETO .OR. ASTR(PTR) .EQ. BIGO .OR.
  3367.      +    ASTR(PTR) .EQ. LETB .OR. ASTR(PTR) .EQ. BIGB .OR.
  3368.      +    ASTR(PTR) .EQ. LETH .OR. ASTR(PTR) .EQ. BIGH) THEN
  3369.          EOD = PTR - 1
  3370.       ELSE
  3371.          EOD = PTR
  3372.          PTR = PTR + 1
  3373.       ENDIF
  3374. C
  3375. C     TRY TO FIGURE OUT THE BASE
  3376. C
  3377.       IF (ASTR(PTR) .EQ. 0) THEN
  3378.          BASE = 10
  3379.       ELSE IF (ASTR(PTR) .EQ. LETO .OR. ASTR(PTR) .EQ. BIGO .OR.
  3380.      +         ASTR(PTR) .EQ. LETB .OR. ASTR(PTR) .EQ. BIGB) THEN
  3381.          BASE = 8
  3382.       ELSE IF (ASTR(PTR) .EQ. LETH .OR. ASTR(PTR) .EQ. BIGH) THEN
  3383.          BASE = 16
  3384.       ENDIF
  3385. C
  3386. C     IF DIDN'T FIND A BASE
  3387. C
  3388.       IF (BASE .EQ. 0) THEN
  3389.          CALL PRINTL(STDOUT,'CTOI - Invalid base ')
  3390.          CALL PUTC(STDOUT, ASTR(PTR))
  3391.          CALL FLUSH(STDOUT)
  3392.          CTOI = 0
  3393.          RETURN
  3394.       ENDIF
  3395. C
  3396. C     ADD UP THE DIGITS
  3397. C
  3398.       TOTAL = 0
  3399.       ISNEG = 1
  3400.       DO 100 I = 1,EOD
  3401.          CH = ASTR(I)
  3402.          IF (CH .EQ. MINUS) THEN
  3403.             ISNEG = -1
  3404.             GO TO 100
  3405.          ENDIF
  3406.          IF (BASE .EQ. 10) THEN
  3407.             IF (CH .LT. DIG0 .OR. CH .GT. DIG9) THEN
  3408.                CALL PRINTL(STDOUT,'CTOI - Invalid decimal digit ')
  3409.                CALL PUTC(STDOUT, CH)
  3410.                CALL FLUSH(STDOUT)
  3411.                CTOI = 0
  3412.                RETURN
  3413.             ELSE
  3414.                CH = CH - DIG0
  3415.             ENDIF
  3416.          ELSE IF (BASE .EQ. 8) THEN
  3417.             IF (CH .LT. DIG0 .OR. CH .GT. DIG7) THEN
  3418.                CALL PRINTL(STDOUT,'CTOI - Invalid octal digit ')
  3419.                CALL PUTC(STDOUT, CH)
  3420.                CALL FLUSH(STDOUT)
  3421.                CTOI = 0
  3422.                RETURN
  3423.             ELSE
  3424.                CH = CH - DIG0
  3425.             ENDIF
  3426.          ELSE IF (BASE .EQ. 16) THEN
  3427.             IF (CH .GE. DIG0 .AND. CH .LE. DIG9) THEN
  3428.                CH = CH - DIG0
  3429.             ELSE IF (CH .GE. LETA .AND. CH .LE. LETF) THEN
  3430.                CH = 10 + CH - LETA
  3431.             ELSE IF (CH .GE. BIGA .AND. CH .LE. BIGF) THEN
  3432.                CH = 10 + CH - BIGA
  3433.             ELSE
  3434.                CALL PRINTL(STDOUT,'CTOI - Invalid hex digit ')
  3435.                CALL PUTC(STDOUT, CH)
  3436.                CALL FLUSH(STDOUT)
  3437.                CTOI = 0
  3438.                RETURN
  3439.             ENDIF
  3440.          ENDIF
  3441.          TOTAL = TOTAL*BASE + CH
  3442. 100   CONTINUE
  3443.       CTOI = TOTAL * ISNEG
  3444.       RETURN
  3445.       END
  3446.       INTEGER FUNCTION ITOS(INT,STR,MINWID)
  3447.            IMPLICIT NONE
  3448.            INTEGER INT
  3449.            INTEGER STR(200)
  3450.            INTEGER MINWID
  3451.  
  3452. CCC   ITOS - CONVERT AN INTEGER TO STRING FORMAT.
  3453. C
  3454.       INCLUDE 'KDEF.INS'
  3455.       INTEGER      WIDTH
  3456.       INTEGER      VAL
  3457.       INTEGER      ASCII0
  3458.       INTEGER      TCH
  3459.       INTEGER      IPTR
  3460.       INTEGER      ENDPTR
  3461. C
  3462.       INTEGER      MOD
  3463.       INTEGER      ICHAR
  3464.  
  3465.       WIDTH = 0
  3466.       IF (INT .LT. 0) THEN
  3467.          WIDTH = 1
  3468.          STR(WIDTH) = ICHAR('-')
  3469.       ENDIF
  3470.       VAL = IABS(INT)
  3471.       ASCII0 = ICHAR('0')
  3472. 10    WIDTH = WIDTH + 1
  3473.       STR(WIDTH) = MOD(VAL,10) + ASCII0
  3474.       VAL = VAL / 10
  3475.       IF (VAL .NE. 0) GO TO 10
  3476.       STR(WIDTH+1) = 0
  3477. C
  3478. C     NOW REVERSE THE DIGITS
  3479. C
  3480.       IPTR = 1
  3481.       ENDPTR = WIDTH
  3482.       IF (STR(IPTR) .EQ. ICHAR('-')) IPTR = IPTR + 1
  3483. 20    IF (IPTR .LT. ENDPTR) THEN
  3484.          TCH = STR(IPTR)
  3485.          STR(IPTR) = STR(ENDPTR)
  3486.          STR(ENDPTR) = TCH
  3487.          IPTR = IPTR + 1
  3488.          ENDPTR = ENDPTR - 1
  3489.          GO TO 20
  3490.       ENDIF
  3491.       ITOS = WIDTH
  3492.       RETURN
  3493.       END
  3494.       INTEGER FUNCTION GETFILE(FN)
  3495.            IMPLICIT NONE
  3496.            INTEGER       FN(*)     !file name
  3497.  
  3498. C= Open a file for writing packet data to.
  3499. C
  3500. C     GETFILE WILL TRY TO CREATE A FILE TO WRITE TO.  IF IT
  3501. C     ALREADY EXISTS, THEN IT WILL FAIL.
  3502. C
  3503.       CHARACTER*56 FILENAM
  3504. C
  3505.       INTEGER      OPEN
  3506. C
  3507.       INCLUDE 'KDEF.INS'
  3508. C
  3509. C     GET THE DPC VERSION OF THE FILENAME
  3510. C
  3511.       CALL AS2DPC(FN,FILENAM)
  3512.       CALL FILCHK(FILENAM)
  3513.       GETFILE = OPEN(FILENAM, 'W')
  3514.       RETURN
  3515.       END
  3516.       SUBROUTINE GETNOW(MM,DD,YY,HR,MIN,SEC)
  3517.            IMPLICIT NONE
  3518.            INTEGER  MM,DD,YY
  3519.            INTEGER  HR,MIN,SEC
  3520.  
  3521. CCC   GET THE CURRENT DATE AND TIME.
  3522. C
  3523.       INTEGER      IDT(3)              !INTEGER DATE AND TIME
  3524. C
  3525.       CALL DATE(IDT)
  3526.       YY = IDT(1)
  3527.       MM = IDT(2)
  3528.       DD = IDT(3)
  3529.       CALL TIME(IDT)
  3530.       HR = IDT(1)
  3531.       MIN = IDT(2)
  3532.       SEC = IDT(3)
  3533.       RETURN
  3534.       END
  3535.       SUBROUTINE FILCHK(FN)
  3536.            IMPLICIT NONE
  3537.            CHARACTER *(*) FN
  3538. C
  3539. C= Check validity of filename, remove special characters
  3540. C
  3541.       INTEGER PTR,CH
  3542.       INTEGER      I
  3543. C
  3544.       INTEGER      LEN
  3545.       INTEGER      ICHAR
  3546.       CHARACTER*1  CHAR
  3547. C
  3548.       PTR = 1
  3549.       DO I=1, LEN(FN)
  3550.         IF (FN(I:I) .EQ. ' ') THEN
  3551.         ELSE IF(FN(I:I) .GE. 'A' .AND. FN(I:I) .LE. 'Z') THEN
  3552.           FN(PTR:PTR) = FN(I:I)
  3553.           PTR = PTR + 1
  3554.         ELSE IF (FN(I:I) .GE. '0' .AND. FN(I:I) .LE. '9' .AND.
  3555.      $           I .NE. 1) THEN
  3556.           FN(PTR:PTR) = FN(I:I)
  3557.           PTR = PTR + 1
  3558.         ELSE IF (FN(I:I) .GE. 'a' .AND. FN(I:I) .LE. 'z') THEN
  3559.           FN(PTR:PTR) = CHAR(ICHAR(FN(I:I)) - X'20')
  3560.           PTR = PTR + 1
  3561.         ELSE IF(FN(I:I) .EQ. '.' .OR. FN(I:I) .EQ. '*' .OR.
  3562.      $          FN(I:I) .EQ. '_') THEN
  3563.           FN(PTR:PTR) = FN(I:I)
  3564.           PTR = PTR + 1
  3565.         ENDIF
  3566.       ENDDO
  3567.       IF (PTR .LE. LEN(FN)) FN(PTR:) = ' '
  3568.       RETURN
  3569.       END
  3570.       SUBROUTINE RDPARAM(PDATA)
  3571.            IMPLICIT NONE
  3572.            INTEGER    PDATA (100)
  3573.  
  3574. C= Get the packet parameters from the other kermit
  3575. C
  3576.       INCLUDE 'KDEF.INS'
  3577.       INCLUDE 'KPACK.COM'
  3578.       INTEGER PARAMS(11)
  3579.       EQUIVALENCE (PARAMS,SPKSIZ)
  3580.       INTEGER      I
  3581. C
  3582.       INTEGER      CTL
  3583.       INTEGER      UNCHAR
  3584. C
  3585. C     CYCLE THROUGH THE LIST OF PARAMETERS UNTIL THE END-OF-LIST
  3586. C     IS FOUND (A 0 BYTE).
  3587. C     Must be loop because variable length reply
  3588. C
  3589.       I = 1
  3590.       DO WHILE (PDATA(I) .NE. 0 .AND. I .LE. 11)
  3591. C
  3592. C        IS IT THE PAD CHARACTER?
  3593. C
  3594.          IF (I .EQ. 4) THEN
  3595.             PARAMS(I) = CTL(PDATA(I))
  3596.             IF (PARAMS(I) .EQ. 0) PARAMS(I) = NULL
  3597. C
  3598. C        IS IT THE QUOTE CHARACTER?
  3599. C
  3600.          ELSE IF (I .EQ. 6) THEN
  3601.             PARAMS(I) = PDATA(I)
  3602. C
  3603. C all else
  3604. C
  3605.          ELSE
  3606.             IF (UNCHAR(PDATA(I)) .NE. 0) THEN
  3607.                PARAMS(I) = UNCHAR(PDATA(I))
  3608.             ENDIF
  3609.          ENDIF
  3610.          I = I + 1
  3611.       ENDDO
  3612.       RETURN
  3613.       END
  3614.       SUBROUTINE REMOVE(FN)
  3615.            IMPLICIT NONE
  3616.            INTEGER   FN(100)
  3617.  
  3618. C= Remove a file from the local file list.
  3619. C
  3620.       CHARACTER*56 FNAME
  3621.  
  3622.       CALL AS2DPC(FN,FNAME)
  3623.       OPEN(UNIT='TMP',FILE=FNAME)
  3624.       CLOSE(UNIT='TMP',STATUS='DELETE')
  3625.       RETURN
  3626.       END
  3627.       SUBROUTINE STRCPY(S1,S2)
  3628.            IMPLICIT NONE
  3629.            INTEGER S1(200),S2(200)
  3630.  
  3631. C= Copy one ascii string to another
  3632. C
  3633.       INTEGER      I1
  3634.  
  3635.       I1 = 1
  3636. 10    S2(I1) = S1(I1)
  3637.       IF (S1(I1) .NE. 0) THEN
  3638.          I1 = I1 + 1
  3639.          GO TO 10
  3640.       ENDIF
  3641.       RETURN
  3642.       END
  3643.       INTEGER FUNCTION SLEN(STR)
  3644.            IMPLICIT NONE
  3645.            INTEGER   STR(200)
  3646.  
  3647. C= Return the length of a zero terminated ascii string buffer.
  3648. C
  3649.       INTEGER      I
  3650.  
  3651.       I = 0
  3652. 10    IF (STR(I+1) .NE. 0) THEN
  3653.          I = I + 1
  3654.          GO TO 10
  3655.       ENDIF
  3656.       SLEN = I
  3657.       RETURN
  3658.       END
  3659.       INTEGER FUNCTION SNDPAR(PDATA)
  3660.            IMPLICIT NONE
  3661.            INTEGER PDATA(100)
  3662.  
  3663. C= Setup parameters to send to other kermit.
  3664. C
  3665.       INCLUDE 'KDEF.INS'
  3666.       INCLUDE 'KPACK.COM'
  3667. C
  3668.       INTEGER      I
  3669.       INTEGER      PARAMS(12)
  3670.         EQUIVALENCE (PARAMS, PACKSIZ)
  3671. C
  3672.       INTEGER      CTL
  3673.       INTEGER      TOCHAR
  3674. C
  3675. C     SEND WHAT WE WANT
  3676. C
  3677.       PDATA (1) = TOCHAR(PACKSIZ)
  3678.       PDATA (2) = TOCHAR(TIMEOUT)
  3679.       PDATA (3) = TOCHAR(NPAD)
  3680.       PDATA (4) = CTL(PADCH)
  3681.       PDATA (5) = TOCHAR(EOLCH)
  3682.       PDATA (6) = QUOTECH
  3683.       PDATA (7) = 0
  3684. C
  3685. C     RETURN LENGTH OF HOW MANY THINGS WE WANT TO SET
  3686. C
  3687.       SNDPAR = 6
  3688.       RETURN
  3689.       END
  3690.       SUBROUTINE SLEEP(SECONDS)
  3691.            IMPLICIT NONE
  3692.            INTEGER     SECONDS
  3693. CC
  3694. C     SLEEP - HOLD FOR <SECONDS> SECONDS.
  3695. C
  3696.       INTEGER      I
  3697.  
  3698.       DO 100 I=1,SECONDS
  3699.          CALL DELAY(1000)
  3700. 100   CONTINUE
  3701.       RETURN
  3702.       END
  3703.       SUBROUTINE DELAY(MSEC)
  3704.            IMPLICIT NONE
  3705.            INTEGER  MSEC
  3706. C
  3707. C=    DELAY - HOLD THINGS UP FOR <MSEC> MILISECS.
  3708. C
  3709. C     **** THIS IS PROBABLY SYSTEM DEPENDENT CODE *****
  3710. C          IF YOU MODIFY IT USE CONDITIONAL COMPILATION
  3711. C
  3712.       INTEGER      IOS
  3713. C
  3714.       CALL WAIT(MSEC, 1, IOS)
  3715.       RETURN
  3716.       END
  3717.       INTEGER FUNCTION CTL (ASCCH)
  3718.            IMPLICIT NONE
  3719.            INTEGER  ASCCH
  3720. C
  3721. C= Flip control bit protecting control chars and unprotecting
  3722. C
  3723.       CTL = IEOR(ASCCH,X'40')
  3724.       RETURN
  3725.       END
  3726.       INTEGER FUNCTION TOCHAR(ASCCH)
  3727.            IMPLICIT NONE
  3728.            INTEGER  ASCCH
  3729. C
  3730. C= Make an ascii character.
  3731. C
  3732.       INCLUDE      'KDEF.INS'
  3733. C
  3734.       TOCHAR = ASCCH + BLANK
  3735.       RETURN
  3736.       END
  3737.       INTEGER FUNCTION UNCHAR(ASCCH)
  3738.            IMPLICIT NONE
  3739.            INTEGER   ASCCH
  3740. C
  3741. C= Convert back to control character
  3742. C
  3743.       INCLUDE      'KDEF.INS'
  3744. C
  3745.       UNCHAR = ASCCH - BLANK
  3746.       RETURN
  3747.       END
  3748.       SUBROUTINE GETMACH(MACH)
  3749.            IMPLICIT NONE
  3750.            CHARACTER*(*) MACH  !current machine type
  3751. C
  3752. C= Retrieves current machine type from os
  3753. C
  3754.       CHARACTER*2 MACHS(0:5)       !gould machines
  3755.      $ /'55','75','27','67','87','97'/
  3756.       INTEGER     IMACH            !read machine type
  3757. C
  3758.       INLINE
  3759.         LB         7,X'0CBF'       !get machine type code
  3760.         STW        7,IMACH         !store for use
  3761.       ENDI
  3762.       IF (IMACH .GE. 0 .AND. IMACH .LE. 5) THEN
  3763.         MACH = MACHS(IMACH)
  3764.       ELSE
  3765.         MACH = '**'
  3766.       ENDIF
  3767.       RETURN
  3768.       END
  3769.       SUBROUTINE PRTMSG(STR, VAL)
  3770.            IMPLICIT NONE
  3771.            CHARACTER*(*) STR
  3772.            INTEGER       VAL
  3773. C
  3774. C= Prints a message to output device (normally abort message)
  3775. C
  3776.  1000 FORMAT (X,A,I4)
  3777.       WRITE ('UT',1000,ERR=10) STR, VAL
  3778.  10   CONTINUE
  3779.       RETURN
  3780.       END
  3781.       SUBROUTINE DISPLAY (S)
  3782.            IMPLICIT NONE
  3783.            CHARACTER*(*) S
  3784. C
  3785. C= Display string on console
  3786. C
  3787.       INTEGER      WORD
  3788.       CHARACTER*80 STRING
  3789.         EQUIVALENCE (WORD, STRING) !word bound string
  3790. C
  3791.       STRING = S
  3792.       CALL CARRIAGE
  3793.       CALL M:TELEW(STRING)
  3794.       RETURN
  3795.       END
  3796.       INTEGER FUNCTION NOFIND (STRING,CHARN)
  3797.       IMPLICIT     NONE
  3798. C= Return position of 1st character in STRING that does not match CHARN.
  3799. C
  3800. C                            RETURN THE INDEX OF THE FIRST
  3801. C                            CHARACTER IN STRING THAT DOES
  3802. C                            NOT MATCH CHARN.
  3803. C                            RETURNS 0 IF THE STRINGS MATCH.
  3804. C
  3805. C                            FORMAL PARAMETER DECLARATIONS.
  3806.       CHARACTER*(*) STRING,CHARN
  3807. C
  3808. C                            LOCAL DECLARATIONS.
  3809. C
  3810. C                            LENGTH OF STRING PARAMETER.
  3811.       INTEGER STRLEN
  3812. C                            STRING SEARCH POINTER.
  3813.       INTEGER I
  3814. C                            LENGTH OF STRING FUNCTION
  3815.       INTRINSIC LEN
  3816.  
  3817. C
  3818. C-------------------------------------------------------------------
  3819. C
  3820. C                            FIND LENGTH OF INPUT STRING.
  3821.       STRLEN = LEN(STRING)
  3822. C                            PRESET FUNCTION VALUE TO INDICATE
  3823. C                            SEARCH FAILED TO FIND NON-CHARN
  3824. C                            CHARACTER.
  3825.       NOFIND = 0
  3826. C                            INITIALIZE STRING SEARCH POINTER.
  3827.       I=0
  3828.   10  CONTINUE
  3829. C                            POINT TO NEXT CHARACTER IN STRING
  3830.       I = I + 1
  3831. C                            BEYOND END OF STRING - SEARCH FAILED.
  3832.       IF( I .GT. STRLEN ) GO TO 20
  3833. C                            DO IT AGAIN IF THIS CHARACTER MATCHES.
  3834.       IF( STRING(I:I) .EQ. CHARN ) GO TO 10
  3835. C                            MISMATCH ENCOUNTERED - NOTE
  3836. C                            POSITION AND RETURN.
  3837.       NOFIND = I
  3838. C
  3839.   20  CONTINUE
  3840. C
  3841.       RETURN
  3842.       END
  3843.       INTEGER FUNCTION LASTCHR (STRING)
  3844.       IMPLICIT     NONE
  3845. C= Return position of last non-blank character in STRING.
  3846. C
  3847. C                            FIND THE LAST NON-BLANK CHARACTER
  3848. C                            IN THE INPUT STRING.
  3849. C
  3850. C
  3851.       CHARACTER*(*) STRING   ! GIVEN STRING
  3852. C
  3853. C     RETURNS LASTCHR        ! POSITION OF LAST NON-BLANK CHARACTER
  3854. C                                IN STRING
  3855. C
  3856.       INTEGER CHR
  3857. C
  3858.       INTEGER   LEN
  3859.       INTRINSIC LEN
  3860. C
  3861.       INTEGER     ZERO,ONE
  3862.       PARAMETER  (ZERO=0,ONE=1)
  3863. C     CHARACTER*1 BLANK
  3864. C     PARAMETER  (BLANK=' ')
  3865. C
  3866. C     REVISED 12/08/82, PDM.  CORRECT TREATMENT OF EMPTY LINE.
  3867. C
  3868. C------------------------------------------------------------------
  3869. C
  3870. C
  3871.       CHR = LEN(STRING) + ONE
  3872.   10  CONTINUE
  3873.            CHR = CHR - ONE
  3874.            IF (CHR.LE.ZERO) GOTO 20
  3875.       IF (STRING(CHR:CHR).EQ.' ') GOTO 10
  3876. 20    CONTINUE
  3877. C
  3878.       LASTCHR = CHR
  3879. C
  3880. C
  3881.       RETURN
  3882.       END
  3883.       SUBROUTINE LADJ(STRING)
  3884.       IMPLICIT NONE
  3885. C= Left-justify a string.
  3886. C                            Left-justify a string.
  3887. C-------------------------------------------------------------------
  3888. C Written May 6, 1983 by Fred Preller, Simulation Associates, Inc.
  3889. C-------------------------------------------------------------------
  3890.       CHARACTER*(*) STRING
  3891. C-------------------------------------------------------------------
  3892.       INTEGER       FIRST    ! First non-blank character position
  3893.       CHARACTER*1   BLANK/' '/
  3894. C-------------------------------------------------------------------
  3895.       INTEGER   NOFIND
  3896.       EXTERNAL  NOFIND
  3897. C-------------------------------------------------------------------
  3898.       FIRST = NOFIND(STRING,BLANK)
  3899. C Note the criteria: FIRST = 0   => totally blank line, and
  3900. C                    FIRST = 1   => line already justified.
  3901.       IF( FIRST .GT. 1 ) STRING = STRING(FIRST:)
  3902.       RETURN
  3903.       END
  3904.       SUBROUTINE BREAKR
  3905.            IMPLICIT NONE
  3906. C= Establish break receiver
  3907. C
  3908. C BREAKR ESTABLISHES A BREAK RECEIVER THAT REMAINS ACTIVE AS
  3909. C LONG AS THE TASK IS ACTIVE.  WHEN A BREAK IS RECEIVED, THE
  3910. C BREAK FLAG IS SET.  THE USER MUST CLEAR THE FLAG TO ENSURE
  3911. C THAT SUBSEQUENT BREAKS ARE DETECTED.
  3912. C
  3913.       LOGICAL BREAK
  3914.       COMMON /BREAK/ BREAK
  3915. C
  3916.       CALL X:BRK ($100,,)
  3917.       BREAK = .FALSE.
  3918.       RETURN
  3919. C
  3920. C BREAK ENTRY POINT
  3921.  100  BREAK = .TRUE.
  3922.       CALL X:BRKXIT
  3923. C
  3924.       END
  3925.       SUBROUTINE SLINE(S)
  3926.           CHARACTER*(*)  S   !tsm line
  3927. C
  3928. C= Returns the tsm command line without the execution portion
  3929. C
  3930.       CHARACTER*236  BUFF   !local buffer
  3931.       INTEGER      NRESV    !number of reserved words
  3932.         PARAMETER (NRESV = 5)
  3933.       CHARACTER*8 RWORDS(NRESV)          !reserved pre words
  3934.      $   /'RUN', 'EXECUTE ', 'EXEC', 'DEBU', 'DEBUG'/
  3935.       CHARACTER*8  R                   !reserved word
  3936.       INTEGER   OUT/'OUT'/
  3937.       CHARACTER*1  D                   !delimitor
  3938. C
  3939. C SLINE
  3940. C
  3941.       CALL TLINE(BUFF)                 !get tsm command line
  3942.       CALL LADJ(BUFF)
  3943. C
  3944. C remove leading '$'
  3945. C
  3946.       IF (BUFF(1:1) .EQ. '$') THEN
  3947.         BUFF = BUFF(2:)
  3948.       END IF
  3949.       CALL EXTR(R, D, BUFF)               !possible task name/reserved
  3950. C
  3951. C get rid of leading reserved words
  3952. C
  3953.       DO 20,I=1, NRESV
  3954.         IF (R .EQ. RWORDS(I)) THEN
  3955.           CALL EXTR(R, D, BUFF)         !get task path
  3956.           LEAVE 20
  3957.         END IF
  3958.  20   END DO
  3959. C
  3960. C check for dsc name
  3961. C
  3962.       IF (R(1:1) .EQ. '@' .OR. R(1:1) .EQ. '^' .OR. D .EQ. '(') THEN
  3963.         CALL EXTR(R, D, BUFF)          !extract directory
  3964.         CALL EXTR(R, D, BUFF)          !task name
  3965.       END IF
  3966. C
  3967. C return remander without task name
  3968. C
  3969.       S = BUFF
  3970.       RETURN
  3971.       END
  3972.       SUBROUTINE EXTR(R, D, S)
  3973.            CHARACTER*(*) R             !extracted word
  3974.            CHARACTER*1   D             !delimitor
  3975.            CHARACTER*(*) S             !word to extract from
  3976. C
  3977. C= Extracts the next word based on TSM's delimitors
  3978. C
  3979.       CHARACTER*9 DELIM /' ,()=;$!%'/  !delimitors
  3980.       CHARACTER*2 QUOTES /'''""'/      !quotes
  3981.       INTEGER      NS                  !length of S
  3982.       INTEGER      I
  3983.       LOGICAL      QUOTE           !in quote
  3984.       CHARACTER*1  QUOTECH         !character used in quote
  3985. C
  3986. C functions
  3987. C
  3988.       INTEGER      NOFIND              !look until not found
  3989. C
  3990. C extr
  3991. C
  3992.       QUOTE = .FALSE.
  3993.       NS = LEN(S)
  3994.       I = 1
  3995.       DO 20, WHILE (I .LE. NS)
  3996.         IF (QUOTE) THEN
  3997.           IF (S(I:I) .EQ. QUOTECH) THEN
  3998.              QUOTE = .FALSE.
  3999.           ENDIF
  4000.         ELSE
  4001.           IF (INDEX(QUOTES, S(I:I)) .GT. 0) THEN
  4002.             QUOTECH = S(I:I)
  4003.             QUOTE = .TRUE.
  4004.           ELSE IF (INDEX(DELIM, S(I:I)) .GT. 0) THEN
  4005.             LEAVE 20
  4006.           ENDIF
  4007.         END IF
  4008.         I = I + 1
  4009.  20   END DO
  4010. C
  4011. C returned field
  4012. C
  4013.       IF (I .GT. NS) THEN
  4014.         R = S
  4015.       ELSE IF (I .EQ. 1) THEN
  4016.         R = ' '
  4017.       ELSE
  4018.         R = S(:I-1)
  4019.       END IF
  4020. C
  4021. C delimitor
  4022. C
  4023.       IF (I .GT. NS) THEN
  4024.         D = ' '
  4025.       ELSE
  4026.         D = S(I:I)
  4027.       END IF
  4028. C
  4029. C new buffer
  4030. C
  4031.       IF (I .GT. NS) THEN
  4032.         S = ' '
  4033.       ELSE IF (I .EQ. NS) THEN
  4034.         S = ' '
  4035.       ELSE
  4036.         S = S(I+1:)
  4037.       END IF
  4038. C
  4039. C remove trailing blanks
  4040. C
  4041.       I = NOFIND(S, ' ')
  4042.       IF (I .GT. 0) S = S(I:)
  4043.       RETURN
  4044.       END
  4045.       LOGICAL FUNCTION ISFILE(PATHNAME)
  4046.            IMPLICIT NONE
  4047.            CHARACTER*(*)PATHNAME            !PATH TO CHECK
  4048. C
  4049. C= Tests to determine if file specified in path exists
  4050. C
  4051.       INTEGER*4    RDBUFFER(8)         !RESOURCE DESCR. BUFFER
  4052.       INTEGER*4    ERRSTAT             !ERROR STATUS
  4053. C
  4054. C
  4055.       CALL X_RID(PATHNAME,RDBUFFER,ERRSTAT)
  4056.       ISFILE = ERRSTAT .EQ. 0
  4057.       RETURN
  4058.       END
  4059.       INTEGER FUNCTION XTOI(S)
  4060.            IMPLICIT NONE
  4061.            CHARACTER*(*)   S           !hex number in ascii
  4062. C          return          integer value
  4063. C
  4064. C= Converts an ascii hex string to integer number
  4065. C
  4066.       INTEGER      N                   !length of string
  4067.       INTEGER      I                   !string pointer
  4068.       INTEGER      C                   !ascii value
  4069.       INTEGER      ZERO/X'30'/         !ascii zero
  4070.       INTEGER      NINE/X'39'/
  4071.       INTEGER      A   /X'41'/
  4072.       INTEGER      F   /X'46'/
  4073. C
  4074. C functions
  4075. C
  4076.       INTEGER      ICHAR               !char to integer value
  4077.       INTEGER      LEN                 !length of string
  4078. C
  4079. C xtoi
  4080. C
  4081.       N = LEN(S)
  4082.       I = 1
  4083.       XTOI = 0
  4084.       DO WHILE (I .LT. N .AND. S(I:I) .EQ. ' ')
  4085.         I = I + 1
  4086.       END DO
  4087.       DO 20 WHILE (I .LE. N)
  4088.         C = ICHAR(S(I:I))
  4089.         IF (C .GE. ZERO .AND. C .LE. NINE) THEN
  4090.           C = C - ZERO
  4091.         ELSE IF (C .GE. A .AND. C  .LE. F) THEN
  4092.           C = C - A + 10
  4093.         ELSE
  4094.           LEAVE 20
  4095.         END IF
  4096.         INLINE
  4097.           LW     6,XTOI     !get previous value
  4098.           LW     7,C        !get current value to add
  4099.           SLL    7,28       !left justify
  4100.           SLLD   6,4        !move into xtoi
  4101.           STW    6,XTOI      !done
  4102.         ENDI
  4103.         I = I + 1
  4104.  20   END DO
  4105.       RETURN
  4106.       END
  4107.       CHARACTER*(*) FUNCTION ITOX (X)
  4108.            IMPLICIT NONE
  4109.            INTEGER       X   !hex value
  4110. C
  4111. C= Convert integer to hex ascii string
  4112. C  forces a leading numeric character
  4113. C
  4114.       CHARACTER*9  T                   !temporary string
  4115.       INTEGER      I                   !sting pointer
  4116.       INTEGER      J                   !local value to convert
  4117.       INTEGER      C                   !convertion value
  4118.       INTEGER      A/X'41'/
  4119.       INTEGER      F/X'46'/
  4120.       INTEGER      ZERO/X'30'/
  4121.       INTEGER      NINE/X'39'/
  4122. C
  4123. C functions
  4124. C
  4125.       CHARACTER*1  CHAR                !integer to character function
  4126. C
  4127. C ITOX
  4128. C
  4129.       J = X
  4130.       T = ' '
  4131.       I = 9
  4132.       DO UNTIL (J .EQ. 0)
  4133.         INLINE
  4134.           LW       6,J                 !get current value
  4135.           SRLD     6,4                 !get first hex value
  4136.           SRL      7,28                !right justify
  4137.           STW      7,C                 !convert
  4138.           STW      6,J                 !new value
  4139.         ENDI
  4140.         IF (C .GE. 10) THEN
  4141.           C = C - 10 + A
  4142.         ELSE
  4143.           C = C + ZERO
  4144.         END IF
  4145.         T(I:I) = CHAR(C)
  4146.         I = I - 1
  4147.       END DO
  4148.       IF (T(I+1:I+1) .GT. 'A') THEN
  4149.         T(I:I) = CHAR(ZERO)
  4150.       END IF
  4151.       CALL LADJ(T)
  4152.       ITOX = T
  4153.       RETURN
  4154.       END
  4155.       CHARACTER*(*) FUNCTION ITOA (I)
  4156.            IMPLICIT NONE
  4157.            INTEGER       I             !integer to output
  4158. C
  4159. C= Converts an integer number to an ascii string
  4160. C
  4161.       CHARACTER*20   BUF               !local buffer
  4162.       INTEGER        J                 !local integer value
  4163. C
  4164. C format
  4165. C
  4166.  1000 FORMAT (I20)
  4167. C
  4168. C itoa
  4169. C
  4170.       J = I
  4171.       WRITE (BUF, 1000, ERR=10) J
  4172.       CALL LADJ(BUF)
  4173.       ITOA = BUF
  4174.       RETURN
  4175.  10   CONTINUE
  4176.       ITOA = '0'
  4177.       RETURN
  4178.       END
  4179.       SUBROUTINE GETEMSG(STRNG)
  4180.            IMPLICIT NONE
  4181.            INTEGER  STRNG(200)
  4182. C
  4183. C= Produce an error message string for the current error
  4184. CLT 2.3 THIS ROUTINE TRW'D TO PRODUCE CORRECT ERROR MESSAGES
  4185. C
  4186.       INCLUDE      'KDEF.INS'
  4187.       INCLUDE      'KPROT.COM'
  4188. C
  4189.       INTEGER      I
  4190. C
  4191.       I = 1
  4192.       IF (ABORTYP(SENDING)) THEN
  4193.         CALL DPC2AS('SENDING',STRNG(I), 7)
  4194.         I = I + 7
  4195.       ELSE
  4196.         CALL DPC2AS('RECEIVING',STRNG(I),9)
  4197.         I = I + 9
  4198.       ENDIF
  4199.       IF (ABORTYP(INITERR)) THEN
  4200.         CALL DPC2AS(' INIT',STRNG(I),5)
  4201.         I = I + 5
  4202.       ELSE IF (ABORTYP(FILERR)) THEN
  4203.         CALL DPC2AS(' FILE NAME',STRNG(I),10)
  4204.         I = I + 10
  4205.       ELSE IF (ABORTYP(DATAERR)) THEN
  4206.         CALL DPC2AS(' DATA',STRNG(I),5)
  4207.         I = I + 5
  4208.       ELSE IF (ABORTYP(EOFERR)) THEN
  4209.         CALL DPC2AS(' EOF',STRNG(I),4)
  4210.         I = I + 4
  4211.       ELSE
  4212.         CALL DPC2AS(' BREAK',STRNG(I),6)
  4213.         I = I + 6
  4214.       ENDIF
  4215.       CALL DPC2AS(' PACKET,',STRNG(I),7)
  4216.       I = I + 7
  4217.       IF (ABORTYP(TOOMANY)) THEN
  4218.         CALL DPC2AS(' TOO MANY RETRIES',STRNG(I),17)
  4219.         I = I + 17
  4220.       ELSE IF (ABORTYP(INVALID)) THEN
  4221.         CALL DPC2AS(' RECV. INVALID PACKET',STRNG(I),20)
  4222.         I = I + 20
  4223.       ELSE IF (ABORTYP(SEQERR)) THEN
  4224.         CALL DPC2AS(' RECV. OUT OF SEQ. PACKET',STRNG(I),25)
  4225.         I = I + 25
  4226.       ELSE IF (ABORTYP(LCLFILE)) THEN
  4227.         CALL DPC2AS(' FAILED TO OPEN FILE',STRNG(I), 21)
  4228.         I = I + 21
  4229.       ELSE
  4230.         CALL DPC2AS(' UNANTICIPATED ERROR',STRNG(I),20)
  4231.         I = I + 20
  4232.       ENDIF
  4233.       STRNG(I) = 0
  4234.       I = I+1
  4235.       RETURN
  4236.       END
  4237.       BLOCK DATA BDFILECO
  4238.            IMPLICIT NONE
  4239. C
  4240. C= Initialize the filecom common
  4241. C
  4242.       INCLUDE      'KFILE.COM'
  4243. C
  4244.       DATA FMODE/MAXFILE*CLOSED/   !close all units
  4245.       DATA FCHPTR /MAXFILE*0/
  4246.       DATA FCHCNT /MAXFILE*0/
  4247.       DATA FEOF /MAXFILE*.FALSE./
  4248.       DATA CTDEV /MAXFILE*.FALSE./
  4249.       DATA FREQ /MAXFILE*0/
  4250.       DATA IOPEND /MAXFILE*NOIO/
  4251.       DATA NOWAIT /MAXFILE*.FALSE./
  4252.       DATA BINARY /MAXFILE*.FALSE./
  4253.       DATA FTIMOUT/MAXFILE* 0/
  4254.       END
  4255.       INTEGER FUNCTION OPEN(FN, MODE)
  4256.            IMPLICIT NONE
  4257.            CHARACTER*(*) FN        !file name
  4258.            CHARACTER*(*) MODE      !mode of file ('R','W')
  4259. C
  4260. C= o Opens a file as specified, returns file index
  4261.       INCLUDE      'KFILE.COM'
  4262. C
  4263.       INTEGER      I               !indexing
  4264.       CHARACTER*8  FILESTAT        !file status for open
  4265.       INTEGER      IOS             !status of open
  4266.       INTEGER      IMODE           !translated mode code
  4267.       INTEGER      ALTLFC          !altlfc to assign to
  4268.       CHARACTER*4  CALTLFC         !character form of alt lfc
  4269.         EQUIVALENCE (CALTLFC, ALTLFC)
  4270.       CHARACTER*1  OPENMODE        !access mode
  4271. C
  4272.       INTEGER      ICHAR           !character to integer
  4273. C
  4274.       IF (MODE .EQ. 'R') THEN
  4275.         IMODE = RD
  4276.       ELSE IF (MODE .EQ. 'W' .OR. MODE .EQ. 'C') THEN
  4277.         IMODE = WR
  4278.       ELSE
  4279.         CALL PRTMSG('OPEN - invalid mode',ICHAR(MODE))
  4280.         OPEN = ERROR
  4281.         RETURN
  4282.       ENDIF
  4283.       DO I=1, MAXFILE              !handle duplicates
  4284. C
  4285. C handle duplicate entries
  4286. C
  4287.         IF (FMODE(I) .NE. CLOSED) THEN     !if open
  4288.           IF (FNAME(I) .EQ. FN) THEN     !if duplicate
  4289.             IF (FMODE(I) .EQ. IMODE) THEN   !if same mode, ignore
  4290.               IF (CTDEV(I)) THEN            !if device, flush, ready
  4291.                 CALL FLUSH(I)
  4292.                 OPEN = I
  4293.                 RETURN
  4294.               ELSE                         !if file, rewind
  4295.                 CALL FLUSH(I)
  4296.                 CALL CLOSE(I)
  4297.               ENDIF
  4298.             ELSE                       !if mode different, reopen
  4299.               IF (CTDEV(I)) THEN       !if device, not really dupl.
  4300.                 CONTINUE
  4301.               ELSE                     !if file, close so can reopen
  4302.                 CALL FLUSH(I)
  4303.                 CALL CLOSE(I)
  4304.               ENDIF
  4305.             ENDIF
  4306.           ENDIF
  4307.         ENDIF
  4308.       ENDDO
  4309. C
  4310. C find slot
  4311. C
  4312.       OPEN = 1
  4313.       DO WHILE (OPEN .LT. MAXFILE .AND. FMODE(OPEN) .NE. CLOSED)
  4314.         OPEN = OPEN + 1
  4315.       ENDDO
  4316.       IF (FMODE(OPEN) .NE. CLOSED) THEN
  4317.         OPEN = ERROR
  4318.         CALL PRTMSG('OPEN - Exceed allowed number of files',MAXFILE)
  4319.         RETURN
  4320.       ENDIF
  4321. C
  4322. C open
  4323. C
  4324.       FNAME(OPEN) = FN
  4325.       FCHPTR(OPEN) = 1
  4326.       FCHCNT(OPEN) = 0
  4327.       FMODE(OPEN) = IMODE
  4328.       FEOF(OPEN) = .FALSE.
  4329.       CTDEV(OPEN) = .FALSE.
  4330.       FREQ(OPEN) = MAXCH
  4331.       IOPEND(OPEN) = NOIO
  4332.       NOWAIT(OPEN) = .FALSE.
  4333.       FTIMOUT(OPEN) = 0
  4334.       BINARY(OPEN) = .FALSE.
  4335.       DO I=1, 4
  4336.         FBLK(I, OPEN) = 0
  4337.       ENDDO
  4338.       DO I=1, MAXCH
  4339.         FCHBUF(I, OPEN) = 0
  4340.       ENDDO
  4341. C
  4342. C if standard i/o, connect to user terminal
  4343. C
  4344.       IF (FNAME(OPEN) .EQ. 'STDIN' .OR. FNAME(OPEN) .EQ. 'STDOUT') THEN
  4345.         OPEN (UNIT=OPEN, ALTUNIT='UT', IOSTAT=IOS, ERR=910)
  4346.         CTDEV(OPEN) = .TRUE.
  4347.         FREQ(OPEN) = 133
  4348. C
  4349. C if terminal - all terminals begin with @
  4350. C
  4351.       ELSE IF (FNAME(OPEN)(1:1) .EQ. '@') THEN
  4352.         FNAME(OPEN) = FNAME(OPEN)(2:)
  4353.         OPEN (UNIT=OPEN, DEVICE=FNAME(OPEN),
  4354.      $        WAIT=.FALSE.,
  4355.      $        IOSTAT=IOS, ERR=910)
  4356.         CTDEV(OPEN) = .TRUE.
  4357.         FREQ(OPEN) = 133
  4358. C
  4359. C must be file
  4360. C
  4361.       ELSE
  4362.         IF (FMODE(OPEN) .EQ. RD) THEN
  4363.           FILESTAT='OLD'
  4364.           OPENMODE = 'R'
  4365.         ELSE
  4366.           FILESTAT='UNKNOWN'
  4367.           OPENMODE = 'U'
  4368.         ENDIF
  4369.         OPEN(UNIT=OPEN, FILE=FNAME(OPEN),
  4370.      $         BLOCKED=.TRUE., FORM='FORMATTED',
  4371.      $         WAIT=.FALSE.,STATUS=FILESTAT,
  4372.      $         OPENMODE = OPENMODE,
  4373.      $         IOSTAT=IOS, ERR=910)
  4374.       ENDIF
  4375.       CALL BLKINIT(OPEN)
  4376.       RETURN
  4377. C
  4378. C open error
  4379. C
  4380.  910  CONTINUE
  4381.       FMODE(OPEN) = CLOSED
  4382.       OPEN = -IOS
  4383.       RETURN
  4384.       END
  4385.       SUBROUTINE BLKINIT(FD)
  4386.            IMPLICIT NONE
  4387.            INTEGER    FD           !file descriptor
  4388. C
  4389. C= Calls fcbinit with proper function code for current flags
  4390. C
  4391.       INCLUDE      'KFILE.COM'
  4392. C
  4393.       INTEGER      FUNC            !function code
  4394.       INTEGER      NOWAITW/X'80000000'/  !nowait operation
  4395.       INTEGER      DFI    /X'20000000'/  !use io spec we specify
  4396.       INTEGER      XXWORD /X'00100000'/  !xon/xoff protocol
  4397.       INTEGER      EXP    /X'02000000'/  !expanded fcb
  4398.       INTEGER      NOERR  /X'40000000'/  !no error branch
  4399.       INTEGER      CONTROL/X'00800000'/  !control character detect
  4400.       INTEGER      NOECHO /X'00400000'/  !do not echo down port
  4401.       INTEGER      NOUPPER/X'00200000'/  !do not convert to upper case
  4402.       INTEGER      SPCHRW /X'00100000'/  !special character detect
  4403.       INTEGER      PURGEW /X'00080000'/  !purge type ahead buffer
  4404. C
  4405.       IF (CTDEV(FD)) THEN
  4406.         IF (FMODE(FD) .EQ. RD) THEN
  4407.           IF (BINARY(FD)) THEN
  4408.             FUNC = NOERR + EXP + DFI + CONTROL + NOECHO + NOUPPER
  4409.           ELSE
  4410.             FUNC = NOERR + EXP
  4411.           ENDIF
  4412.         ELSE       !write
  4413.           FUNC = NOERR + EXP + DFI
  4414.         ENDIF
  4415.       ELSE         !disk read/write
  4416.         FUNC = NOERR + EXP
  4417.       ENDIF
  4418.       IF (NOWAIT(FD)) FUNC = FUNC + NOWAITW
  4419.       CALL FCBINIT(FD, FBLK(1, FD), FUNC, FREQ(FD))
  4420.       RETURN
  4421.       END
  4422.       SUBROUTINE CLOSE(FD)
  4423.            IMPLICIT NONE
  4424.            INTEGER    FD           !file descriptor
  4425. C
  4426. C= Closes an opened file.
  4427. C
  4428.       INCLUDE      'KFILE.COM'
  4429. C
  4430.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
  4431.         CONTINUE                   !ignore errors
  4432.       ELSE IF (FMODE(FD) .EQ. CLOSED) THEN
  4433.         CONTINUE                   !already closed
  4434.       ELSE
  4435.         CALL FLUSH(FD)
  4436.         CLOSE(UNIT=FD)
  4437.         FMODE(FD) = CLOSED
  4438.       ENDIF
  4439.       RETURN
  4440.       END
  4441.       SUBROUTINE FLUSH(FD)
  4442.            IMPLICIT NONE
  4443.            INTEGER   FD            !file descriptor
  4444. C
  4445. C= forces output of buffer
  4446. C
  4447.       INCLUDE      'KFILE.COM'
  4448. C
  4449.       INTEGER*1    LBUF(MAXCH,  MAXFILE)  !local buffers for nowait
  4450.       INTEGER      I
  4451. C
  4452.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
  4453.         RETURN
  4454.       ELSE IF (FMODE(FD) .EQ. CLOSED) THEN
  4455.         RETURN
  4456.       ELSE
  4457.         IF (FMODE(FD) .EQ. WR .AND. FCHCNT(FD) .GT. 0) THEN
  4458.           IF (IOPEND(FD) .EQ. NOIO) THEN
  4459.             IF (NOWAIT(FD)) THEN
  4460.               IOPEND(FD) = IOSTART
  4461.               DO I=1, FCHCNT(FD)
  4462.                 LBUF(I, FD) = FCHBUF(I, FD)
  4463.               ENDDO
  4464.               GOTO (10,20,30,40,50,60,70,80,90,100) FD
  4465.  10           CONTINUE
  4466.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
  4467.      $           *801, *801)
  4468.               GOTO 150
  4469.  20           CONTINUE
  4470.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
  4471.      $           *802, *802)
  4472.               GOTO 150
  4473.  30           CONTINUE
  4474.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
  4475.      $           *803, *803)
  4476.               GOTO 150
  4477.  40           CONTINUE
  4478.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
  4479.      $           *804, *804)
  4480.               GOTO 150
  4481.  50           CONTINUE
  4482.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
  4483.      $           *805, *805)
  4484.               GOTO 150
  4485.  60           CONTINUE
  4486.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
  4487.      $           *806, *806)
  4488.               GOTO 150
  4489.  70           CONTINUE
  4490.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
  4491.      $           *807, *807)
  4492.               GOTO 150
  4493.  80           CONTINUE
  4494.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
  4495.      $           *808, *808)
  4496.               GOTO 150
  4497.  90           CONTINUE
  4498.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
  4499.      $           *809, *809)
  4500.               GOTO 150
  4501.  100           CONTINUE
  4502.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
  4503.      $           *810, *810)
  4504.               GOTO 150
  4505.  150          CONTINUE
  4506.             ELSE
  4507.               IOPEND(FD) = NOIO
  4508.               CALL DPWRITE(FBLK(1, FD), FCHBUF(1, FD), FCHCNT(FD), 0)
  4509.             ENDIF
  4510.           ENDIF
  4511.         ELSE IF (FMODE(FD) .EQ. RD .AND. IOPEND(FD) .EQ. IOSTART) THEN
  4512.           CALL HIO(FD)
  4513. CLT       DO I=1, MAXFILE
  4514. CLT         IF (FMODE(I) .EQ. WR .AND. IOPEND(I) .EQ. IOSTART)
  4515. CLT  $        CALL X:EAWAIT(0,,)
  4516. CLT         IF (IOPEND(I) .EQ. IOSTART) IOPEND(I) = NOIO
  4517. CLT       ENDDO
  4518. CLT       CALL HIOALL              !this is going to hurt somewhere
  4519.         ENDIF
  4520.         FCHPTR(FD) = 1
  4521.         FCHCNT(FD) = 0
  4522.       ENDIF
  4523.       RETURN
  4524. C
  4525. C end action
  4526. C
  4527.  801  IOPEND( 1) = NOIO; CALL X:XNWIO
  4528.  802  IOPEND( 2) = NOIO; CALL X:XNWIO
  4529.  803  IOPEND( 3) = NOIO; CALL X:XNWIO
  4530.  804  IOPEND( 4) = NOIO; CALL X:XNWIO
  4531.  805  IOPEND( 5) = NOIO; CALL X:XNWIO
  4532.  806  IOPEND( 6) = NOIO; CALL X:XNWIO
  4533.  807  IOPEND( 7) = NOIO; CALL X:XNWIO
  4534.  808  IOPEND( 8) = NOIO; CALL X:XNWIO
  4535.  809  IOPEND( 9) = NOIO; CALL X:XNWIO
  4536.  810  IOPEND(10) = NOIO; CALL X:XNWIO
  4537.       END
  4538.       SUBROUTINE PUTC(FD, TCH)
  4539.            IMPLICIT NONE
  4540.            INTEGER    FD     !file descriptor
  4541.            INTEGER    TCH    !character to output
  4542. C
  4543. C= outputs a character
  4544. C
  4545. C **** NOTE: tricky stuff, no difference between terminal
  4546. C      outputs in binary or ascii, but in binary NEL's are
  4547. C      not interpreted.  So don't put term in binary unless
  4548. C      you really mean it.
  4549. C
  4550. C
  4551.       INCLUDE      'KFILE.COM'
  4552. C
  4553.       INTEGER      CH
  4554.       INTEGER      I
  4555. C
  4556.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
  4557.         CONTINUE
  4558.       ELSE IF (FMODE(FD) .EQ. WR) THEN
  4559.         CH = TCH
  4560.         IF (.NOT. BINARY(FD) .AND. TCH .EQ. NEL) THEN
  4561.           CH = CR
  4562.           IF (.NOT. CTDEV(FD)) GOTO 20
  4563.         ENDIF
  4564.  10     CONTINUE
  4565.         IF (FCHCNT(FD) .GE. FREQ(FD)) CALL FLUSH(FD)
  4566.         IF (FCHCNT(FD) .LT. MAXCH) THEN
  4567.           FCHCNT(FD) = FCHCNT(FD) + 1
  4568.           FCHBUF(FCHCNT(FD), FD) = CH
  4569.         ENDIF
  4570.         IF (FCHCNT(FD) .GE. FREQ(FD)) CALL FLUSH(FD)
  4571.         IF (TCH .EQ. NEL .AND. CH .EQ. CR) THEN
  4572.           CH = LF
  4573.           GOTO 10
  4574.         ENDIF
  4575.  20     CONTINUE
  4576. C
  4577. C end of line processing
  4578. C
  4579.         IF (.NOT. BINARY(FD) .AND. TCH .EQ. NEL) THEN
  4580. C
  4581. C if text file, strip trailing blanks, cr, lf
  4582. C
  4583.           IF (.NOT. CTDEV(FD)) THEN
  4584.             I = FCHCNT(FD)
  4585.             DO WHILE (I .GT. 0)
  4586.               IF (FCHBUF(I, FD) .EQ. BLANK .OR. FCHBUF(I, FD) .EQ.
  4587.      $            CR .OR. FCHBUF(I, FD) .EQ. LF) THEN
  4588.                 I = I - 1
  4589.               ELSE
  4590.                 LEAVE
  4591.               ENDIF
  4592.             ENDDO
  4593.             IF (I .LE. 0) THEN
  4594.               I = I + 1
  4595.               FCHBUF(I, FD) = BLANK
  4596.             ENDIF
  4597.             FCHCNT(FD) = I
  4598.           ENDIF
  4599.           CALL FLUSH(FD)                   !force out
  4600.         ENDIF
  4601.       ENDIF
  4602.       RETURN
  4603.       END
  4604.       INTEGER FUNCTION GETC(FD, CH)
  4605.            IMPLICIT NONE
  4606.            INTEGER    FD           !file descriptor
  4607.            INTEGER    CH           !character read in
  4608. C
  4609. C= Reads a character from input buffer, reads if necessary
  4610. C
  4611.       INCLUDE      'KFILE.COM'
  4612. C
  4613.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
  4614.         CH = ERROR
  4615.       ELSE IF (FMODE(FD) .EQ. RD) THEN
  4616.         IF (FCHPTR(FD) .GT. FCHCNT(FD)) CALL FILL(FD)
  4617.         IF (FEOF(FD)) THEN
  4618.           CH = EOF
  4619.         ELSE IF (FCHPTR(FD) .GT. FCHCNT(FD)) THEN
  4620.           CH = ERROR
  4621.         ELSE
  4622.           CH = FCHBUF(FCHPTR(FD), FD)
  4623.           FCHPTR(FD) = FCHPTR(FD) + 1
  4624.         ENDIF
  4625.       ELSE
  4626.         CH = ERROR
  4627.       ENDIF
  4628.       GETC = CH
  4629.       RETURN
  4630.       END
  4631.       SUBROUTINE FILL(FD)
  4632.            IMPLICIT NONE
  4633.            INTEGER    FD   !file descriptor
  4634. C
  4635. C= Fills the respective fd's buffer
  4636. C
  4637.       INCLUDE      'KFILE.COM'
  4638. C
  4639.       INTEGER      STATUS          !status of io done
  4640.       INTEGER      I               !temp count
  4641. C
  4642.       INTEGER      DPCOUNT         !retreive count of transfer
  4643.       INTEGER      DERROR          !error code
  4644. C
  4645.       IF (IOPEND(FD) .EQ. NOIO) THEN
  4646.         IF (NOWAIT(FD)) THEN
  4647.           IOPEND(FD) = IOSTART
  4648.           GOTO (10, 20, 30, 40, 50, 60, 70, 80, 90, 100) FD
  4649.  10       CONTINUE
  4650.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*801,*801)
  4651.             GOTO 150
  4652.  20      CONTINUE
  4653.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*802,*802)
  4654.             GOTO 150
  4655.  30       CONTINUE
  4656.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*803,*803)
  4657.             GOTO 150
  4658.  40      CONTINUE
  4659.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*804,*804)
  4660.             GOTO 150
  4661.  50      CONTINUE
  4662.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*805,*805)
  4663.             GOTO 150
  4664.  60       CONTINUE
  4665.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*806,*806)
  4666.             GOTO 150
  4667.  70      CONTINUE
  4668.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*807,*807)
  4669.             GOTO 150
  4670.  80      CONTINUE
  4671.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*808,*808)
  4672.             GOTO 150
  4673.  90       CONTINUE
  4674.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*809,*809)
  4675.             GOTO 150
  4676.  100     CONTINUE
  4677.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*810,*810)
  4678.             GOTO 150
  4679.  150      CONTINUE
  4680.           IF (FTIMOUT(FD) .GT. 0) THEN
  4681.             CALL X:EAWAIT(-FTIMOUT(FD)*20,,)
  4682.             IF (IOPEND(FD) .EQ. IOSTART) THEN
  4683.               CALL HIO(FD)
  4684.               CALL X:EAWAIT(-FTIMOUT(FD)*20,,)
  4685.             ENDIF
  4686.           ENDIF
  4687.         ELSE
  4688.           CALL DPREAD(FBLK(1, FD), FCHBUF(1, FD), FREQ(FD), 0)
  4689.           IOPEND(FD) = IOCOMP
  4690.         ENDIF
  4691.       ENDIF
  4692.       IF (IOPEND(FD) .EQ. IOCOMP) THEN
  4693.         IOPEND(FD) = NOIO
  4694.         FCHPTR(FD) =1
  4695.         FCHCNT(FD) = DPCOUNT(FBLK(1, FD))
  4696.         IF (.NOT. BINARY(FD)) THEN
  4697.           IF (CTDEV(FD)) THEN
  4698.             FCHCNT(FD) = FCHCNT(FD) + 1
  4699.             FCHBUF(FCHCNT(FD), FD) = NEL
  4700.           ELSE
  4701.             I = FCHCNT(FD)
  4702.             DO WHILE (I .GT. 0)
  4703.               IF (FCHBUF(I,FD) .EQ. BLANK) THEN
  4704.                 I = I - 1
  4705.               ELSE
  4706.                 LEAVE
  4707.               ENDIF
  4708.             ENDDO
  4709.             I = I + 1
  4710.             FCHBUF(I, FD) = NEL
  4711.             FCHCNT(FD) = I
  4712.           ENDIF
  4713.         ENDIF
  4714.         STATUS = DERROR(FBLK(1, FD))
  4715.         IF (STATUS .EQ. 3 .OR. STATUS .EQ. 4) FEOF(FD) = .TRUE.
  4716.       ENDIF
  4717.       RETURN
  4718. C
  4719. C end action
  4720. C
  4721.  801  IOPEND(1) = IOCOMP; CALL X:XNWIO
  4722.  802  IOPEND(2) = IOCOMP; CALL X:XNWIO
  4723.  803  IOPEND(3) = IOCOMP; CALL X:XNWIO
  4724.  804  IOPEND(4) = IOCOMP; CALL X:XNWIO
  4725.  805  IOPEND(5) = IOCOMP; CALL X:XNWIO
  4726.  806  IOPEND(6) = IOCOMP; CALL X:XNWIO
  4727.  807  IOPEND(7) = IOCOMP; CALL X:XNWIO
  4728.  808  IOPEND(8) = IOCOMP; CALL X:XNWIO
  4729.  809  IOPEND(9) = IOCOMP; CALL X:XNWIO
  4730.  810  IOPEND(10)= IOCOMP; CALL X:XNWIO
  4731.       END
  4732.       SUBROUTINE STTY(FD, FIELD, VALUE)
  4733.            IMPLICIT NONE
  4734.            INTEGER    FD    !port to set
  4735.            CHARACTER*(*) FIELD    !field to set
  4736.            INTEGER       VALUE     !value to set to
  4737. C
  4738. C= Sets the specified field to the value
  4739. C
  4740.       INCLUDE      'KVER.INS'
  4741.       INCLUDE      'KFILE.COM'
  4742.       LOGICAL*1    TTYECHO(MAXFILE)  !local memory for echo
  4743. C
  4744.       LOGICAL      TUDT            !test user device table
  4745. C
  4746. C
  4747.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
  4748.         CONTINUE
  4749.       ELSE IF (FMODE(FD)  .EQ. CLOSED) THEN
  4750.         CONTINUE
  4751. C
  4752. C binary mode
  4753. C
  4754.       ELSE IF (FIELD .EQ. 'BINARY') THEN
  4755.         BINARY(FD) = VALUE .EQ. 1
  4756.         CALL BLKINIT(FD)
  4757. C
  4758. C TIMEOUT
  4759. C
  4760.       ELSE IF (FIELD .EQ. 'TIMEOUT') THEN
  4761.         FTIMOUT(FD) = VALUE
  4762. C
  4763. C nowait
  4764. C
  4765.       ELSE IF (FIELD .EQ. 'NOWAIT') THEN
  4766.         NOWAIT(FD) = VALUE .EQ. 1
  4767.         CALL BLKINIT(FD)
  4768.         IF (FMODE(FD) .EQ. RD) THEN
  4769. C
  4770. C This section is used to enable timeouts since
  4771. C gould doesn't support a timeout on a normal read.
  4772. C You must be privileged to do this stuff
  4773. C
  4774.           IF (LOCALON) THEN
  4775.             IF (NOWAIT(FD)) THEN
  4776. C
  4777. CLT 2.3 CORRECTED TURNING ECHO ON AND OFF
  4778. C In this section (which incidentially must be called first) we
  4779. C memorize the previous condition of the udt so we can restore
  4780. C it to correct mode.  This is part of rev. 2.3.  This feature
  4781. C is particularly important for those using a network for file
  4782. C transmittal since they don't have echo on any way.
  4783. C
  4784.               TTYECHO(FD) = TUDT(FBLK(1, FD), 'ECHO')
  4785.               IF (TTYECHO(FD)) THEN
  4786.                 CALL SUDT(FBLK(1, FD), 'NOEC')    !make sure
  4787.               ENDIF
  4788.               CALL SUDT(FBLK(1, FD), 'DUAL')
  4789.             ELSE
  4790.               CALL SUDT(FBLK(1, FD), 'SING')
  4791.               IF (TTYECHO(FD)) THEN
  4792.                 CALL SUDT(FBLK(1, FD), 'ECHO')    !may be right
  4793.               ENDIF
  4794.             ENDIF
  4795.           ENDIF
  4796.         ENDIF
  4797. C
  4798. C readsize
  4799. C
  4800.       ELSE IF (FIELD .EQ. 'SIZE') THEN
  4801.         IF (VALUE .GT. 0) THEN
  4802.           FREQ(FD) = VALUE
  4803.         ELSE
  4804.           FREQ(FD) = MAXCH
  4805.         ENDIF
  4806.         IF (FREQ(FD) .GT. MAXCH) FREQ(FD) = MAXCH
  4807.         CALL BLKINIT(FD)
  4808. C
  4809. C unrecognized field
  4810. C
  4811.       ELSE
  4812.         CONTINUE
  4813.       ENDIF
  4814.       RETURN
  4815.       END
  4816.       SUBROUTINE UNGETC(FD, CH)
  4817.            IMPLICIT NONE
  4818.            INTEGER   FD            !file descriptor
  4819.            INTEGER   CH            !character put back
  4820. C
  4821. C= Try to put a character back into the input stream
  4822. C
  4823. C  Ungetc can only put back characters as far as the beginning
  4824. C  of the buffer.  Hopefully, this is ok, since only getword
  4825. C  does this with an nel which should be well into the buffer.
  4826. C
  4827.       INCLUDE      'KFILE.COM'
  4828. C
  4829.       IF (FCHPTR(FD) .GT. 1) THEN
  4830.         FCHPTR(FD) = FCHPTR(FD) - 1
  4831.         FCHBUF(FCHPTR(FD), FD) = CH
  4832.       ENDIF
  4833.       RETURN
  4834.       END
  4835.       INTEGER FUNCTION GETWORD(FD, STR, MAXLEN)
  4836.            IMPLICIT NONE
  4837.            INTEGER    FD   !file descriptor
  4838.            INTEGER    STR(*)  !string to read to
  4839.            INTEGER    MAXLEN !max size of string
  4840. C
  4841. C= get a word from an input stream
  4842. C
  4843. C  Getword considers a word to be delimited by blanks.
  4844. C  It will return the length of the word as its value.
  4845. C
  4846.       INCLUDE      'KFILE.COM'
  4847. C
  4848.       INTEGER      LEN             !length of string
  4849.       INTEGER      CH              !character
  4850. C
  4851.       INTEGER      GETC            !get character
  4852. C
  4853.       LEN = 0
  4854. C
  4855. C skip leading white space
  4856. C
  4857.  10   CONTINUE
  4858.       IF (GETC(FD, CH) .EQ. EOF) THEN
  4859.         GETWORD = EOF
  4860.         RETURN
  4861.       ELSE IF (CH .EQ. NEL) THEN
  4862.         GETWORD = 0
  4863.         RETURN
  4864.       ENDIF
  4865.       IF (CH .EQ. BLANK .OR. CH .EQ. TAB) GOTO 10
  4866. C
  4867. C found first character, so keep going
  4868. C
  4869.       DO WHILE (.NOT. (CH .EQ. EOF .OR. CH .EQ. BLANK .OR.
  4870.      $                 CH .EQ. TAB .OR. CH .EQ. NEL) .AND.
  4871.      $                 LEN .LT. MAXLEN)
  4872.         LEN = LEN + 1
  4873.         STR(LEN) = CH
  4874.         CH = GETC(FD, CH)
  4875.       ENDDO
  4876. C
  4877. C save eols for next getword
  4878. C
  4879.       IF (CH .EQ. NEL) CALL UNGETC(FD, CH)
  4880.       STR(LEN+1) = 0
  4881.       GETWORD = LEN
  4882.       RETURN
  4883.       END
  4884.       SUBROUTINE PUTSTR(FD, STR)
  4885.            IMPLICIT NONE
  4886.            INTEGER   FD
  4887.            INTEGER  STR(*)   !string to read
  4888. C
  4889. C= Output a string to an output stream
  4890. C
  4891.       INCLUDE      'KFILE.COM'
  4892. C
  4893.       INTEGER      I
  4894. C
  4895.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
  4896.       ELSE IF (FMODE(FD) .EQ. WR) THEN
  4897.         I = 1
  4898.         DO WHILE (STR(I) .NE. 0)
  4899.           CALL PUTC(FD, STR(I))
  4900.           I = I + 1
  4901.         ENDDO
  4902.       ENDIF
  4903.       RETURN
  4904.       END
  4905.       SUBROUTINE PUTINT (FD, INT, MINWID)
  4906.            IMPLICIT NONE
  4907.            INTEGER    FD
  4908.            INTEGER    INT
  4909.            INTEGER    MINWID       !minimum width
  4910. C
  4911. C= Output an integer
  4912. C
  4913.       INCLUDE      'KDEF.INS'
  4914. C
  4915.       INTEGER      WIDTH
  4916.       INTEGER      VAL
  4917.       INTEGER      ASCIIO
  4918.       INTEGER      NCH             !number of characters
  4919.       INTEGER      STRING(21)
  4920. C
  4921.       INTEGER      ICHAR
  4922.       INTEGER      IABS
  4923.       INTEGER      MOD
  4924. C
  4925.       WIDTH = 0
  4926.       IF (INT .LT. 0) THEN
  4927.         CALL PUTC(FD, ICHAR('-'))
  4928.         WIDTH = 1
  4929.       ENDIF
  4930.       VAL = IABS(INT)
  4931.       ASCIIO = ICHAR('0')
  4932.       NCH = 0
  4933.       DO UNTIL (VAL .EQ. 0 .OR. NCH .GE. 20)
  4934.         NCH = NCH + 1
  4935.         STRING(NCH) = MOD(VAL, 10) + ASCIIO
  4936.         VAL = VAL/10
  4937.       ENDDO
  4938.       WIDTH = WIDTH + NCH
  4939. C
  4940. C now output the digits
  4941. C
  4942.       DO UNTIL (NCH .LE. 0)
  4943.         CALL PUTC(FD, STRING(NCH))
  4944.         NCH = NCH - 1
  4945.       ENDDO
  4946.       DO WHILE (WIDTH .LT. MINWID)
  4947.         CALL PUTC(FD, BLANK)
  4948.         WIDTH = WIDTH + 1
  4949.       ENDDO
  4950.       RETURN
  4951.       END
  4952.       SUBROUTINE PUTDAY(FD, MM, DD, YY)
  4953.            IMPLICIT NONE
  4954.            INTEGER   FD
  4955.            INTEGER   MM, DD, YY
  4956. C
  4957. C= Output day of week
  4958. C
  4959.       INTEGER      IZLR
  4960.       INTEGER      IMN
  4961.       INTEGER      IYR
  4962.       INTEGER      IDY
  4963.       INTEGER      WKDAY
  4964. C
  4965. C day of week function!
  4966. C
  4967.       IZLR (IYR, IMN, IDY) = MOD((13*(IMN+10-(IMN+10)/13*12)-1)/5+
  4968.      $    IDY+77+5*(IYR+(IMN-14)/12-(IYR+(IMN-14)/12)/100*100)/4+
  4969.      $    (IYR+(IMN-14)/12)/400-(IYR+(IMN-14)/12)/100*2,7)+1
  4970. C
  4971.       WKDAY = IZLR(YY, MM, DD)
  4972.       IF (WKDAY .EQ. 1) THEN
  4973.         CALL PRINT(FD, 'Sunday')
  4974.       ELSE IF (WKDAY .EQ. 2) THEN
  4975.         CALL PRINT(FD, 'Monday')
  4976.       ELSE IF (WKDAY .EQ. 3) THEN
  4977.         CALL PRINT(FD, 'Tuesday')
  4978.       ELSE IF (WKDAY .EQ. 4) THEN
  4979.         CALL PRINT(FD, 'Wednesday')
  4980.       ELSE IF (WKDAY .EQ. 5) THEN
  4981.         CALL PRINT(FD, 'Thursday')
  4982.       ELSE IF (WKDAY .EQ. 6) THEN
  4983.         CALL PRINT(FD, 'Friday')
  4984.       ELSE
  4985.         CALL PRINT(FD, 'Saturday')
  4986.       ENDIF
  4987.       RETURN
  4988.       END
  4989.       SUBROUTINE PUTMNTH(FD, MM)
  4990.            IMPLICIT NONE
  4991.            INTEGER   FD
  4992.            INTEGER   MM
  4993. C
  4994. C= Output the month name.
  4995. C
  4996.       IF (MM .EQ. 1) THEN
  4997.         CALL PRINT(FD, 'January')
  4998.       ELSE IF (MM .EQ. 2) THEN
  4999.         CALL PRINT(FD, 'Feburary')
  5000.       ELSE IF (MM .EQ. 3) THEN
  5001.         CALL PRINT(FD, 'March')
  5002.       ELSE IF (MM .EQ. 4) THEN
  5003.         CALL PRINT(FD, 'April')
  5004.       ELSE IF (MM .EQ. 5) THEN
  5005.         CALL PRINT(FD, 'May')
  5006.       ELSE IF (MM .EQ. 6) THEN
  5007.         CALL PRINT(FD, 'June')
  5008.       ELSE IF (MM .EQ. 7) THEN
  5009.         CALL PRINT(FD, 'July')
  5010.       ELSE IF (MM .EQ. 8) THEN
  5011.         CALL PRINT(FD, 'August')
  5012.       ELSE IF (MM .EQ. 9) THEN
  5013.         CALL PRINT(FD, 'September')
  5014.       ELSE IF (MM .EQ. 10) THEN
  5015.         CALL PRINT(FD, 'October')
  5016.       ELSE IF (MM .EQ. 11) THEN
  5017.         CALL PRINT(FD, 'November')
  5018.       ELSE IF (MM .EQ. 12) THEN
  5019.         CALL PRINT(FD, 'December')
  5020.       ELSE
  5021.         CALL PRINT(FD, 'No such month')
  5022.       ENDIF
  5023.       RETURN
  5024.       END
  5025.       SUBROUTINE PRINT (FD, STR)
  5026.            IMPLICIT NONE
  5027.            INTEGER   FD
  5028.            CHARACTER*(*)  STR
  5029. C
  5030. C= Output character string
  5031. C
  5032.       INTEGER      I
  5033. C
  5034.       INTEGER      LEN
  5035.       INTEGER      ICHAR
  5036. C
  5037.       DO I=1, LEN(STR)
  5038.         CALL PUTC(FD, ICHAR(STR(I:I)))
  5039.       ENDDO
  5040.       RETURN
  5041.       END
  5042.       SUBROUTINE PRINTL(FD, STR)
  5043.            IMPLICIT NONE
  5044.            INTEGER    FD
  5045.            CHARACTER*(*) STR
  5046. C
  5047. C= Output a string with cr/lf at end
  5048. C
  5049.       INCLUDE      'KDEF.INS'
  5050. C
  5051.       CALL PUTC(FD, NEL)
  5052.       CALL PRINT(FD, STR)
  5053.       CALL FLUSH(FD)
  5054.       RETURN
  5055.       END
  5056.       SUBROUTINE SENDBRK(FD)
  5057.            IMPLICIT NONE
  5058.            INTEGER  FD             !file to break
  5059. C
  5060. C Sends break to attached port
  5061. C
  5062.       INCLUDE      'KFILE.COM'
  5063. C
  5064.       INTEGER      BLK(4)          !local block
  5065.       INTEGER      BRK             !function that turns on break
  5066.      $       /X'62800000'/
  5067.       INTEGER      NOBRK           !turn off break
  5068.      $       /X'62000000'/         !break turned off
  5069. C
  5070.       IF (FD .LE. 0 .AND. FD .GE. MAXFILE) THEN
  5071.       ELSE IF (.NOT. CTDEV(FD)) THEN
  5072.       ELSE IF (FMODE(FD) .NE. WR) THEN
  5073.       ELSE
  5074.         CALL FLUSH(FD)
  5075.         CALL FCBINIT(FD, BLK, BRK, 0)
  5076.         CALL DPWRITE(BLK, 0, 0)
  5077.  
  5078.         CALL DELAY(60)
  5079.         CALL FCBINIT(FD, BLK, NOBRK, 0)
  5080.         CALL DPWRITE(BLK, 0, 0)
  5081.         CALL BLKINIT(FD)
  5082.       ENDIF
  5083.       RETURN
  5084.       END
  5085.       SUBROUTINE IOWAIT (MSEC)
  5086.            IMPLICIT NONE
  5087.            INTEGER  MSEC           !msec to wait for io to complete
  5088. C
  5089. C= Delays the specified time if io is pending
  5090. C
  5091.       INTEGER      IOS
  5092. C
  5093.       INTEGER      MIN
  5094. C
  5095. C
  5096.       CALL X:EAWAIT(MIN(-1,-MSEC/50), IOS, *10)
  5097.  10   CONTINUE
  5098.       RETURN
  5099.       END
  5100.