<<< K6SUBS.FTN >>>
      subroutine SetTrap(SyRv)                           ,<881219.1353> 
     >Set Fortran Trapping
      implicit none 
  
!     K6SUBS contains routines which are specific to RTE-6.  This 
!     revision operates with KERMIT revision 1.99 or later. 
  
!     This routine is actually system-independent.  It is included in the 
!     system-dependent outines only because it contains conditionally-
!     compiled code.  If the user MUST use this KERMIT on a C.83 system,
!     having this routine here will reduce the installation time greatly. 
!     BE SURE TO RE-INDEX the appropriate library file! 
  
      include kercom.ftni,NOLIST          !Defines "SysRev" 
      integer*2 SyRv
  
      external FtnTrap
  
      if (SysRev .ge. 2440) then          !Fortran trapping desired?
          if (SyRv .ge. 2440) then        !Yes - is it available? 
              call Ftrap(FtnTrap)         !Yes - use it 
          else
              call tpFm('You must set "SysRev" (in KERCOM) <_')
              call tpFm(' 2440, then recompile/relink KxSubs!')
              call quit 
          endif 
      endif 
      return
  
      end 
  
      subroutine restore(lu)                             ,<881219.1353> 
     >6/Restore LU's
      implicit none 
  
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST
      integer*2 lu,cnf(CnfSiz)
      logical*2 fMux
      integer*2 timv,ctrg,c17s,c30c,c30s,c33c,c33s,c34c,c34s
      equivalence (fMux,Cnf(fMx)), (timv,Cnf(tim)), (ctrg,Cnf(trg)) 
      equivalence (c17s,Cnf(v17)) 
      equivalence (c30c,Cnf(c30)), (c33c,Cnf(c33)), (c34c,Cnf(c34)) 
      equivalence (c30s,Cnf(s30)), (c33s,Cnf(s33)), (c34s,Cnf(s34)) 
  
!     This routine differs from its RTE-A counterpart in that IDM00 
!     has a CN45 request to kill the DC1 trigger character, which would 
!     need to be restored.  The DVM00 trigger handling is part of the 
!     DDV05 device-driver, which is restored (if needed) when we do the 
!     CN33 to restore the driver-responses configuration. 
  
      if (lu .eq. L) then                 !Use which configuration array? 
          call MoveWords(LocCnf,cnf,CnfSiz) 
      else
          call MoveWords(RemCnf,cnf,CnfSiz) 
      endif 
  
      call Set_timeout(lu,timv,fMux)      !Restore original timeout 
  
      if (.not. fMux) return              !Not mux?  Nothing left to do 
  
c     At this point, we will restore ONLY those parameters we have altered
c     as a result of KERMIT's normal operations.
  
      if (c30c .ne. c30s) then
          call control(lu,3000b,c30s)     !restore char format
      endif 
      if (c33c .ne. c33s) then
          call control(lu,3300b,c33s)     !restore configuration
      endif 
      if (c34c .ne. c34s) then
          call control(lu,3400b,c34s) 
      endif 
  
      if (.not. btest(cnf,0) ) then       !D mux? 
          call control(lu,3700b,173400b)  !No: allow echo/edit; end on CR 
      else                ! --> Need not yet established! 
          call control(lu,1700b,c17s)     !Yes: restore terminator
      endif 
      return
  
      end 
  
      subroutine enable(lu,imux)                         ,<881219.1353> 
     >6/Enable int-scheduling 
      implicit none 
  
      integer*2 lu,imux 
  
!     This routine differs from its RTE-A counterpart in that IDM00 
!     muxt keep up with the names of the interrupt-scheduled programs 
!     and DVM00 doesn't.
  
      if (.not. btest(imux,0) ) then      !B/C mux? 
          call control(lu,3700b,173400b)  !cn37: set read type
      endif 
      call control(lu,2000b,0)            !cn20: enable interrupts
      return
  
      end 
  
      subroutine disable(lu,imux)                        ,<881219.1353> 
     >6/Disable int-scheduling
      implicit none 
  
      integer*2 lu,imux 
  
!     This routine differs from its RTE-A counterpart in that IDM00 
!     uses CN23 to disable interrupts, whereas DVM00 should agree with
!     the RTE-6 "D" mux driver in using a CN21 to do the same job.
  
      call control(lu,2100b,0)            !cn21: disable interrupts 
      return
  
      end 
  
      subroutine set_timeout(lu,val,imux)                ,<881219.1353> 
     >6/Set LU timeout value
      implicit none 
  
      integer*2 lu,val,imux 
  
!     This routine differs from its RTE-A counterpart in that IDM00 
!     has two flavors of timeout ("user" and "system") where DVM00 has
!     only one. 
  
      if (val .lt. 0) return              !Don't set negative time-outs 
  
      call control(lu,2200b,val)          !cn22: set time-out 
      return
  
      end 
  
      subroutine KillEnqAck                              ,<881219.1353> 
     >6/Disable ENQ/ACK 
      implicit none 
  
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST
  
!     This routine differs from its RTE-A counterpart in that IDM00 
!     has a CN45 request to clear the trigger-character, whereas DVM00
!     uses DDV05 to perform triggering, and we bypass that anyway.
  
      if ( btest(iRmx,0) ) then           !D-mux? 
          if ( btest(r34c,0) ) then       !XON/XOFF enabled?
              r34c = 5                    !Yes - add CPU<-->CPU protocol
          else
              r34c = 4                    !else change to CPU<-->CPU proto
          endif 
          call control (R,3400b,r34c) 
          r33c = 100000b                  !Turn on FIFO mode
      else
          if ( btest(r30c,7) ) then       !Is Enq/Ack on now? 
              r30c = ibclr(r30c,7)        !Yes - turn it off
              call control(R,3000b,r30c)
          endif 
          r33c = 22501B                   !Bypass dev-drvr/type-ahead on
      endif 
      call control(R,3300b,r33c)
  
!     If we are really modifying the local configuration, we must track 
!     the changes to the local array, or RESTORE won't work correctly!
  
      if (R .eq. L) call MoveWords(RemCnf,LocCnf,CnfSiz)
  
      return
  
      end 
  
      Subroutine cPrep                                   ,<881219.1353> 
     >6/Prepare for Connect 
      implicit none 
  
      include kercom.ftni,NOLIST          !Defines L and R
      include kercnf.ftni,NOLIST
      include kconcw.ftni,NOLIST
  
!     This routine differs from its RTE-A counterpart in the function-
!     codes it sets for IDM00 (12040B/C) vs. DVM00 (12792B/C), and for
!     ID*00 (12005) vs. DVA05 (12966).
  
      call disable(L)                     !Kill local interrupt scheduling
      Ltx=L $ Lrx=L $ Rtx=R $ Rrx=R       !Prepare XLUEX hi control words 
      term = 1200b                        !(B/C mux terminate rcv buffer) 
      dstat = 600b                        !Dynamic status request code
  
!     Prepare the local LU for connect - allows 12966 and 2 Mux types 
  
      if ( fLmx ) then                    !Local on a mux?
          if ( fLcm ) then                !Yes - if B or C mux... 
              Lrc = 3300b                 !transparent + save t-a data
              L33c = iand(L33c,17b) .or. 22600b  !Turn on type-ahead
              call control(L,3300b,L33c)
              call control(L,3600b,1)     !Set read length
              call control(L,3700b,4000b) !Terminate on count only
              call control(L,term,0)      !Terminate all buffers
              call control(L,term,0)      !Terminate all buffers again
              call control(L,term,0)      !Terminate all buffers once more
          else
              Lrc = 100b                  !D mux uses only binary 
              L33c = 100000b              !Turn on FIFO mode
              call control(L,3300b,L33c)
          endif 
          call control(L,2600b,1)         !Flush card 
      else
          Lrc = 100b                      !binary 
      endif 
      Ltc = 2000b                         !transparent
  
!     Prepare the remote LU for connect - allows for 2 mux types only 
  
      if ( fRcm ) then                    !Prepping a B/C mux port? 
          Rrc = 3300b                     !transparent + save t-a data
          Rtc = 3300b                     !transparent
          R33c = (R33c.and.17b) + 22600b  !cn33: read reconfig off
          call control(R,3300b,R33c)
          call control(R,3600b,254)       !cn36: set read len (254 bytes) 
          call control(R,3700b,4000b)     !cn37: terminate on count only
          call control(R,term,0)          !terminate all buffers
          call control(R,term,0)          !terminate all buffers again
          call control(R,term,0)          !terminate all buffers once more
          call sleep(10)                  !allow .1 sec settling time 
      else
          Rrc = 100b                      !D-mux is simple: just binary 
          Rtc = 2000b                     !...still simple: transparent 
      endif 
  
      if ( fLmx ) call control(L,2600b,1) !Flush local if on a mux
      call control(R,2600b,1)             !Flush remote 
      return
  
      end 
  
      integer*2 function GetPak()                        ,<881219.1353> 
     >6/Read a packet 
      implicit none 
  
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST          !To define iRmx 
      integer*2 buf(128),xr(2),cw 
      equivalence (buf,RecPkt),(xr(2),cw) 
  
!     This routine differs from its RTE-A equivalent in that we must
!     bypass DD*00 and suppress a trigger in the read call under RTE-A. 
  
      if ( btest(iRmx,0) ) then           !D-mux? 
          cw = 0                          !Yes - set for normal ASCII 
      else
          cw = 3000b                      !B/C: transparent, keep t-a data
      endif 
      xr = R                              !Set remote lu into control word
      call xluex(1,xr,buf,-254)           !Read a buffer
      call abreg(GetPak,rlen)             !Get the received length
      return
  
      end 
  
      subroutine PutPak(len)                             ,<881219.1353> 
     >6/Send a packet 
      implicit none 
  
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST          !Defines iRmx 
      integer*2 len,xl(2),cw,PakBuf 
      equivalence (xl(2),cw),(Packet,PakBuf)
      data cw /2000b/                     !transparent
  
!     This routine differs from its RTE-A counterpart in that we must 
!     bypass DD*00 and suppress handshake under RTE-A.
  
      xl = R                              !Get the remote LU
      call control(R,2600b,1)             !Flush card before sending
      call xluex(2,xl,PakBuf,-len)
      return
  
      end 
  
      subroutine GetMux(LU,CnfArr)                       ,<881219.1353>
     >6/Get MUX info
      implicit none
  
!     This routine fills the Loc or Rem CNF array for the given LU.
!     If it uses the new serial drivers, we can ask the driver what kind of
!     card the LU is connected to; if it doesn't, we will look in the DVP
!     of the LU to see what we can learn.
!
!     The value placed in fLmx or fRmx tells KERMIT what kind of LU it is:
!         Bit 15: set if LU supports KERMIT protocol as follows
!                  RTE-A: 12040 mux only
!                  RTE-6: 12792 mux (or 12966 using DVW00 - see note below)
!         Bit 0:  set if LU is on a D MUX
!         Bit 1:  set if LU is on the A400 OBIO
!
!     NOTE: This version of KERMIT doesn't actually support the 12966/DVW00
!           combination.  It is supported by KERMIT-CX as part of CONNECT,
!           which is a terminal-emulation program by ICT.  If KERMIT-RTE
!           does things which you would like to see in KERMIT-CX, ask Don
!           Wright (at ICT) to add the appropriate code.
  
$alias /datc/ = '$DATC', NoAllocate 
$alias opsy  = '.OPSY', direct
$alias xla   = '.XLA', direct 
$alias xluex, NoAbort 
  
      include kercnf.ftni,NOLIST
      include kercom.ftni,NOLIST
      integer*2 LU,CnfArr(CnfSiz) 
      integer*2 xl(2),cw,j,a,b,z,datc,eqta,eqxa 
      integer*2 LuTru,AddressOf,IxGet,opsy,xla,sc,eqx 
      integer*2 naRd,naCn 
      parameter (naRd = 100001b)
      parameter (naCn = 100003b)
      logical*2 xftty 
      common /datc/ datc
      equivalence (xl(2),cw)
 
      integer*2 Cnf(CnfSiz)
      logical*2 fmxc
      integer*2 imxc,syuc,timc,trgc,v17c
      integer*2 c30c,c33c,c34c,s30c,s33c,s34c
      equivalence (fmxc,imxc,Cnf(fmx)),(syuc,Cnf(syu))
      equivalence (timc,Cnf(tim)),(trgc,Cnf(trg)),(v17c,Cnf(v17))
      equivalence (c30c,Cnf(c30)),(c33c,Cnf(c33)),(c34c,Cnf(c34))
      equivalence (s30c,Cnf(s30)),(s33c,Cnf(s33)),(s34c,Cnf(s34))
  
!     The following are equivalences to cfg (in kercnf.ftni)
      character*6 pnam,snam
      character*4 dnam,inam
      integer*2   drev,dvt6,dvad,irev,frev
      integer*2   cn17,cn22,cn30,cn31,cn33,cn34,dv20
      equivalence (dnam, cfg(1)),(drev, cfg(4)),(dvt6, cfg(5))
      equivalence (dvad, cfg(6)),(inam, cfg(7)),(irev,cfg(10))
      equivalence (frev,cfg(11)),(pnam,cfg(12)),(snam,cfg(15))
      equivalence (cn17,cfg(18)),(cn22,cfg(19)),(cn30,cfg(20))
      equivalence (cn31,cfg(21)),(cn33,cfg(22)),(cn34,cfg(23))
      !           cfg words 24-31 are currently (rev 4.1) spares
      equivalence (dv20,cfg(32))
  
      !Statement function:
      sc(j) =  ixget(j) .and. 77b         !Get/isolate a select-code
      eqx(j) = ixget(j+8) .and. 377b      !Get/isolate the EQTX size
  
!     This routine differs from its RTE-A counterpart in that the
!     determination of the interface type is different.
 
      j = opsy()                          !Get the operating-system type
      if (j .ne. -17) then
          call tpFm('Aborting - not set up for this system!')
          call exec(6)
      endif
  
      Cnf = 0
      Call MoveWords(Cnf,Cnf(2),CnfSiz-1) !Clear the configuration array
      syuc = LuTru(LU)                    !Get system LU
      xl = syuc .or. 100000b              !Set session override for XLUEX 
      imxc = 0                            !Preset to 'not a mux'
  
      if (xla(datc) .lt. 2440) then       !timeout bit moved at rev 2440
          rtoBit = 7
      else
          rtoBit = 0
      endif 
  
      if ( xftty(xl) ) then               !If interactive...
          cw = 60600b                     !see if we can do SSR 
          call xluex(naCn,xl,-2,*10)      !No-abort special dynamic status
          call abreg(a,b)                 !Get the return flag
          if (b .ne. 123456b) goto 10     !Not SSR compatible 
          cw = 3700b                      !Prepare for the SSR
          call xluex(naRd,xl,cfg,32,*30)  !Do the SSR 
          if (dnam .eq. 'DV80') then      !Remains to be seen what happens
              imxc = 100001b
              rtoBit = 1                  !just a guess...
          endif 
          if (imxc .eq. 0) goto 20        !Not a mux? Just return to caller 
          v17c = cn17                     !Get current terminator 
          timc = cn22                     !Current time-out value 
          c30c = cn30                     !Current CN30 value 
          c33c = cn33                     !Current CN33 value 
          c34c = cn34                     !Current CN34 value 
      endif 
      goto 20 
  
!     We come here if the LU is interactive but the driver won't do SSR.
!     We decide it is a MUX LU if there are 3 or more EQTs using the
!     same select-code (Don Wright: thanks for that idea!).  We must also 
!     eliminate DVV00 LUs, so each of the LUs using the same select-code
!     must also have an EQT-extension of more than 13 words.  Sad to say, 
!     once DVM00 is happy with the EQTX size, it clears that word, so we
!     must also allow the EQTX size to be zero! 
  
10    call exec(13,LU,a,b)                !Get the EQT4 value in "b"
      b = b .and. 77b                     !Isolate the select-code
      eqta = IxGet(1650b) + 3             !Point to 1st EQT4 word 
      a = 0                               !Clear the loop counter 
      do j = 1,IxGet(1651b)               !Loop through the EQT table 
          if (sc(eqta) .eq. b) then       !Same select-code?
              z = eqx(eqta)               !Get the EQT-extension size 
              if (z.gt.13 .or. z.eq.0)
     >            a = a + 1 
              endif 
          eqta = eqta + 15                !Bump to next EQT4
      end do
      if (a .lt. 3) goto 20               !probably not a mux 
      imxc = 100000b                      !Flag as KERMIT-useable 
      eqta = IxGet(1652b) + syuc - 1      !Find my DRT entry
      eqta = IxGet(eqta) .and. 377b       !Find my EQT-number 
      eqta = IxGet(1650b) + (eqta-1)*15   !Find my EQT entry
      timc = abs(IxGet(eqta+13))          !Get current timeout value
      eqxa = IxGet(eqta+12)               !Get my EQT-extension address 
      c30c = IxGet(eqxa + 4)              !Get the current CN30 value 
      c33c = IxGet(eqxa + 5)              !Get the current CN33 value 
      if (iand(c33c,177760b) .eq. 0) then !any cn33 configuration set up? 
          c33c = c33c .or. 52500b         !No - set power-on defaults 
      endif 
      !Note: the cn34 parameter isn't needed with 12792B/C muxes
  
 20   call MoveWords(c30c,s30c,3)         !Copy current values to saves 
      call MoveWords(cnf,CnfArr,CnfSiz)   !Copy config back to caller 
      return
  
 30   call tpFm('Aborting: SSR-compatible driver rejected the SSR') 
      call quit 
  
      end 
  
      subroutine LogOff                                  ,<881219.1353> 
     >6/Log the server off
      implicit none 
  
      include kercom.ftni,NOLIST          !Needed for system
      integer*2 sess,Eqt,EqTypA,EqTyp,junk,err,ime(3) 
      integer*2 LuTru,LuSes,LogLu,ixget 
      integer*2 drt,eqta
      character*6 me
      equivalence (me,ime)
  
!     This routine differs from its RTE-A counterpart in that the jobs
!     performed by the log-off program are completely different under 
!     RTE-A and under RTE-6.  Further, CLGOF doesn't exist for RTE-6! 
  
      sess = LuTru( L )                   !Get our true terminal LU#
  
!     Trace down the EQT entry for this session - we will be modifying
!     the device type so that it doesn't look interactive.
  
      drt=ixget(1652b) $ eqta=ixget(1650b)!Locate system tables 
      Eqt = ixget(drt+sess-1) .and. 377b  !Get our EQT# 
      EqTypA = (Eqt - 1) * 15 + eqta + 4  !Locate device-type word
      junk = ixget(EqTypA)                !Get current device-type word 
      EqTyp = junk .and. 37400b           !Isolate current device-type
      junk = junk .or. 37400b             !Turn us into an instrument...
      call ixPut(EqTypA,junk)             !...now!
  
      call clgof(sess,1,err)              !Log us off now 
  
      junk = ixget(EqTypA) .xor. 37400b .or. EqTyp
      call ixPut(EqTypA,junk)             !Restore device-type word 
  
      call pname(ime)                     !Who am I 
      call ShootProg(me,'8')              !Commit suicide 
  
      end 
  
      subroutine clgof(sess,dum1,dum2)                   ,<881219.1353> 
     >6/Perform programmatic log-off
      implicit none 
  
!     CLGOF logs the session indicated by SESS off. 
! 
!     This routine differs from the versions submitted to the CSL by
!     Don Wright and Bill Donze in that the shutdown of any programs
!     running in the session is performed here, and not in LGOFF (as
!     it would otherwise be).  If the caller of this routine has
!         a) DeTACHed from the session and
!         b) set the device-type of the user's terminal to a non- 
!            interactive type 
!     then it is possible to perform a completely "silent" log-off
!     (i.e., no messages will be emitted to the user's terminal). 
!     BE SURE TO RESTORE THE TERMINAL'S DEVICE TYPE!
! 
!     Note -- this code was obtained originally by disassembling the
!     appropriate code from RTE-A (of all things) to find out what
!     operations were done by CLGOF there.  I reasoned that I could 
!     perform similar operations under RTE-6, and a look at LGOFF 
!     verified the methods used here. 
  
      integer*2 sess                      !Formal parameters
      integer*2 dum1,dum2                 !(for RTE-A compatibility)
  
      integer*2 lgof,lgcl,dscs            !External stuff 
$alias /lgof/ = '$LGOF', NoAllocate 
$alias xla = '.XLA', direct 
      common /lgof/ lgof
      common /LogOffInfo/ scba,sessn,idad 
      integer*2 xla,LUSes,LogLU,LUTru,TrimLen,GetMySons 
      integer*2 scba,sessn,idad 
  
      integer*2 junk,temp,p1,p2,p3        !Local stuff
      integer*2 myses,cclas,prog(3),ime(3)
      logical*2 fses
      character*5 pgnam,me
      equivalence (pgnam,prog),(me,ime) 
  
!     The RTE-A equivalent to this code is furnished by the system. 
  
      myses = LuTru(LogLu(junk))          !Get my session#
      call pname(ime) 
      sessn = sess                        !...and passed session# 
      if (sessn .eq. myses) call dtach    !Get out of LGOFF's way 
  
      lgcl = xla(lgof)                    !Get LGOFF's class# 
      if (lgcl .eq. 0) return             !Session not available
      lgcl = lgcl .or. 20000b             !Set 'no deallocate' bit
  
      scba = LuSes(sessn)                 !Get the SCB address
      if (scba .eq. 0) return             !No such session? Just return!
  
!     The following loop terminates all programs running in the given 
!     session except: 
!         My caller (in case we didn't actually detach...)
!         D.RTR/SMP (special cases - they clean themselves up)
  
      p2 = 0                              !Initialize for program-search
      do while (GetMySons(prog,p2,fses) .ne. 0) 
          if (pgnam .eq. 'D.RTR') goto 10 
          if (pgnam .eq. 'SMP')   goto 10 
          if (pgnam .eq. me) goto 10
          if ( fses ) then                !Normal program in session? 
              call ShootProg(pgnam,'8') 
          else
              call ShootProg(pgnam,'1')   !A "system utility" 
          endif 
 10   end do
  
      cclas = 0                           !Insure we allocate a class#
      call exec(18,0,0,0,0,0,cclas)       !Write to new comm class
  
!     Tell LGOFF to log off the given session 
      call exec(100024b,0,cclas,1,sessn+20000b,scba,lgcl,*999)
  
!     Get messages from LGOFF until LGOFF is done.
 20   call exec(100025b,cclas+20000b,junk,0,p1,p2,p3,*999)
      if (p3 .ne. 1) goto 20              !Must be class read or write/read 
      if (p2 .gt. 0) goto 20              !Ignore class-writes/-controls
      call clrq(2,cclas)                  !Release the class# 
  
 999  return
  
      end 
      integer*2 function GetMySons(pgnam,idno,fses)      ,<881219.1353> 
     >6/Find Session Programs 
      implicit none 
  
      integer*2 pgnam(3),idno             !My parameters
      logical*2 fses
  
      integer*2 ixget                     !Externals
      common /LogOffInfo/ scb,sessn,idad
      integer*2 scb,sessn,idad
  
      integer*2 keywd,temp                !Local stuff
  
!     The RTE-A equivalent to this code is furnished by the system. 
  
      keywd = ixget(1657b)                !Get ID-segment table pointer 
      GetMySons = 0                       !Prepare for pessimistic result 
      fses = .true.                       !Assume program is in session 
  
 10   idad = ixget(keywd + idno)          !Get an ID-segment address
      if (idad .eq. 0) return             !End of ID-segment table - done 
  
      idno = idno + 1                     !Prep for next iteration
      temp = ixget(idad + 14)             !Get the ID-segment status
      if (.not. btest(temp,4) ) then      !If this is a long ID-segment 
          temp = ixget(idad+32)           !Get the SCB pointer from it
          if (scb .eq. temp) then         !If it matches the target 
              pgnam = ixget(idad+12)      !...get progname (1st word) 
              pgnam(2) = ixget(idad+13)   !...get progname (2nd word) 
              pgnam(3) = ixget(idad+14) .and. 177400b .or. 40b
              GetMySons = 1               !Flag success 
              temp = ixget(idad+31) .and. 377b
              fSes = temp .eq. sessn      !Flag program in session
              return
          endif 
      endif 
  
      goto 10 
  
      end 
  
      subroutine ShootProg(name,how)                     ,<881219.1353> 
     >6/Quietly kill a program
      implicit none 
  
      character*(*) name,how
  
      integer*2 buf(7),TrimLen,p
      character*13 cBuf 
      equivalence (buf,cbuf)
  
!     The RTE-A equivalent to this routine is furnished by RTE-A
  
      p = TrimLen(name) 
      cbuf = 'OF,' // name(:p) // ',' // how // ',NP' 
      call messs(buf,13)
      return
  
      end 
  
      integer*2 function WhoLockedLu(LU)
     >, 92084-1Y013 REV 2718 870506 <ps>
      implicit none 
  
!     This source was obtained via disassembly of the system routine of the 
!     same name.  As of the 4.1 system revision, the original system routine
!     caused its caller to be non-transportable; this is fixed here:
!         The original WhoLockedLu used "AddressOf($RNTB)" via an alias to
!             obtain the true address of the Resource Number table. 
!         By going one level indirect using "XLA($$RTB)" also via an alias
!             to retrieve this address, the code becomes transportable. 
  
$alias /rntb/ = '$$RTB', NoAllocate 
$alias xla = '.XLA', direct 
  
      integer*2 rntb
      common /rntb/ rntb
      integer*2 LU
      integer*2 drt,lumax,drt3,LockWord,LockerRN,LockerIDNo 
      integer*2 IxGet,IDNumberToAdd,xla   !<ps> 
  
      WhoLockedLu = 0                     !Preset return value
      drt = ixget(1652b)                  !Locate the Device Reference Table
      lumax = ixget(1653b)                !...and the size of it
      if (LU .gt. lumax) return           !Return if illegal LU 
  
      drt3 = drt + lumax*2                !Locate DRT part 3
      LockWord = IxGet( ((LU-1)/2)+drt3 ) !Get word with lock for this lu 
      if (iand(LU,1) .ne. 0) then         !Upper or lower byte? 
          LockerRN = ibits(LockWord,8,8)  !Odd LU uses upper byte 
      else
          LockerRN = ibits(LockWord,0,8)  !Even LU uses lower byte
      endif 
  
      if (LockerRN .eq. 0) return         !Quit if not locked 
  
      LockerIDNo = ixget(xla(rntb) + LockerRn) .and. 377b 
  
      WhoLockedLu = IDNumberToAdd(LockerIDNo) 
  
      return
      end 
  
      subroutine IDAddToName(idaddr,PrgName,lu) 
     >, 92084-1Y013 REV 2718 870506 <ps>
      implicit none 
  
!     The source for this routine was obtained via disassembly of the system
!     routine of the same name.  As of the 4.1 system revision, this routine
!     did not provide the ID-segment's session info; it is fixed here!
  
      integer*2 idaddr,PrgName(*),lu,IxGet
  
      PrgName(1) = IxGet(idaddr+12) 
      PrgName(2) = IxGet(idaddr+13) 
      PrgName(3) = IxGet(idaddr+14) .and. 177400b .or. 40b
      lu         = IxGet(idaddr+31) .and. 377b    !870506-ps
      return
  
      end 
<<< KASUBS.FTN >>>
      subroutine SetTrap(SyRv)                           ,<871015.1451>
     >Set Fortran Trapping
      implicit none
  
!     KASUBS contains routines which are specific to RTE-A.  This
!     revision operates with KERMIT revision 1.99a or later.
  
!     This routine is actually system-independent.  It is included in the
!     system-dependent outines only because it contains conditionally-
!     compiled code.  If the user MUST use this KERMIT on a C.83 system,
!     having this routine here will reduce the installation time greatly.
!     BE SURE TO RE-INDEX the appropriate library file!
  
      include kercom.ftni,NOLIST          !Defines "SysRev"
      integer*2 SyRv
  
      external FtnTrap
  
      if (SysRev .ge. 2440) then      !Fortran trapping desired?
          if (SyRv .ge. 2440) then    !Yes - is it available?
              call Ftrap(FtnTrap)     !Yes - use it
          else
              call tpFm('You must set "SysRev" (in KERCOM) <_')
              call tpFm(' 2440, then recompile/relink KxSubs!')
              call quit
          endif
      endif
      return
  
      end
  
      subroutine restore(lu)                             ,<871015.1451>
     >A/Restore LU's
      implicit none
  
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST
      integer*2 lu,cnf(CnfSiz)
      logical*2 fMux
      integer*2 timv,ctrg,c17s,c30c,c30s,c33c,c33s,c34c,c34s
      equivalence (fMux,Cnf(fMx)), (timv,Cnf(tim)), (ctrg,Cnf(trg))
      equivalence (c17s,Cnf(v17))
      equivalence (c30c,Cnf(c30)), (c33c,Cnf(c33)), (c34c,Cnf(c34))
      equivalence (c30s,Cnf(s30)), (c33s,Cnf(s33)), (c34s,Cnf(s34))
  
!     This routine differs from it's RTE-6 counterpart in that IDM00
!     has a CN45 request to kill the DC1 trigger character, which would
!     need to be restored.  The DVM00 trigger handling is part of the
!     DDV05 device-driver, which is restored (if needed) when we do the
!     CN33 to restore the driver-responses configuration.
  
      if (lu .eq. L) then                 !Use which configuration array?
          call MoveWords(LocCnf,cnf,CnfSiz)
      else
          call MoveWords(RemCnf,cnf,CnfSiz)
      endif
  
      call Set_timeout(lu,timv,fMux)      !Restore original timeout
  
      if (.not. fMux) return              !Not mux?  Nothing left to do
  
c     At this point, we will restore ONLY those parameters we have altered
c     as a result of KERMIT's normal operations.
  
      if (c30c .ne. c30s) then            !If we changed port configuration
          call control(lu,3000b,c30s)     !...put it back
      endif
      if (c33c .ne. c33s) then            !If we changed type-ahead
          call control(lu,3300b,c33s)     !...restore that too
      endif
      if (c34c .ne. c34s) then            !If we changed handshake
          call control(lu,3400b,c34s)     !...fix it up
      endif
  
      if (.not. btest(Cnf,0) ) then       !D-mux or B-/C-mux?
          call control(lu,4500b,10400b)   !Restore DC1 trigger-char
          call control(lu,3700b,173400b)  !allow echo/edit; end on CR
      else                ! --> Need not yet established!
          call control(lu,1700b,c17s)     !Restore terminator
      endif
  
      return
      end
  
      subroutine enable(lu,imux)                         ,<871015.1451>
     >A/Enable int-scheduling
      implicit none
  
      include kercom.ftni,NOLIST          !Defines L
      include kercnf.ftni,NOLIST          !Defines non-mux "trigger"
  
      integer*2 lu,iMux,dv6,if6,dp(12),p1(4),p2(4),xl(2),cw,p1s,p2s
      integer*2 p1a,p1b,p1c,p1d,p2a,p2b,p2c,p2d
      equivalence (dp(5),p1),(dp(9),p2),(xl(2),cw)
      equivalence (p1(1),p1a),(p1(2),p1b),(p1(3),p1c),(p1(4),p1d)
      equivalence (p2(1),p2a),(p2(2),p2b),(p2(3),p2c),(p2(4),p2d)
  
!     This routine differs from it's RTE-6 counterpart in that IDM00
!     muxt keep up with the names of the interrupt-scheduled programs
!     and DVM00 doesn't.
  
      if ( btest(iMux,0) ) then           !D-mux?
          call control(lu,2000b)          !Yes - just re-enable
      else
          if (lu .eq. L) then
              p1s = Ltrg
              p2s = L17v
          else
              p1s = Rtrg
              p2s = R17v
          endif
          xl = lu                         !Prepare for XLUEX
          call control(lu,3700b,173400b)  !cn37: set read type
          cw = 10000b                     !Set the "Z-bit"
          call xluex(13,xl,dv6,if6,dp,12) !Get pri/sec program names
          call control(lu,102300b,0)      !cn23: set scheduling flag
          if (imux .ge. 0) p1a = p1s      !Restore P1a if not on mux
          cw = 2000b                      !cn20: enable primary scheduling
          call xluex(3,xl,p1a,p1b,p1c,p1d)
          if (imux .ge. 0) p2a = p2s      !Restore P2a if not on mux
          cw = 4000b                      !cn40: enable secondary sched
          call xluex(3,xl,p2a,p2b,p2c,p2d)
      endif
  
      return
      end
  
      subroutine disable(lu,iMux)                        ,<871015.1451>
     >A/Disable int-scheduling
      implicit none
  
      integer*2 lu,iMux
  
!     This routine differs from it's RTE-6 counterpart in that IDM00
!     uses CN23 to disable interrupts, whereas DVM00 should agree with
!     the RTE-6 "D" mux driver in using a CN21 to do the same job.
 
      if ( btest(iMux,0) ) then           !D-mux?
          call control(lu,2100b,1)        !cn21: disable scheduling
      else
          call control(lu,102300b,1)      !cn23: clr sched flg (to intfc)
      endif
  
      return
      end
 
      subroutine set_timeout(lu,val,iMux)                ,<871015.1451>
     >A/Set LU timeout value
      implicit none
  
      integer*2 lu,val,iMux
  
!     This routine differs from it's RTE-6 counterpart in that IDM00
!     has two flavors of timeout ("user" and "system") where DVM00 has
!     only one.
 
      if (val .lt. 0) return              !Don't set negative time-outs
  
      if ( btest(iMux,0) ) then           !D-mux or B-/C-mux?
          call control(lu,2200b,val)      !D: only one flavor of timeout
      else
          call control(lu,2700b,val)      !B/C: set "user" time-out
      endif
  
      return
      end
  
      subroutine KillEnqAck                              ,<871015.1451>
     >A/Disable remote ENQ/ACK
      implicit none
  
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST
  
!     This routine differs from it's RTE-6 counterpart in that IDM00
!     has a CN45 request to clear the trigger-character, whereas DVM00
!     uses DDV05 to perform triggering, and we bypass that anyway.
  
      if ( btest(iRmx,0) ) then           !D-mux?
          if ( btest(r34c,0) ) then       !XON/XOFF enabled?
              r34c = 5                    !Yes - add CPU<-->CPU protocol
          else
              r34c = 4                    !else change to CPU<-->CPU proto
          endif
          call control(R,3400b,r34c)
          r33c = 100000b                  !Turn on FIFO mode
      else
          call control(R,4500b,0)         !cn45: set trigger-char (to none)
          if ( btest(r30c,7) ) then       !is Enq/Ack on now?
              r30c = r30c .xor. 200b      !Yes - turn it off
              call control(R,3000b,r30c)  !...and send it to the port
          endif
          r33c = 22500b                   !Set for type-ahead
      endif
      call control(R,3300b,r33c)
  
!     If we are really modifying the local configuration, we must track
!     the changes to the local array, or RESTORE won't work correctly!
  
      if (R .eq. L) call MoveWords(RemCnf,LocCnf,CnfSiz)
  
      return
  
      end
  
      Subroutine cPrep                                   ,<871015.1451>
     >A/Prepare for Connect
      implicit none
  
      include kercom.ftni,NOLIST          !Defines L and R
      include kercnf.ftni,NOLIST
      include kconcw.ftni,NOLIST
  
!     This routine differs from it's RTE-6 counterpart in the function-
!     codes it sets for IDM00 (12040B/C) vs. DVM00 (12792B/C), and for
!     ID*00 (12005) vs. DVA05 (12966).
 
      call disable(L)                     !Kill local interrupt scheduling
      Ltx=L $ Lrx=L $ Rtx=R $ Rrx=R       !Prepare XLUEX hi control words
      term = 5200b                        !(B/C mux terminate rcv buffer)
      dstat = 100600b                     !Dynamic status bypasses dev-dvr
  
!     Prepare the local LU for connect - allows for ASIC and 2 Mux types
  
      if ( fLmx ) then                    !Local on a mux?
          if ( fLcm ) then                !Yes - if B or C mux...
              Lrc = 3100b                 !...use trans/save t-a data
              L33c = 22600b               !Turn on local FIFO
              call control(L,3300b,L33c)
              call control(L,3600b,1)     !Set read length
              call control(L,3700b,4000b) !terminate on count only
              call control(L,term,0)      !terminate all buffers
              call control(L,term,0)      !terminate all buffers again
              call control(L,term,0)      !terminate all buffers once more
          else
              Lrc = 100b                  !D mux uses only binary
              L33c = 100000b              !Turn on local FIFO mode
              call control(L,3300b,l33c)
          endif
          call control(L,2600b,1)         !Flush card
      else
          Lrc = 100100b                   !Skip device-driver + binary
      endif
      Ltc = 2000b                         !transparent
  
!     Prepare the remote LU for connect - allows for 2 mux types only
  
      if ( fRcm ) then                    !Prepping a B/C mux port?
          Rrc = 3100b                     !transparent + save t-a data
          Rtc = 3700b                     !transparent + no handshake
          R33c = 22600b                   !cn33: read reconfig off
          call control(R,3300b,R33c)      !cn33: read reconfig off
          call control(R,3600b,254)       !cn36: set read len (254 bytes)
          call control(R,3700b,4000b)     !cn37: terminate on count only
          call control(R,term,0)          !terminate all buffers
          call control(R,term,0)          !terminate all buffers again
          call control(R,term,0)          !terminate all buffers once more
          call sleep(10)                  !allow .1 sec settling time
      else
          Rrc = 100b                      !D-mux is simple: just binary
          Rtc = 2000b                     !...still simple: transparent
      endif
  
      if ( fLmx ) call control(L,2600b,1) !Flush local if on a mux
      call control(R,2600b,1)             !Flush remote
      return
  
      end
  
      integer*2 function GetPak()                        ,<871015.1451>
     >A/Read a packet
      implicit none
  
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST          !To define fRmx
      integer*2 buf(128),xr(2),cw
      equivalence (buf,RecPkt),(xr(2),cw)
  
!     This routine differs from it's RTE-6 equivalent in that we must
!     bypass DD*00 and suppress a trigger in the read call under RTE-A.
  
      if ( btest(iRmx,0) ) then           !D-mux?
          cw = 0                          !Yes - set for normal ASCII
      else
          cw = 103000b                    !B/C: no ddvr, trans, keep t-a
      endif
      xr = R                              !Set remote lu into control word
      call xluex(1,xr,buf,-254,40000b)    !Get the info
      call abreg(GetPak,rlen)             !Get the received length
      return
  
      end
  
      subroutine PutPak(len)                             ,<871015.1451>
     >A/Send a packet
      implicit none
  
      include kercom.ftni,NOLIST          !Defines
      include kercnf.ftni,NOLIST          !Defines fRmx
      integer*2 len,xl(2),cw,PakBuf
      equivalence (xl(2),cw),(Packet,PakBuf)
 
!     This routine differs from it's RTE-6 counterpart in that we must
!     bypass DD*00 and suppress handshake under RTE-A.
  
      if ( btest(iRmx,0) ) then           !D-mux
          cw = 2000b                      !Yes - do transparent write
      else
          cw = 102700b                    !Else bypass, trans, no handshake
      endif
      xl = R                              !Get the remote LU
      call control(R,2600b,1)             !Flush the card before sending
      call xluex(2,xl,PakBuf,-len)
      return
  
      end
      subroutine GetMux(LU,CnfArr)                       ,<871015.1451>
     >A/Get MUX info
      implicit none
  
!     This routine fills the Loc or Rem CNF array for the given LU.
!     If it uses the new serial drivers, we can ask the driver what kind of
!     card the LU is connected to; if it doesn't, we will look in the DVP
!     of the LU to see what we can learn.
!
!     The value placed in fLmx or fRmx tells KERMIT what kind of LU it is:
!         Bit 15: set if LU supports KERMIT protocol as follows
!                  RTE-A: 12040 mux
!                  RTE-6: 12792 mux (or 12966 using DVW00 - see note below)
!         Bit 0:  set if LU uses the new serial drivers
!         Bit 1:  set if LU is on the A400 OBIO
!
!     NOTE: This version of KERMIT doesn't actually support the 12966/DVW00
!           combination.  It is supported by KERMIT-CX as part of CONNECT,
!           which is a terminal-emulation program by ICT.  If KERMIT-RTE
!           does things which you would like to see in KERMIT-CX, ask Don
!           Wright (at ICT) to add the appropriate code.
  
$alias /lut/ = '$LUTA', NoAllocate
$alias opsy  = '.OPSY', direct
$alias xluex, NoAbort
  
      include kercnf.ftni,NOLIST
      include kercom.ftni,NOLIST
      integer*2 LU,CnfArr(CnfSiz)
      integer*2 xl(2),cw,j,a,b,lut,dvta,dvxa
      integer*2 LuTru,AddressOf,IxGet,opsy
      integer*2 naRd,naCn
      parameter (naRd = 100001b)
      parameter (naCn = 100003b)
      logical*2 xftty
      common /lut/ lut
      equivalence (xl(2),cw)
  
      integer*2 Cnf(CnfSiz)
      logical*2 fmxc
      integer*2 imxc,syuc,timc,trgc,v17c
      integer*2 c30c,c33c,c34c,s30c,s33c,s34c
      equivalence (fmxc,imxc,Cnf(fmx)),(syuc,Cnf(syu))
      equivalence (timc,Cnf(tim)),(trgc,Cnf(trg)),(v17c,Cnf(v17))
      equivalence (c30c,Cnf(c30)),(c33c,Cnf(c33)),(c34c,Cnf(c34))
      equivalence (s30c,Cnf(s30)),(s33c,Cnf(s33)),(s34c,Cnf(s34))
  
!     The following are equivalences to cfg (in kercnf.ftni)
      character*6 pnam,snam
      character*4 dnam,inam
      integer*2   drev,dvt6,dvad,irev,frev
      integer*2   cn17,cn22,cn30,cn31,cn33,cn34,dv20
      equivalence (dnam, cfg(1)),(drev, cfg(4)),(dvt6, cfg(5))
      equivalence (dvad, cfg(6)),(inam, cfg(7)),(irev,cfg(10))
      equivalence (frev,cfg(11)),(pnam,cfg(12)),(snam,cfg(15))
      equivalence (cn17,cfg(18)),(cn22,cfg(19)),(cn30,cfg(20))
      equivalence (cn31,cfg(21)),(cn33,cfg(22)),(cn34,cfg(23))
      !           cfg words 24-31 are currently (rev 4.1) spares
      equivalence (dv20,cfg(32))
  
!     This routine differs from it's RTE-6 counterpart in that
!     determination of the interface type is different.
  
      j = opsy()                          !Get the operating-system type
      if (j.ne.-53 .and. j.ne.-37 .and. j.ne.-61) then
          call tpFm('Aborting - not set up for this system!')
          call exec(6)
      endif
  
      Cnf = 0
      Call MoveWords(Cnf,Cnf(2),CnfSiz-1) !Clear the configuration array
      syuc = LuTru(LU)                    !Get system LU
      xl = syuc .or. 100000b              !Set session override for XLUEX
      imxc = 0                            !Preset to 'not a mux'
  
      rtobit = 1                          !Set the time-out bit for RTE-A
      if ( xftty(xl) ) then               !If interactive...
          cw = 60600b                     !see if we can do SSR
          call xluex(naCn,xl,-2,*10)      !No-abort special dynamic status
          call abreg(a,b)                 !Get the return flag
          if (b .ne. 123456b) goto 10     !Not SSR compatible
          cw = 3700b                      !Prepare for the SSR
          call xluex(naRd,xl,cfg,32,*30)  !Do the SSR
          if (inam .eq. 'ID80') then      !We have a "D" mux!
              imxc = 100001b
          endif
          if (inam .eq. 'ID40') then      !See if maybe it's A400 OBIO
              imxc = 100003b
          endif
          if (imxc .eq. 0) goto 20        !Not a mux? Just return to caller
          v17c = cn17                     !Get current terminator
          timc = cn22                     !Current time-out value
          c30c = cn30                     !Current CN30 value
          c33c = cn33                     !Current CN33 value
          c34c = cn34                     !Current CN34 value
      endif
      goto 20
  
!     We come here if the LU is interactive but the driver won't do SSR.
!     We decide it is a MUX LU if:
!         It has 12 driver parameters (eliminates IO-mapped LUs)
!         It has 57 DVT-extension words (eliminates ASIC LUs)
!         DVP1 has bit 2 set (further eliminates ASIC LUs)
  
10    dvta = AddressOf(lut)               !Get address of $LUTA
      dvta = IxGet(dvta)                  !Get the address of the LUT
      dvta = IxGet(dvta + syuc - 1)       !Get LU's DVT address
!1.99a     dvta = IxGet(dvta)                  !Get the DVT address
      a = IxGet(dvta + 20)                !Get DVP/DVX size word
      b = a .and. 777b                    !Isolate the DVX size
      a = ibits(a,9,7)                    !...and the DVP size
      if (a .ne. 12) goto 20              !Terminals have 12 DVP words
      timc = abs(IxGet(dvta+28))          !Get the current timeout value
      if (b .ne. 57) then                 !MUX (IDM00) has 57 DVX words
          trgc = IxGet(dvta + 29)         !Capture 1st word of pri prog name
          v17c = IxGet(dvta + 33)         !...and 1st word of sec prog name
          goto 20
      endif
      a = IxGet(dvta + 25)                !Get Driver Parameter #1
      if (.not. btest(a,2)) goto 20       !DVP1 bit 2 must be set
      imxc = 100000b                      !Flag as KERMIT-useable
      trgc = IxGet(dvta + 27)             !Get the current trigger-character
      dvxa = IxGet(dvta + 21)             !Get DVT-extension address
      c30c = IxGet(dvxa + 40)             !Get the current CN30 value
      c33c = IxGet(dvxa + 39)             !Get the current cn33 value
      if (iand(c33c,177760b) .eq. 0) then !any configuration setup?
          c33c = 52500b                   !No - set power-on defaults
      endif
      !Note: the cn34 parameter isn't needed with 12040B/C muxes
  
 20   call MoveWords(c30c,s30c,3)         !Copy current values to saves
      call MoveWords(cnf,CnfArr,CnfSiz)   !Copy config back to caller
      return
  
 30   call tpFm('Aborting: SSR-compatible driver rejected the SSR')
      call quit
  
      end
 
      subroutine LogOff                                  ,<871015.1451>
     >A/Log the server off
      implicit none
  
      integer*2 sess,err,usnum
  
!     This routine differs from it's RTE-6 counterpart in that the jobs
!     performed by the log-off program are completely different under
!     RTE-A and under RTE-6.  Further, CLGOF doesn't exist for RTE-6!
  
      sess = usnum()                      !Get the session number
      call Clgof(sess,2,err)              !Go to background (suppress msgs)
      sess = usnum()                      !My session# has changed
      call Clgof(sess,1,err)              !Now kill everything off.
  
      call exec(6)                        !(...and die, just in case)
  
      end
<<< KERMIT.FTN >>>
ftn7x,s
      program kermit(6,49)                               ,<890525.1144>
     >File transfer utility
      implicit none
  
!     HP-1000 KERMIT main program
!
!     rev     date        reason..........................................
!     1.98a   23Jul86     First release to CUCCA (supersedes all previous)
!     1.98b   06Aug86     receive/get with rename lost DS info in mask
!                         >>> Released to Interex Detroit swap tape
!     1.98c   09Oct86     Repaired checksum-type parameter-return [recpar]
!     1.99    10Apr87     New CONNECT removes mux lockups; altered CONTROL
!                         and SLEEP routine to go with new CONNECT.  A lot
!                         of reorganization, moving system-dependent code
!                         to KxSUBS (x=A or 6 for RTE-A or RTE-6).  This
!                         makes KERMIT a transportable program!
!     1.99a   14Jul87     Fix in GetMux (KASUBS) for tracking down the DVT
!                         address (near statement label 10).  Several fixes
!                         for compatibility with RTE revision 5.0.
!     1.99b   16Oct87     Fix in ReportFileError to load 3rd segment before
!                         calling SndErr; fix in Connect to (hopefully) let
!                         B- and C-mux terminal-emulation work under RTE-A.
!     1.99c   Jun '88     More fixing to Connect - it is now tested with a
!                         12040D and 12040C, and with a 12792C.  Hopefully
!                         this is the last I need to hear about this!
!                         >>> Released to Interex 2830 CSL tape
!     1.99d   May '89     Fix in RINIT to properly handle timeout.  Now
!                         supports "D" mux on both RTE-A and RTE-6!
!                         >>> Released to CUCCA in Dec. '89
!
!     Permission is granted to any individual or institution to copy
!     or use this program, except for explicitly commerical purpose.
!
!     RTE-6/VM KERMIT was originally implemented by John Lee, of
!     RCA Laboratories 6/29/84.
!
!     Heavily modified by Paul Schumann at E-Systems, Inc. beginning
!     11/09/84 for a "full" implementation of KERMIT, including local-
!     host mode, server operation, and hierarchical file access, on
!     both RTE-6 and RTE-A.
!
!     Installation instructions:
!
!         KERMIT is designed to work on both RTE-6 and RTE-A systems from
!         the C.83 revision (first appearance of CI file space) or later.
!         In order to minimize the installation time, all of the system-
!         dependent code has been moved to K6SUBS.FTN (for RTE-6/VM) or
!         KASUBS.FTN (for RTE-A); the link command-file KERMIT.LOD will
!         select the appropriate routines when you link.
!
!         NOTE: the KERMIT relocatables you received are already set for
!               any system revision from A.84 to 4.1.  If you are actually
!               using a C.83 system, you must edit KERCOM.ftni and change
!               the "SysRev" parameter to any value less than 2440, then
!               recompile KERMIT.  It should not be necessary to recompile
!               KASUBS or K6SUBS.  Failure to do this will result in an
!               undefined external reference to FTRAP.  If you force-load
!               KERMIT, you will be told to make the change just described,
!               and then KERMIT will abort.
!
!         Link KERMIT using the supplied KERMIT.LOD.  Undefined external
!         references (except for FTRAP - see above) are caused by failure
!         to use the correct KERMIT library file (KASUBS or K6SUBS) or be-
!         cause your system is simply too old (before C.83).
!
!         Copy KERMIT.HLP to the /SYSTEM or /KERMIT directory, or if you
!         have no CI space, copy it as "KERMI to any FMGR space.  This
!         file is generated by running the RTE-6 GENIX utility against
!         the KERMIT.TEXT file, which is user-editable.  You need not
!         rebuild KERMIT.HLP if you have not altered KERMIT.TEXT.
!
!                                               Paul Schumann
!                                               E-Systems, Inc.
!                                               PO Box 1056 CBN 148
!                                               Greenville, TX  75401
!                                               (214) 457-5358
!
!     A note on the programming style...
!     I use IMPLICIT NONE in order to protect myself from typos
!     (I am a terrible typist); obviously this means that I must
!     define all symbols before I use them.  I have attempted as
!     much as possible to make the symbol names self-documenting,
!     but I don't LIKE to type either, so I use very short names
!     which I prefixed as follows:
!         fiXx is a variable pertaining to the current file being
!             sent or received
!         dbXx is a variable pertaining to some debugging
!         cmXx is a variable pertaining to the command line
!         fXxx is a logical flag of some type
!
!     I firmly adhere to the concept of "data hiding" as a tool to improve
!     software reliability: a module cannot change a variable if it has no
!     access to it.  I have a number of common blocks with separate include
!     files so that a routine which needs access to control variables but
!     which needs no access to file variables can have exactly that access.
!     Would-be KERMIT modifiers should keep this in mind before they decide
!     to re-combine the common include-files.  (It also improves compiler
!     speed when FTN7X doesn't need to keep up with a lot of unused symbol
!     names!)
!
!     In the interest of saving paper, the complete listings of all common
!     blocks appear only in the block-data routine.  I regret any problems
!     this may cause.
!
!     The following is a definition of ALL variables in /KER/, the
!     main control common block for KERMIT-RTE.  Variables are defined
!     in storage order (for cross-referencing to /KER/ itself).  The
!     numbers in parentheses after a variable name (if any) give the
!     storage allocation in 16-bit words; if absent, assume 1 word.
!
!     SysRev(0)    - the highest system revision-code expected by this
!                    KERMIT version
!     Delay        - # of seconds waited before sending out the first
!                    SINIT packet (only in remote mode).
!     EOL          - End of line delimiter required by other KERMITS.
!     EsChar       - The character used to return back to command mode
!                    from CONNECT.
!     L            - Local TTY channel (to which the user is logged)
!     ImxTry       - Maximum number of retries/packet before giving up on
!                    start-up of a [group] file-transfer
!     MaxTry       - maximum number of retries/packet before giving up on
!                    any packet once transfers are already under way
!     R            - Remote TTY channel (to which user is NEVER logged)
!                    This is also the local channel if KERMIT is in
!                    remote-host mode.
!     p            - a general-purpose byte pointer variable; used by
!                    pPutc and its callers in building a packet
!     rlen         - The data length of the last packet received
!     Seq          - The sequence number of the current packet
!     Class        - The class# to use during CONNECT mode.
!     slen         - The data size of the next packet to send
!     trCb(144)    - Transfer-file control block
!     fePath       - An assigned label.  If a file error of some kind
!                    occurs, execution will continue at (fePath) after
!                    the error is processed.  Only the KERMIT main and
!                    the SERVER subroutine should ever change fePath!
!     sPcnt        - The number of parameters the other KERMIT sent me.
!                    (Some KERMITs don't like to see more parameters than
!                     they sent out, notably an older IBM-PC version...)
!     Parity       - The parity of the remote line:
!                     1 = Even       2 = Mark       3 = None
!                     4 = Odd        5 = Space
  
!     My packet parameters follow:
  
!     PakSiz       - The maximum packet size I want to receive
!     Timeout      - Time (sec) the other KERMIT should wait for me to
!                  - send a packet (0 means wait forever)
!     nPad         - The # of pad characters I require (I require none)
!     EOLch        - The terminator I require at the end of each packet;
!                  - this is hard-coded to 13 (carriage-return)!
!     Quote        - The character I must see before control characters
!     Bit8         - The character I must get if the next data byte is
!                    to have its 8th bit set
!     ChkTyp       - the checksum type I want to receive on packets
!     Repc         - The character which tells me a repeat-count follows
!     capas(2)     - My capabilities bits (I can do time-out; I accept
!                    server commands; I can send/receive attribute packets)
!     Sync         - the character with which my incoming packets start
  
!     My partner's packet parameters follow:
  
!     sPkSiz       - the maximum packet size I am allowed to send
!     sTime        - Time (sec) I will wait for a packet from my partner
!                    (0 means wait forever)
!     sPad         - The number of pad characters my partner needs
!     sPadch       - The character my partner wants for padding
!     sEOL         - My partner's packet-terminator character
!     sQuote       - The character I must put before control characters
!     sBit8        - The character I must send before sending a character
!                  - whose 8th-bit is set
!     sCheck       - My partner's checksum type
!     sRepc        - The character my partner will use before repeat counts
!     sCapas(2)    - My partner's capability bits
!     sSync        - The character I must send as the start of a packet
  
!     Assorted flags follow
  
!     fWarn        - True if file-overwrite warning is desired
!     fIBM         - True if talking to a CMS KERMIT, false otherwise
!                    If true, I must wait for a DC1 (XON or ^Q) before I
!                    can send anything.  Additionally, if I am CONNECTed,
!                    I will locally echo keystrokes.
!     fServ        - True if in server mode, false otherwise
!     fTrans       - True if commands are coming from a transfer-file
!     fBit8        - True if I am doing 8th-bit quoting
!     fRepc        - True if I am doing repeat-count prefixing
!     fPkIO        - True if I am doing packet-I/O
!     fSend        - True if sending a file; false if receiving a file
!                    (valid only during file-transfers)
!     f8OK         - True if 8th-bit quoting is enabled
 
!     String things follow
  
!     HlpNam(32)   - the file-descriptor for KERMIT's help file
!     Packet(50)   - A character array which holds the outgoing packet
!     RecPkt(128)  - A character array which holds the incoming packet
!     pData(48)    - A character array for the data part of a packet
!     state        - The current file-transfer state
!     ErrMsg(36)   - Text of most recent error-message (SndErr takes
!                    the error-packet text from this variable!)
!     Prompt(10)   - The string used as a command-prompt
  
!     Other labeled common areas:
!         /KCMNDS/ forms KERMIT-RTE's vocabulary
!         /KERCMD/ holds the current command-line & parameters
!         /KERCNF/ holds configuration info for the system and for the
!                  two LUs KERMIT is currently using
!         /KERDBG/ holds (self) debugging parameters
!         /KERFIL/ holds control parameters for the file being sent or
!                  received currently.
!         /KERSTA/ holds file-transfer statistical information
  
!     WARNING -- KERMIT uses "unusual" techniques in order to keep a large
!         program comfortably within the address space, while maintaining
!         the functionality.  These are:
!         1)  'ASSIGN nn to fePath' appears in KERMIT's main program only.
!             "fePath" is a variable in KERCOM which is used only by the
!             file-error reporting routine, ReportFileError, to return to
!             the main quickly without propagating an error-code through
!             the subroutine call-chain.  WARNING: this usage alone makes
!             KERMIT unfit for Code and Data Separation (CDS), although
!             there is a CDS-compatible method which performs the same job.
!         2)  KERMIT is segmented in an unusual way: all modules in the
!             segments (except for the "segment header") are subroutines or
!             functions that are called FROM SOME PART OF THE MAIN!  This
!             method was used to reduce KERMIT (1.97 and previous revisions)
!             from 31 pages (under RTE-A) to 24 before the RUn command was
!             added.  This "feature" makes KERMIT unfit for LOADR; you must
!             use LINK.  (Actually, there is a method by which LOADR can be
!             made to load this KERMIT, but it involves splitting the object
!             files at segment boundaries -- it isn't worth the trouble!)
!
!         If you find bugs in KERMIT, please let me know!  I can advise you
!         in the most expedient wat to fix them, as well as fix them for
!         other KERMIT users.  If you contemplate extending the capabilities
!         of this KERMIT, be sure you understand the segmenting method.  A
!         few guidelines are:
!             a)  If it is already in the main, don't move it to any of
!                 the segments, or you'll probably lose return addresses!
!             b)  If it parses an interactive command, at least some of it
!                 must be in K1CMD's (command processing) segment.
!             c)  If it deals ONLY with communicating to the other end
!                 (file-transfers or server), it >>probably<< belongs in
!                 K3XFR's (packet-transfer) segment.
!             d)  K2MSK's segment may appear the smallest in terms of the
!                 number of source lines, but all of the file-masking code
!                 loads there.  It is still the smallest segment, but it's
!                 unlikely that any more useful code could be put there.
!             e)  If it may be called from 2 or more segments, and all
!                 calls it makes are to the system or other modules in
!                 the main only, it >>probably<< belongs in the main.
!
!     I apologize in advance for any problems this may cause the reader.
  
      include kercom.ftni,NOLIST
      include kercmd.ftni,NOLIST
      integer*2 loglu,junk
      logical*2 succeed,send,receive
  
      L = loglu(junk)                     !Get user's I/O channel
      do junk = 3,1,-1                    !Insure all segments load
          call LoadSeg(junk)              !...ending with command-processor
      end do
 
!     K1CMD performs initialization code on 1st entry only.
  
      assign 10 to fePath                 !Set File-error path
  
!     The following infinite loop is terminated by
!         a)  An exit-type command if interactive
!         b)  A finish-type command if serving
  
 10   if ( fServ ) then                   !Serving?
          call LoadSeg(3) $ call Server   !Yes - Server never returns
      else
          call LoadSeg(1) $ Call Command  !No - do interactive commands
      endif
  
!     A command requiring packet-I/O is ready to execute
  
      call LoadSeg(3) $ call PakIO        !Prepare for packet-I/O
      if (cmTk .eq. 'BYE') then
          call Bye
      else if (cmTk .eq. 'FINISH') then
          call Finish
      else if (cmTk .eq. 'GET') then
          call Get
      else if (cmTk .eq. 'RECEIVE') then
          succeed = receive('R')
          call success(succeed)
      else if (cmTk .eq. 'SEND') then
          if (L .eq. R) call sleep(delay)
          succeed = send()
          call success(succeed)
      endif
      cmCh = ' ' $ call NrmIO $ goto 10   !Get something else to do
 
      end
  
      Subroutine LoadSeg(SegNum)                         ,<890525.1144>
     >Overlay loader
      implicit none
  
      include kercom.ftni,NOLIST
      integer*2 SegNum,err,segn(3)
      character*6 cSegNam,SegNames(3)
      equivalence (cSegNam,segn)
      data SegNames /'K1CMD ','K2MSK ','K3XFR '/
  
      if (segnum .eq. seg) return         !Segment is already loaded
      cSegNam = SegNames(SegNum)
      call SegLd(segn,err)                !Try to load the segment
      if (err .ne. 0) then                !Did it load (and return)?
          call tpI2('Segment-Loader error _',err,0)
          call tpCh(' on -',cSegNam)
          stop 'aborting with segment-load problems'
      endif
  
      return
      end
  
      Subroutine tPrint                                  ,<890525.1144>
     >Term-print mini-formatter
      implicit none
  
      include kercom.ftni,NOLIST          !To define "L"
  
!     Define the names of all entry parameters
  
      integer*2 i2Var                     !Integer*2 variable to print
      integer*4 i4Var                     !Integer*4 variable to print
      integer*2 iflen                     !length of the integer field
      character*(*) chFmt                 !"format" string to print
      character*(*) chVar                 !character variable to print
  
      integer*2 tp,ioBuf(129),TrimLen,xl(2),cw
      logical*2 fReady                    !True when string ready to print
      integer*4 w4,mul
      character*20 IntToDecimal,DintToDecimal,chWk,jRight
      character chBuf*258
      equivalence (ioBuf,chBuf)
      data tp /1/                         !IO-buffer starts at byte# 1
      data cw /0/                         !No control bits on the LU
  
c     Formatting rules:
c         If a "format" ends with an underscore ("_") then the string
c             being built will not be printed on this call, but the
c             format string will be put in the I/O buffer without it.
c         If a "format" ends with a dash ("-") then the string being
c             built will be printed without it.  This allows trailing
c             blanks to be put in the format which would otherwise be
c             deleted.
c         The field length parameter is given as the number of digits
c             allowed for the formatted number if right-justification
c             is desired.  If the field length is positive, blanks are
c             padded on the left as needed; if negative, zeroes are
c             padded on the left.   If the field length is zero, the
c             number will be printed left-justified.
c         If the number being formatted occupies more characters in the
c             string than the field-length, the number will display as
c             (iflen) stars (just like the formatter!).
c         A maximum of 257 characters may ever be printed at one time.
  
      entry tpFm(chFmt)                   !Append a format only
      call CopyMore(chFmt,chBuf,tp,fReady)
      goto 10
  
      entry tpI2(chFmt,i2Var,ifLen)       !Append format and I*2 number
      call CopyMore(chFmt,chBuf,tp,fReady)
      chWk = jRight(IntToDecimal(i2var),iflen)
      chBuf(tp:) = chWk                   !Copy in the number
      tp = tp + TrimLen(chWk)             !Adjust the pointer
      goto 10
  
      entry tpI4(chFmt,i4Var,ifLen)       !Append format and I*4 number
      call CopyMore(chFmt,chBuf,tp,fReady)
      chWk = jRight(DintToDecimal(i4Var),iflen)
      chBuf(tp:) = chWk
      tp = tp + TrimLen(chWk)
      goto 10
  
      entry tpCh(chFmt,chVar,ifLen)       !Append format and string
      call CopyMore(chFmt,chBuf,tp,fReady)
      chBuf(tp:) = chVar
      if (ifLen .gt. 0) then              !Was a field-size given
          tp = tp + ifLen                 !Yes - "truncate" at that size
      else
          tp = tp + TrimLen(chVar)        !No - use all but trailing blanks
      endif
  
 10   tp = min(tp,258)                    !Don't overflow the string
      if (fReady) then                    !If string is ready to print...
          xl = L                          !Set LU in XLUEX control words
          call xluex(2,xl,iobuf,1-tp)     !...print it
          tp = 1                          !...and reset the pointer
      endif
  
      return
      end
  
      subroutine CopyMore(frm,dest,tp,fdone)             ,<890525.1144>
     >do "formats"
      implicit none
 
      character*(*) frm,dest
      integer*2 tp
      logical*2 fdone
      integer*2 i,TrimLen
  
      i = TrimLen(frm)                    !Where does the format end?
  
      if (frm(i:i) .eq. '_') then         !Are we finishing the buffer?
          fdone = .false.                 !No - flag it to caller
          i = i - 1                       !Don't copy continue flag to buf
      else
          fdone = .true.
          if (frm(i:i) .eq. '-') i=i-1    !Remove trailing-blanks flag
      endif
  
      if (i .gt. 0) then                  !Anything to copy?
          dest(tp:) = frm(:i)             !Copy the correct part
          tp = tp + i                     !adjust the pointer
          tp = min(tp,258)
      endif
  
      return
      end
  
      character*20 function jRight(chNum,flen)           ,<890525.1144>
     >do "Ix" formats
      implicit none
  
      character*(*) chNum
      integer*2 flen
      integer*2 i,ilen,TrimLen
      character*20 stars,blanks,zeroes
      data stars   /'********************'/
      data blanks  /'                    '/
      data zeroes  /'00000000000000000000'/
  
      ilen = iabs(flen)
      if (ilen .gt. 20) then
          call quit
          stop 'I-field length > 20 (jRight)'
      endif
      i = TrimLen(chNum)                  !How big is the number
      if (ilen .ne. 0) then               !Was a field-length given?
          if (i .gt. ilen) then           !Yes - will the number fit?
              jRight = stars(:ilen)       !No - replace number with stars
          else if (i .lt. ilen) then
              i = ilen - i                !fits ok; get # of fill bytes
              if (flen .lt. 0) then       !Doing zero or blank fill?
                  jRight = zeroes(:i) // chNum
              else
                  jRight = blanks(:i) // chNum
              endif
          else
              jRight = chNum              !exact fit
          endif
      else
          jRight = chNum                  !Else no formatting requested
      endif
 
      return
      end
  
      subroutine FtnTrap(abreg,preg)                     ,<890525.1144>
     >Trap FORTRAN errors
      implicit none
  
      include kercom.ftni,NOLIST
      include kerdbg.ftni,NOLIST
  
      integer*2 abreg(2),preg(2),abcod(3)
      character ecode*6, addr*8, IntToDecimal*6, IntToOctal*6
      equivalence (abcod,ecode)
  
!     If KERMIT incurs a FORTRAN error, it will most likely be a type-2
!     (always fatal) error.  The point of this routine is to insure the
!     restoration of all MUX configurations and file-closure should the
!     "impossible" happen.  In fact, the most likely error will be from
!     a string routine.  On completion of it's task, FtnTrap allows the
!     standard "runtime error" termination to occur.
  
      addr = IntToOctal(preg)//'/'//char(seg+48) !Format error addr/seg#
  
      if (abreg .lt. 20000b) then         !Group-2 error?
          ecode = IntToDecimal(abreg)     !Yes - format the number
      else
          abcod = abreg                   !Copy Group-1/-3 error to the
          abcod(2) = abreg(2)             !message
          abcod(3) = 2h                   !Clear the end of the message
      endif
  
      ErrMsg = 'Runtime error ' // ecode // ' @' // addr
      call kdebug(all,ErrMsg,' ')         !Try to log the error
      call LoadSeg(3) $ Call SndErr       !Do error-packet if in transfer
  
      call quit                           !Clean myself up
      return                              !allow me to abort
      end
  
      subroutine kdebug(type,header,info)                ,<890525.1144>
     >Do KERMIT debug logging
      implicit none
  
      include kerdbg.ftni,NOLIST
      integer*2     type
      character*(*) header,info
      integer*2     LogBf,TrimLen,err
      character*150 LogCh
      equivalence   (LogCh,LogBf)
  
c     This routine performs the debug logging requested by KERMIT's
c     user.  If debug logging of (type=STATES, PACKET, or ALL) is
c     enabled and logging is not suspended, then (header) and (info)
c     are concatenated into a log record and written to the log file.
  
      if (dbLv .lt. 1) return             !No debugging is active
      if (iand(type,dbLv) .ne. 0) then    !Logging this type of stuff?
          LogCh = ' ' // header // info   !Yes - form the record
          call FmpWrite(dbCb,err,LogBf,TrimLen(LogCh))   !...& write it
          call FmpPost(dbCb,err)
      endif                               !IGNORE file-write errors!
  
      return
      end
  
      subroutine quit                                    ,<890525.1144>
     >Terminate KERMIT cleanly
      implicit none
  
      include kerfil.ftni,NOLIST          !Defines fiCB and maCB
      include kercom.ftni,NOLIST          !Defines trCB, R, and L
      include kercnf.ftni,NOLIST          !Defines fRmx and fLmx
      include kerdbg.ftni,NOLIST          !Defines dbCB
      integer*2 junk
  
      call FmpClose(fiCB,junk)
      call FmpClose(dbCB,junk)
      call FmpClose(trCB,junk)
      call FmpEndMask(maCb)
 
      !The next line is an attempt to prevent both ends of a CPU-CPU
      !link from trying (and always failing) to log each other on.
      !Hopefully, 5 seconds is enough time for logout- or program-
      !termination activity to stop before this side's interrupts
      !get re-enabled.
  
      if (R .ne. L) then
          call sleep(500)
          call restore(L)                 !Restore local configuration
          call enable(L,fLmx)             !...and interrupt-scheduling
      endif
  
      call restore(R)                     !Restore remote configuration
      call enable(R,fRmx)                 !Restore remote interrupt-sched
  
      call lurq(100000b)                  !Release any locks I've done
      return
  
      end
  
      real*4 function control(lu,fcn,param)              ,<890525.1144>
     >Perform control calls
      implicit none
  
      real*4 rstat
      integer*2 lu,fcn,param,xl(2),cw
      equivalence (xl(2),cw),(xl,rstat)
 
!     While this routine is >never< actually called as a function, we define
!     it as such so that ABReg will work to return the status of the control
!     request to the caller (as used by connect).
  
      xl = lu
      cw = fcn
      call xluex(3,xl,param)              !Perform the control function
      call abreg(xl,cw)                   !get the status of the request
      control = rstat                     !Return it to the caller
  
      return
      end
  
      subroutine ReportFileError(err,nam)                ,<890525.1144>
     >Report file errors
      implicit none
  
c     Since it is the nature of this routine to never return to its
c     caller, we will ALWAYS close the current file (being sent or
c     received) as well as terminating any masked-/indirect-search
c     operation in progress
  
      include kercom.ftni,NOLIST
      include kercmd.ftni,NOLIST
      include kerdbg.ftni,NOLIST
      include kerfil.ftni,NOLIST
      integer*2 err,j,TrimLen
      character*(*) nam
  
      cmCh = ' '                          !Clear the current command
      call FmpError(err,ErrMsg)           !Decode the error-number
      j = TrimLen(ErrMsg) + 1             !Find the end of the text
      if (TrimLen(nam) .gt. 0) then
          ErrMsg(j:) = ': ' // nam        !Tack on the file-name
      endif
  
      call FmpClose(fiCb,err)             !Shut down file/mask operations
      call FmpEndMask(maCb)
  
      call kdebug(all,ErrMsg,' ')         !Log the error-message (debug)
      call LoadSeg(3) $ Call SndErr       !If in packet-I/O, do error-pkt
  
      if (R.eq.L .and. .not. fServ) then
          call NrmIO                      !Restore "local" in remote-host
      endif
  
      goto fePath                         !Return to KERMIT MAIN PROGRAM
  
      end
  
      subroutine Server                                  ,<890525.1144>
     >Be a KERMIT Server
      implicit none
  
c     The only way out of this, once begun, is to receive a FINISH or
c     BYE command from the other KERMIT.
  
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST          !Defines fRmx
      include kerdbg.ftni,NOLIST
      include kerfil.ftni,NOLIST
      integer*2 len,num
      logical*2 receive,send
      character*1 pt,RecPack
  
 10   call Set_Timeout(R,9000,fRmx)       !Do 90-second server timeout
      sCheck = 1                          !Server commands use 1-byte checks
      call LoadSeg(3)                     !Insure file-xfr subs are callable
      call PakIO                          !Set flags for packet-I/O
 
      pt = RecPack(len,num)               !Get a command packet
  
      if (pt.eq.'S' .or. pt.eq.'I') then  !Send file or initialize?
          seq = num                       !Yes - make seq# agree
          fSend = .false.                 !Do param-stuff like a receive
          call RecPar(len)                !Get partner's parameters
          if (fBnry .and. Parity.ne.3 .and. .not.fBit8) then
              ErrMsg = 'Can''t receive binary file (parity problem)'
              call SndErr
              fBnry = .false.
              goto 10
          endif
          if (pt .eq. 'I') call doIpacket !Change my params to remote's vals
          call SndPar('Y',seq)            !...and send mine
          if (pt .eq. 'S') then           !Actually send a file?
              sCheck = NewChk             !OK to change checksum type now
              first = .true.              !Allow LEGALIZE to process RMASK
              mask = rmask                !Set the receive mask
              seq = mod(seq+1,64)
              if (receive('F')) then
                  call kdebug(all,'Server receive completed',' ')
              else
                  call kdebug(all,'Server receive failed',' ')
              endif
          endif
      else if (pt .eq. 'R') then          !Send file(s)?
          first = .true.                  !Prepare to do file masking
          fiNm = ' '                      !Clear old file name
          mask = RecPkt(5:len+4)          !Get the file mask
          if (send()) then
              call kdebug(all,'Server send completed',' ')
          else
              call kdebug(all,'Server send failed',' ')
          endif
  
      else if (pt .eq. 'G') then          !Generic command?
          pt = RecPkt(5:5)                !Get the data field
          if (pt .eq. 'F') then           !Finish?
              call SndPack('Y',num,0)     !Yes - acknowledge it
              call quit                   !Turn off everything
              call exec(6)                !...and stop
  
          else if (pt .eq. 'L') then      !Bye (logout)?
              call SndPack('Y',num,0)     !Acknowledge it
              call quit                   !Turn everything off
              call Logoff3                !and log off the session
  
          else                            !Other generic packet type?
              ErrMsg = 'Unknown generic packet type: ' // pt
              call kdebug(all,ErrMsg,' ')
              call SndErr
          endif
  
      else if (pt .eq. 'T') then          !Time-out?
          seq = 0                         !Reset the sequence number
          call SndPack('N',seq,0)         !Guard against lost packets
          goto 10                         !Ignore it
  
      else if (pt .ne. 'N') then          !Something other than NAK?
          ErrMsg = 'Unknown Server packet type: ' // pt
          call kdebug(all,ErrMsg,' ')
          call SndErr
      endif
  
      goto 10
  
      end
  
      logical*2 function Send()                          ,<890525.1144>
     >Send-state switch
      implicit none
  
      include kercom.ftni,NOLIST
      include kerdbg.ftni,NOLIST
      include kerfil.ftni,NOLIST
      include kersta.ftni,NOLIST
      integer*2 retry
      character*1 sdata,sfile,seof,sinit,sbreak
      character*3 c_r
  
      state = 'S'                         !Set initial state
      c_r = char(13) // ' _'
      fSend = .true.                      !Set Send/Receive flag for send
      send = .false.                      !Clear the success flag
      retry = 0                           !Reset the retry-counter
      call LoadSeg(2) $ call NextFile     !Get 1st file to send
      if (fiNm .eq. ' ') return           !Nothing to send
      call LoadSeg(3) $ call StartStats   !Prepare for packet-I/O
  
 10   if (state .eq. 'D') then            !Send data?
          state = sdata(retry)
      else if (state .eq. 'F') then       !Send file header?
          state = sfile(retry)
      else if (state .eq. 'Z') then       !Send EOF?
          state = seof(retry)             !Yes - send the packet
          if (state .eq. '@') then        !Ready for next file?
              call LoadSeg(2)             !Get the file-masking routines
              call NextFile               !Get next file to send
              call LoadSeg(3)             !Restore packet-I/O capability
              if (fiNm .eq. ' ') then     !Is there one?
                  state = 'B'             !No - break the connection
              else
                  state = 'F'             !Yes - do a file-header
              endif
          endif
      else if (state .eq. 'S') then       !Send initial packet?
          state = sinit(retry)
      else if (state .eq. 'B') then       !Send final packet?
          state = sbreak(retry)
      else if (state .eq. 'C') then       !Last file sent?
          call endstats                   !Turn off statistics logging
          send = .true.
          return
      else if (state .eq. 'E') then       !Did we receive an error packet?
          call endstats
          if (.not. fServ) call tpFm(ErrMsg)
          return
      else if (state .eq. '!') then       !Did we get an error?
          call endstats
          call SndErr
          return
      else                                !Unknown packet?
          call endstats
          ErrMsg = 'Send-state error; state = ' // state
          call kdebug(states,ErrMsg,' ')
          if (R .ne. L) then
              call tpFm(ErrMsg)
          endif
          call SndErr
          return
      endif
  
      call kdebug(states,'TxState: ',state)
      if (retry .ne. 0) rtry = rtry + 1
      if (R .ne. L) then
          call tpI2(c_r,spak,6)
          call tpI2('/_',rtry,-3)
          call tpFm(' _-')
      endif
  
      goto 10
      end
  
      subroutine sleep(csec)                             ,<890525.1144>
     >Delay for N centiseconds
      implicit none
  
      integer*2 csec,i
  
      if (csec .gt. 0) then               !Need negative units to wait
          i = -csec
      else
          i = -2                          !Always wait at least 2 units
      endif
  
      call exec(12,0,1,0,i)
c                ^ ^ ^ ^ ^
c                ! ! ! ! +----> number of units to delay
c                ! ! ! +------> repeat this how many times?" (none = 0)
c                ! ! +--------> Units are centiseconds
c                ! +----------> Suspend myself (not some other task)
c                +------------> Executive request code to suspend
c     In order to read the above diagram, read upwards:
c         "I want the executive to suspend me once for (csec) centiseconds,
c          and then I will do something else."
  
      return
      end
  
      block data main_common                             ,<890525.1144>
     >KERMIT's labeled common areas
      implicit none
  
      include kcmnds.ftni
      include kconcw.ftni
      include kercmd.ftni
      include kercnf.ftni
      include kercom.ftni
      include kerdbg.ftni
      include kerfil.ftni
      include kersta.ftni
  
      data Lsyu       /0/                 ! Insure 1st-time stuff is done
  
      data seg        /0/                 ! Insure 1st LoadSeg call works
      data delay      /1500/              ! 15 sec from SEND to 1st pkt
      data EsChar     /29/                ! CTRL-] returns to local KERMIT
      data MaxTry     /5/                 ! Normal retry-limit is 5
      data ImxTry     /15/                ! Initial retry-limit is 15
      data R          /0/                 ! Remote LU is unknown at startup
      data seq        /0/                 ! Sequence numbers starts at 0
      data Class      /0/                 ! We get a class# as needed
      data sPcnt      /9/                 ! I only have 9 parameters to send
      data Parity     /0/                 ! 'Not set yet'
  
! My packet parameters follow
      data PakSiz     /94/                ! Current packet size
      data Timeout    /0/                 ! (filled in by GetPakTime)
      data nPad       /0/                 ! I require no padding, but...
      data Padch      /0/                 !  ...use nulls if you must pad
      data EOLch      /13/                ! I require CR as a terminator
      data Quote      /35/                ! I want "#" before controls
      data Bit8       /38/                ! I want "&" before 8th-bit set
      data ChkTyp     /1/                 ! I do type-1 checksums
      data Repc       /126/               ! Repeat-count prefix is "~"
      data Sync       /1/                 ! CTRL-A starts my packets
  
! My partner's defaults are reset by subroutine RecPar to:
      data sPkSiz     /80/                ! Packet size
      data sTime      /30/                ! Timeout (never wait past 30 sec)
      data sPad       /0/                 ! I'll never send padding
      data sPadch     /0/                 ! (If I pad, I'll use nulls)
      data sEOL       /13/                ! <CR> is end-of-packet
      data sQuote     /35/                ! "#" precedes control-characters
      data sBit8      /32/                ! No 8th-bit quoting assumed
      data sCheck     /1/                 ! 1-byte checksums used
      data sRepc      /32/                ! No repeat-counts assumed
      data sSync      /1/                 ! CTRL-A starts your packets
  
! Utility defaults follow
      data fWarn      /.true./            ! I will warn of file overwrites
      data fIBM       /.false./           ! I am not in IBM mode
      data fServ      /.false./           ! I am not in server mode
      data fEcho      /.false./           ! I am not echoing transfer-file
      data fTrans     /.false./           ! I am not using a transfer-file
      data f8OK       /.true./            ! I will allow 8-th bit quoting
      data HlpNam     /' '/               ! I don't know the help file name
  
      data state      /'C'/               ! File-transfer is C(omplete)
      data Prompt     /'Kermit-RTE>'/     ! Command-line prompt
 
! File defaults follow
      data fBnry      /.false./           ! Assume ASCII transfers
      data Mask       /' '/               ! Set default (directory) mask
      data Rmask      /' '/               ! Clear the server-receive mask
      data fiNm       /' '/               ! Clear the file-name storage
  
! Debugging defaults follow
      data dbNm       /' '/               ! No debugging file opened
      data dbLv       /0/                 ! No debugging in progress
  
! Status stuff follows
      data tspak      /0/                 ! No packets sent yet     (total)
      data trpak      /0/                 ! No packets received yet (total)
      data trtry      /0/                 ! No retries yet          (total)
      data spak       /0/                 ! No packets sent yet     (current)
      data rpak       /0/                 ! No packets received yet (current)
      data rtry       /0/                 ! No retries yet          (current)
      data sbytes     /0/                 ! No bytes sent
      data rbytes     /0/                 ! No bytes received
      data sovrhd     /0/                 ! No overhead bytes sent
      data rovrhd     /0/                 ! No overhead bytes received
  
!     WARNING: The order of the pvalues must match the order of the parity
!              commands themselves in /KCMNDS/
!     Parity bits =  EVEN,   MARK,    NONE,    ODD,  SPACE
      data pvalu / 41400b, 41000b, 140000b, 40400b, 40000b,
     >             41400b, 40400b,      0b, 41000b, 40000b/
  
! Command constants follow
      data commands/
     >    'BYE',    'CONNECT', 'EXIT',    'FINISH', 'GET',
     >    'HELP',   'QUIT',    'RECEIVE', 'RUN',    'SEND',
     >    'SERVER', 'SET',     'SHOW',    'STATUS', 'TRANSFER'/
      data setparms/
     >    'BINARY', 'BQUOTE', 'CHECK',  'DEBUG',  'DELAY',  'ESCAPE',
     >    'IBM',    'LINE',   'PACKET', 'PARITY', 'PROMPT', 'QUOTE',
     >    'REPEAT', 'RETRY',  'RMASK',  'SYNC',   'WARNING'/
      data parits  / 'EVEN', 'MARK', 'NONE', 'ODD',     'SPACE'/
      data debugs  / 'ALL',  'FILE', 'OFF',  'PACKETS', 'STATES'/
  
      end
      program K1CMD(5)                                   ,<890525.1144>
     >KERMIT command processors
      implicit none
  
      include kercom.ftni,NOLIST
      include kercmd.ftni,NOLIST
      include kercnf.ftni,NOLIST
  
$alias /datc/ = '$DATC', NoAllocate
$alias xla    = '.XLA', direct
  
      integer*2 datc,SyRv,xla
      common /datc/ datc
  
      seg = 1
      if (Lsyu .eq. 0) then               !Need to initialize?
          call GetMux(L,LocCnf)           !Get the local configuration
          SyRv = xla(datc)                !Get the system date-code
  
          call tpCh('HP-1000 RTE-KERMIT Version 1.99d <890525.1144>'
     >                                                ,char(10),0)
          call tpCh(' KERMIT-RTE requires EOL=13!',char(10),0)
  
          call HostMode                   !Check and/or change host mode
          fServ = .false.                 !Can't be serving on startup
          cmCh = ' '                      !Clear the command-line
          call getst(cmIn,-65,cmLn)       !Get a possible run-string
  
          if (SyRv .gt. 5010) then        !Newer than I know about?
              call tpFm('BEWARE - KERMIT has not been tested_')
              call tpFm(' under this system revision!')
          endif
  
          call SetTrap(SyRv)              !Set FORTRAN-traps as needed
      endif
  
      call SegRt
  
      end
  
      subroutine Command                                 ,<890525.1144>
     >Do user commands
      implicit none
  
      include kercom.ftni,NOLIST
      include kercmd.ftni,NOLIST
      include kcmnds.ftni,NOLIST
      include kerdbg.ftni,NOLIST
      integer*2 i,err,xl(2),cw,FmpOpen,FmpRead,TrimLen,Match
      logical*2 MustBeLocal
      character*1 cmC1(80)
      equivalence (xl(2),cw),(cmC1,cmLn)
      data cw /400b/                      !Set Echo on terminal LU
  
      xl = L                              !Put LU into control-word
  
 10   if (fTrans) then                    !Getting transfer-file commands?
          cmCh = ' '                      !Yes - clear the command-line
          cmLn=FmpRead(trCb,err,cmIn,65)  !Yes - get one
          if (err.lt.0 .or. cmLn.lt.0) then  !On EOF or error...
              call FmpClose(trCb,fTrans)     !(don't destroy read-error)
              fTrans = .false.               !Turn off transfer-file flag
          endif
          if (err.lt.0) call ReportFileError(err,'<transfer-file>')
      endif
  
!     By first going to the transfer-file for a command and allowing zero-
!     length commands, I can perform a sort of 'return to the console'
!     operation FOR ONE COMMAND ONLY per blank line in in the transfer-
!     file.  If you find yourself at a console prompt unexpectedly, you
!     can make KERMIT go back to the transfer-file (without processing a
!     dummy command) by entering one or more commas only.
  
      cmLn = TrimLen(cmCh)
      if (cmLn .lt. 1) then
          fPkIO = .false.                 !Can't be in packet-I/O here
 20       call tpCh(Prompt,' _',0)        !Prompt the user
          call xreio(1,xl,cmIn,-65)       !get a command
          call abreg(i,cmLn)              !Get the input length
          cmCh(cmLn+1:) = ' '             !Clear unused part of command
          cmLn = TrimLen(cmCh)            !Now get the data length
          if (cmLn .lt. 1) goto 20        !Reprompt if none given
      endif
  
!     This is the top-level parser.  For a given top-level keyword, do the
!     function indicated.  Most commands can be (severely!) abbreviated.
  
      if (fEcho) call tpCh(' -',cmCh,0)   !Echo as directed
      call kdebug(all,'Command: ',cmCh)   !log the command
      cmRu = cmCh                         !Save for RunProgram/SetPrompt
      call CaseFold(cmCh)                 !Convert to upper case
      do i = 1,cmLn                       !Convert commas to blanks
          if (cmC1(i) .eq. ',') cmC1(i) = ' '
      enddo
      cmLn = TrimLen(cmCh)                !"Kill" trailing blanks
      if (cmLn .lt. 1) goto 10            !Ignore the current command
      cmP2 = 0                            !Initialize token search
      call gettok('?')                    !Locate a token
  
      i = match(commands,cmtsiz,0)        !Find the command in vocabulary
      if (cmTk .eq. '?') goto 30
      if (i .gt. 0) then                  !If in vocabulary...
          cmTk = commands(i)              !...expand the command token
      endif
  
!     In the "case" statement which follows, we only return after surviving
!     the parsing for commands which perform packet-I/O.
  
      if (cmTk .eq. 'BYE') then
          if ( MustBeLocal() ) return     !Only return if local-host
      else if (cmTk .eq. 'CONNECT') then
          call connect
      else if (cmTk.eq.'EXIT' .or. cmTk.eq.'QUIT') then
          call quit
          call exec(6)
      else if (cmTk .eq. 'FINISH') then
          if ( MustBeLocal() ) return     !Remote-host not allowed
      else if (cmTk .eq. 'GET') then
          if ( MustBeLocal() ) then
              call GetFile(*30)
              cmTk = 'GET'
              return
          endif
      else if (cmTk .eq. 'HELP') then
          call help
      else if (cmTk .eq. 'RECEIVE') then
          call RecFile(*30)
          cmTk = 'RECEIVE'
          return
      else if (cmTk .eq. 'SEND') then
          call SndFile(*30)               !Parse the command
          cmTk = 'SEND'
          return
      else if (cmTk .eq. 'SERVER') then
          call ServerInit(*30)            !Ok to go to server?
          cmTk = 'SERVER'
          return
      else if (cmTk .eq. 'SET') then
          call Set
      else if (cmTk .eq. 'SHOW') then
          call show
      else if (cmTk .eq. 'STATUS') then
          call status
      else if (cmTk .eq. 'TRANSFER') then
          if (fTrans) then
              call tpFm('Transfer-files may not be nested!')
          else
              call gettok(' ')            !Get transfer-file's name
              if (FmpOpen(trCb,err,cmTk,'ro',1) .gt. 0) then
                  fTrans = .true.
                  call gettok('NO')       !Default to no echo
                  fEcho = (cmTk(:2) .ne. 'NO')
              else
                  call FmpReportError(err,cmTk)
              endif
          endif
      else                                !If no token matches...
          call RunProgram                 !...assume it is a program name
      endif
  
 30   cmCh = ' '                          !Clear last command out
      goto 10                             !Get another command
  
      end
  
      subroutine HostMode                                ,<890525.1144>
     >Check host mode
      implicit none
  
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST          !Defines fRmx
  
      integer*2 bngdb,i
      character*5 rates(0:15)
      data rates/'????','50','75','110','134.5','150','300','1200',
     >           '1800','2400','4800','9600','19.2k','38.4k','115k',
     >           'sense'/
  
      if (R .eq. 0) then                  !Is remote lu undefined?
          R = L                           !Assume remote-host mode
          call MoveWords(LocCnf,RemCnf,CnfSiz) !local config -> remote array
      endif
  
      call tpFm('KERMIT-RTE is in _')
      call GetPakTimeout(i)               !Sense "remote" baud rate
      if (R .eq. L) then
          call tpFm('remote-host mode_')
          if (.not. fRmx) then
              call tpFm(', but not on a mux port')
              call tpFm('(You''ll need to SET LINE to some mux LU_')
              call tpFm(' before you can transfer files)')
              call tpFm(' "Server" is not available at this LU!')
          else
              call tpFm('; file transfers are ok')
              if (bngdb() .eq. 0) call lurq(100001b,L,1)
          endif
      else
          call tpI2('local-host mode to LU _',R,0)
          call tpCh(' @ _',rates(i))      !Show the baud rate
          call tpFm(' baud; _')
          call ShowParity
          call lurq(100001b,R,1)
      endif
  
      return
      end
  
      integer*2 function GetPakTimeout(i)                ,<890525.1144>
     >Get Packet-I/O timeout
      implicit none
  
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST
      integer*2 baudtimes(14),i,ixget
  
c     baud rate-->       50,   75,  110,134.5,  150,  300,  1200+
      data baudtimes / 2500, 1900, 1500, 1300, 1200,  900,  8*600 /
  
c     This routine sets my timeout value (in my parameter block) as a
c     function of the REMOTE's baud-rate.  It returns as it's parameter
c     the index to the baud-rate table, and as it's value the number of
c     100ths of a second to wait for a packet (from me) as follows:
c          the time required to receive 100 bytes at the given baud rate
c        + 1 second for any fractional second from the above
c        + 5 seconds for processing time.
  
c     NOTE: the remote KERMIT will tell me (in the SINIT packet) if I
c     should time-out a packet-receive; even if the remote KERMIT doesn't
c     want that processing, I'll still time-out a packet receive after
c     30 seconds.  Note that in any event, under RTE-A no receive-packet
c     timeouts will occur because the device driver must be bypassed.
  
      i = r30c                            !Get the current configuration
      i = iand(ishft(i,-3),17b)           !Isolate/right-justify rate
      if (i.lt.1 .or. i.gt.12) then       !Is it a legal value?
          i = 0                           !No - return "unknown"
          Timeout = 0                     !...and don't do timeouts
      else
          Timeout = baudtimes(i)/100      !Put in my parameter block
      endif
  
      GetPakTimeout = Timeout * 100       !Tell SERVER the timeout value
  
      return
      end
  
      subroutine ShowParity                              ,<890525.1144>
     >Show remote-port parity
      implicit none
  
      include kercom.ftni.NOLIST
      include kercnf.ftni.NOLIST
      include kcmnds.ftni.NOLIST
      integer*2 i,j,k,pmask,pvals(5,2)
      parameter (pmask = 141400b)         !Mask removes current parity bits
      equivalence (pvalu,pvals)
  
      i = r30c .and. pmask                !Isolate current parity bits
      j = (iRmx .and. 1) + 1              !Set pvalu index for B/C or D mux
      call tpFm(' Parity = _')
      do k = 1,prtsiz
          if (i .eq. pvals(k,j)) then
              call tpFm(parits(k))
              return
          endif
      enddo
      call tpFm(' Unknown!')
  
      return
      end
  
      logical function ctoi(rval)                        ,<890525.1144>
     >Parse ASCII to integer
      implicit none
  
c     This routine parses ASCII characters into a single 16-bit integer.
c     The character data may be in decimal, octal ("B" must be the last
c     byte), or hexadecimal ("H" must be the last byte), and may contain
c     a leading sign.  A character-literal may be entered as a number if
c     the other (last) character is a '"'.  CTOI returns false if no
c     numeric can be parsed due to no data or illegal data.  The
c     command-line pointer cmP2 is expected to point to the end of the
c     previous token on entry; cmP1 and cmP2 will point to the next
c     token on exit, or cmP1 will equal 0 if there are no more tokens
c     on the line.
  
      include kercmd.ftni,NOLIST
      integer*2 p,i,e,rval,base
      character*1 c,s
  
      ctoi = .false.                      !Show initial "no number found"
      rval = 0                            !...and clear the value save
      call gettok(' ')                    !Isolate the numeric
      if (cmP1 .lt. 1) return             !there isn't a number there
  
      e = cmP2                            !Save end pointer
      c = cmCh(e:e)                       !Get base character (if any)
      if (c .eq. 'B') then                !Is it octal?
          base = 8                        !Yes
          e = e - 1                       !Don't parse the "b"
      else if (c .eq. 'H') then           !No? try hexadecimal
          base = 16
          e = e - 1                       !Don't parse the "h"
      else if (c .eq. '"') then           !No? try ASCII literal
          if ( (cmP2-cmP1) .eq. 1) then   !(must be the literal, then a '"')
              c = cmCh(cmP1:cmP1)         !Get the character
              rval = ichar(c)             !Convert to integer
              ctoi = .true.
              return
          endif
      else                                !No? assume decimal
          base = 10
      endif
  
      p = cmP1                            !Save the starting pointer
      c = cmCh(p:p)                       !Get sign (if any)
      if (c.eq.'+' .or. c.eq.'-') then    !If there is a sign...
          p = p + 1                       !Bump the byte pointer
          s = c                           !...and save the sign byte
      else
          s = ' '
      endif
  
      do while (p .le. e)                 !Parse the number
          c = cmCh(p:p)                   !Get a byte
          p = p + 1                       !Bump the byte pointer
          i = ichar(c) - 60b              !Convert numerics to integer
          if (i .lt. 0) return            !non-numeric found
          if (i.gt.9) then                !Allow possible hex digits
              if (i.lt.17 .or. i.gt.22) return  !Insure it is 'A' thru 'F'
              i = i - 7                         !Scale hex digits
          endif
          if (i .ge. base) return         !Illegal byte for this base
          rval = (rval*base) + i          !Continue forming number
      end do
  
      ctoi = .true.
      if (s .eq. '-') rval = -rval        !Deal with a "-", if found
      return
      end
  
      subroutine gettok(default)                         ,<890525.1144>
     >Get a command-line token
      implicit none
  
c     This routine is sets cmP1 and cmP2 to the start and end of a "token"
c     (one or more non-blanks in the command line), and cmTk is set to the
c     token itself.  If there are no more tokens in the line, cmP1 returns
c     zero, cmP2 is undefined, and cmTk returns the "default" string.
c
c     NOTICE -- cmP1 is always set to cmP2+1 before use; to locate the
c     first token in a line you must set cmP2 to 0.  Locating the "next"
c     token on a line is automatic.
  
      include kercmd.ftni,NOLIST
      character*(*) default
  
      cmP1 = cmP2 + 1                     !Always go to next byte
      call skipbl(cmP1)                   !Skip leading blanks
      cmP2 = cmP1                         !We have start-of-token
      call skip2bl(cmP2)                  !go 1 past end-of-token
      cmP2 = cmP2 - 1                     !Back up to end-of-token
      if (cmP1 .gt. cmLn) then            !Are we past last token?
          cmP1 = 0                        !Yes - note it
          cmTk = default
      else
          cmTk = cmCh(cmP1:cmP2)
      endif
  
      return
      end
  
      integer*2 function match(tabl,tlen,dum)            ,<890525.1144>
     >Match token to token-table
      implicit none
  
      include kercmd.ftni,NOLIST
      include kercom.ftni,NOLIST
      character*(*) tabl(*)
      integer*2 tlen,dum
      logical*2 fCMMD                     !True for special COMMAND call
      character*1 tc
      integer*2 t1,t2,len,TrimLen
  
c     MATCH tries to locate the token (cmTK) in the TABLe of strings
c     containing TLEN entries.  If the token is found >uniquely< in
c     the table, the index of that entry is returned as the value of
c     MATCH; otherwise MATCH returns 0.  If the token contains a "?",
c     any table entries which were matched up to (but not including)
c     the "?" are printed on locally with an appropriate message.
c     In the absence of a "?", if more than one table entry matches
c     the token, MATCH returns as if there was no match and prints a
c     message to inform the user of ambiguous data and shows all of
c     the possible choices.
c
c     cmTk must not contain embedded blanks
c     TABL must be in alphabetical order
  
      fCMMD = pcount() .eq. 3             !True if special COMMAND call
      len = TrimLen(cmTk)                 !Get the token's length
      t1 = 1                              !Set current low table index
      t2 = tlen                           !Set current high index
      p = 1                               !Set token byte-pointer
      match = 0                           !Show no match initially
  
      do while (p .le. len)               !Begin matching here
          tc = cmTk(p:p)                  !Get a token character
          if (tc .eq. '?') then           !If "?" then give possibilities
              call tpFm('The following are legal at this point:')
              call outtbl(tabl,t1,t2)
              return
          endif
 
c         (do while token is less than lower table entry)
          do while (tc.gt.tabl(t1)(p:p) .and. t1.le.t2)
              t1 = t1 + 1
          enddo
  
c         (do while token is greater than upper table entry)
          do while (tc.lt.tabl(t2)(p:p) .and. t2.ge.t1)
              t2 = t2 - 1
          enddo
 
c         (if we know we have a mismatch...)
          if (t2 .lt. t1) then
              if ( fCMMD ) return
              call tpCh('No such command or parameter -',cmTk(:len),0)
              call tpFm('The following are legal at this point:')
              call outtbl(tabl,1,tlen)
              return
          endif
  
          p = p + 1                       !Bump the token byte-pointer
  
      enddo
  
c     After scanning all of the token, is it still ambiguous?
  
      if (T1 .ne. T2) then
          if ( fCMMD ) return
          call tpCh('"_',cmTk,len)
          call tpFm('" is ambiguous; possible matches are:')
          call outtbl(tabl,t1,t2)
      else
          match = t1
          cmTk = tabl(t1)                 !Expand the token
      endif
  
      return
      end
  
      subroutine outtbl(tabl,t1,t2)                      ,<890525.1144>
     >Print strings (tabular)
      implicit none
  
      character*(*) tabl(*)
      integer*2 t1,t2
      integer*2 cwid,ncol,i,j,k
  
c     This routine prints strings in a table (TAB) from indexes T1 to T2
  
      cwid = len(tabl(1))                 !Get the column width
      ncol = 80 / (cwid + 2)              !Get # of displayable columns
  
      do i = t1,t2,ncol                   !Output the columns
          do j = 1,ncol                   !print each table entry
              k = i + j - 1
              if (k .le. t2) then
                  call tpCh(' _',tabl(k),cwid)
                  if (j .lt. ncol) call tpFm(' _')
              endif
          enddo
          call tpFm('-')
      enddo
  
      return
      end
  
      subroutine connect                                 ,<890525.1144>
     >Do terminal-emulation
      implicit none
  
      include kconcw.ftni,NOLIST          !Defines XLUEX ConWords + term
      include kercom.ftni,NOLIST
      include kercmd.ftni,NOLIST
      include kercnf.ftni,NOLIST
      include kerdbg.ftni,NOLIST
      integer*2 ib(128),il                !The input buffer & its length
      integer*2 k,a,b,gtnw                !Various temporaries
      logical*2 eflag                     !TRUE if escape-char processed
      logical*2 NeedRTerm                 !TRUE if Remote needs termination
      logical*2 ifbrk,SetLine,MustBeLocal
  
      k = cmP2                            !Save current parsing pointer
      call GetTok('none')                 !See if there is another parameter
      if (cmTk .ne. 'none') then          !If so, do Set Line for the user
          cmP2 = k                        !Restore the parsing pointer
          cmTk = 'CONNECT'                !...and the "current" command
          if (.not. SetLine() ) return    !The set line didn't work
      endif
 
      if (.not. MustBeLocal() ) return    !User hasn't Set Line yet
  
      eflag = .false.                     !No escape-char seen yet
      fASI = .not. fLmx                   !Set for Local ASIC-type card
      fRcm = .not. btest(iRmx,0)          !Note if remote uses B/C mux
      fLcm = .not. btest(iLmx,0)          !Note if local uses B/C mux
      if (class .eq. 0) then              !Do we need a class number?
          call clrq(100001b,class)        !Yes - get one
          call abreg(a,b)                 !Get return status
          if (a .lt. 0) then              !Did we get a class # ?
              call tpFm('Cannot connect: no class numbers available')
              return
          else
              class = ior(class,20000b)   !Set "don't de-allocate" bit
          endif
      endif
  
!     (Since GtNW is not in common, we must set it here)
      gtnw = ior(class,100000b)           !Set no-wait bit
 
      call cPrep                          !Prepare ports for connect-mode
  
      call tpI2('[connecting to LU _',R,0)
      call tpFm('; return via "control-_')
      call tpCh(char(EsChar+64),'" then "C"]',0)
  
      if ( fASI ) then                    !Non-mux local does class I/O
          call xluex(17,Lrx,ib,-1,0,0,class)  !Start local read
      endif
      if ( fRcm ) NeedRTerm = .true.      !Terminate 1st B/C mux buffer
  
!     The connect loop consists of an inner polling-loop and the outer
!     processing-loop as follows:
!         The inner polling-loop interrogates the remote status looking
!             for availability of type-ahead data, and the local keyboard
!             (via a no-wait class "get" call, or, if on a mux, when some
!             typed-ahead data becomes available) until one of them shows
!             data available, or until the break-flag is set (which will
!             simulate the user typing <escape-character>"C" to close the
!             connection.  Processing of remote data is handled within
!             the inner-loop; we exit the inner-loop on receipt of any
!             keyboard data or if another user "breaks" this KERMIT.
!         The outer processing-loop has two major divisions: the polling
!             loop, and local data-handling, which must be checked on a
!             character-by-character basis for the presence of the escape
!             character.  An escape character signals the beginning of a
!             user command to (the local) KERMIT.
!
!     The flow of this code is sufficiently complicated that I have elected
!     to use (gasp!) a few statement numbers rather than the more elegant
!     (and more cumbersome) if-then-else and unnumbered do-while constructs
!     found in previous versions of this routine.
!
!     I am indebted to Bruce K. Swope, of Intermedics, Inc. in Freeport,
!     Texas, for his assistance in locating the cause of the "mux lockup".
!     His ideas on the handling of the remote port have resulted in greatly
!     reducing (if not completely eliminating) occurrences of this dreaded
!     condition.
!
!     "D" mux handling notes: as you can probably see from the code, the
!     12040D handles much nicer than the B or C revisions (can't wait for
!     the M/E/F version!).  The card can buffer up to 1024 bytes, but I
!     don't want to tie up that much memory; I have elected to never read
!     more than 256 bytes from remote port at any given time.
  
 10   do while (.true.)                   !inner-loop begins
          if (NeedRTerm) then             !Need to terminate remote?
              call control(R,term,0)      !Yes - do it, but not more than
              NeedRTerm = .false.         !...once per input buffer
          endif
          call sleep(4)                   !Let other folks run for 40 ms.
          if ( IfBrk(k) ) goto 40         !Proceed as if "<esc>C" entered
          if ( fLmx ) then                !Local on mux?
              call control(L,dstat,0)     !Yes - get local status
              call abreg(a,il)
              if (il .gt. 0) then         !Any data available?
                  call xluex(1,Lrx,ib,-1) !Yes - get only 1 byte...
                  if ( fLcm ) then        !For local B/C mux...
                      call control(L,term,0)  !...re-terminate input
                  endif
                  il = 1 $ goto 20        !...and process it
              endif
          else
              call exec(21,gtnw,ib,-1)    !Look for keyboard data
              call abreg(a,il)            !Get the status
              if (a .gt. 0) goto 20       !Keyboard data is available
          endif
          call control(R,dstat,0)         !Request remote status
          call abreg(a,il)                !Get it back from driver
          if (il .gt. 0) then             !Data available?
              il = min(il,256)            !Limit input to 256 bytes
              call xluex(1,Rrx,ib,-il)    !Yes - get it
              if ( fLmx ) then            !Local on a mux?
                  call xluex(2,Ltx,ib,-il)   !Yes - just write
              else
                  call clrq(3,class,L)       !Abort pending keyboard read
                  call xluex(2,Ltx,ib,-il)   !Copy remote data to display
                  call xluex(17,Lrx,ib,-1,0,0,class)  !Set new keyboard read
              endif
              if ( fRcm ) then            !Terminate remote on next pass...
                  NeedRTerm = .true.      !...if using B or C mux
              endif
          endif
      end do
  
 20   if (il .le. 0) goto 30              !(Ignore keyboard timeout)
  
      if (fIBM) call xluex(2,Ltx,ib,-1)   !Do local echo as needed
      k = ishft(ib,-8)                    !Get the local keystroke
      if (k.gt.140b .and. k.lt.172b) k=k-40b   !Shift to upper-case
  
      if (k .eq. EsChar) then             !Escape?
          eflag = (.not. eflag)           !Yes - toggle the escape flag
          if (eflag) il = 0               !Send if previous was escape
      else if (eflag) then                !If last keypress was escape...
          il = 0                          !say "don't send this"
          eflag = .false.                 !turn off escape flag
          if (k .eq. 103b) then           !'C' or 'c': close the connection
              goto 40
          else if (k .eq. 122b) then      !'R' or 'r': resume debug logging
              dblv = iand(dblv,77777b)
          else if (k .eq. 123b) then      !'S' or 's': stop debug logging
              dblv = ior(dblv,100000b)
          else if (k .eq. 63) then        !'?': help
              call tpFm('        C         = Close the connection')
              call tpFm('        R         = Resume debug logging')
              call tpFm('        S         = Suspend debug logging')
              call tpCh('control-_',char(eschar+64),0)
              call tpFm(' (again) = send escape to remote')
              eflag = .true.
          else
              call tpFm('Unknown escape function')
          endif
      endif
  
      if (il .gt. 0) then                 !Anything left to send?
          call xluex(2,Rtx,ib,-1)         !Send keystroke to remote
      endif
  
 30   if ( fASI ) then                    !reset local (non-mux) read
          call xluex(17,Lrx,ib,-1,0,0,class)
      endif
      goto 10                             !keep looping
  
 40   if ( fASI ) then                    !Do non-mux local cleanup
          call clrq(3,class,L)            !Clear pending local requests
          a = 0                           !Prepare to kill completed reqs
          do while (a .ge. 0)
              call exec(21,gtnw,ib,-1)    !Get any completed requests
              call abreg(a,il)
          enddo
      elseif ( fLcm ) then                !Cleanup from local B/C mux?
          call control(L,3700b,102000b)   !Yes (RESTORE does the rest
      endif
      if ( fRcm ) then                    !Restore from B/C connect
          call control(R,3300b,22500b)    !cn33: read reconfig on
          call control(R,3700b,102000b)   !cn37: terminate on CR only
      endif
      call control(R,2600b,1)             !cn26: clear (all) card buffers
      call restore(L)                     !Restore local parameters
      call enable(L,fLmx)                 !Restore int scheduling
      call tpFm('[back at KERMIT-RTE]')
      return
  
      end
  
      subroutine help                                    ,<890525.1144>
     >Process HELP commands
      implicit none
  
      include kcmnds.ftni,NOLIST
      include kercmd.ftni,NOLIST
      include kercom.ftni,NOLIST
      integer*2 i,match,err,o
      integer*2 TrimLen,FmpOpen,FmpSetPosition,FmpRead
      integer*4 cr,nr,OldP,CurP,NxtP,DoPos
      logical*2 fExist
  
      integer*2 hfCb(16)                  !Help-file control block
      integer*2 hBuf(128),hInd(18,7)      !Help-file record buffer
      character*256 hStr
      character*36  hKey(7)               !Help-file key entries
      character*24  TheKey
      equivalence (hBuf(3),hInd,hKey),(hBuf,hStr)
  
!     Statement function -- encodes rec# and offset into a double-integer
      DoPos(cr,o) = ishft(cr,8) + iand(o,377b)
  
      call gettok('HELP')                 !Set pointers to 2nd parameter
  
      i = match(commands,cmtsiz)
      if (i .lt. 1) return                !Just drop invalid commands
      if (cmTk .eq. 'SET') then       !Since SET has parameters...
          call gettok('<')            !...parse the 3rd parameter
          if (cmTk .ne. '<') then     !If it wasn't defaulted...
              i = match(setparms,setsiz)  !...expand the keyword
              if (i .lt. 1) return    !Drop an unknown set parameter
          endif
      endif
  
      if (HlpNam .eq. ' ') then           !Have we found the help file?
          if (fExist('kermit.hlp::system',1)) then   !No - try system dir
              HlpNam = 'kermit.hlp::system'
          else if (fExist('kermit.hlp::kermit',1)) then   !then KERMIT's dir
              HlpNam = 'kermit.hlp::kermit'
          else if (fExist('kermit.hlp',1)) then      !Then user's dir
              HlpNam = 'kermit.hlp'
          else if (fExist('"kermi::0',1)) then       !Last, try FMGR space
              HlpNam = '"kermi::0'
          else
              call tpFm('KERMIT.HLP missing or wrong file-type')
              return
          endif
      endif
  
      i = TrimLen(cmTk)                   !Clean up the key
      if (FmpOpen(hfCb,err,HlpNam,'ro',1).lt.0) then
          call ReportFileError(err,HlpNam)
      endif
      if (FmpRead(hfCb,err,hBuf,256).lt.0) then  !Read 1st record
          call FmpClose(hfCb,i)
          call ReportFileError(err,HlpNam)
      endif
      OldP = DoPos(0J,0)                  !Set previous position
      cr = 1                              !Note current record#...
      nr = 1                              !...and desired ("new") record
      o = 1                               !...and current offset
      CurP = DoPos(cr,o)                  !Save "current" position
      NxtP = DoPos(nr,o)                  !Save "next" position
  
 10   if (NxtP .eq. OldP) then            !In an endless loop?
          call tpFm('Sorry, no help available')  !Yes: kill endless loop
          return
      else
          OldP = CurP                     !Else save where we've been
          CurP = NxtP
      endif
      if (nr .ne. cr) then                !At correct file position?
          if (cr .ne. 0) then             !Handle 1st record after open
              if (FmpSetPosition(hfCb,err,nr,-nr).lt.0) then
                  call FmpClose(hfCb,i)
                  call ReportFileError(err,HlpNam)
              endif
          endif
          if (FmpRead(hfCb,err,hBuf,256).lt.0) then
              call FmpClose(hfCb,i)
              call ReportFileError(err,HlpNam)
          endif
          cr = nr                         !Note new current position
      endif
      TheKey = hKey(o)
      if (cmTk .lt. TheKey(:i)) then      !Current token too high?
          nr = hInd(15,o)                 !Get new record
          o  = hInd(16,o)                 !...and new offset
      else if (cmTk .gt. TheKey(:i)) then !Current token too low?
          nr = hInd(17,o)
          o  = hInd(18,o)
      else                                !Found the key, so...
          nr = hInd(13,o)                 !...get the text rec#
          o  = hInd(14,o)                 !...and char offset
          goto 20
      endif
      NxtP = DoPos(nr,o)                  !Build next-position value
      goto 10                             !Look some more
  
 20   if (FmpSetPosition(hfCb,err,nr,-nr).lt.0) then
          call FmpClose(hfCb,i)
          call ReportFileError(err,HlpNam)
      endif
      if (FmpRead(hfCb,err,hBuf,256).lt.0) then
          call FmpClose(hfCb,i)
          call ReportFileError(err,HlpNam)
      endif
      i = index(hStr(o:),char(4)) - 1     !Locate possible terminator
      if (i .lt. 1) then                  !No terminator yet
          call tpCh(hStr(o:) // '-','_',0)!Print the record
          o = 1                           !...reset the offset
          nr = nr + 1                     !...and go on to next record
          goto 20
      else
          i = i + o
          call tpFm(hStr(o:i))
      endif
  
 999  call FmpClose(hfCb,err)
  
      return
      end
  
      logical*2 function fExist(name,type)               ,<890525.1144>
     >Flag file existence and type
      implicit none
  
      character*(*) name
      integer*2     type,ActType
  
c     This routine returns .true. if the named file exists with the
c     given file-type.  If the file-type is given as a number less
c     than zero, the type-checking is omitted, and fExist returns
c     true if the named file exists as any file type
  
      include kercom.ftni,NOLIST
      integer*2 err,FmpOpen,hfCb(16)
  
      ActType = FmpOpen(hfCb,err,name,'ro',1)
      call FmpClose(hfCb,err)
      if (type .ge. 0) then
          fExist = (type .eq. ActType)
      else
          fExist = (ActType .ge. 0)
      endif
 
      return
      end
  
      subroutine Set                                     ,<890525.1144>
     >Parse/Perform SET commands
      implicit none
  
      include kcmnds.ftni,NOLIST
      include kercom.ftni,NOLIST
      include kercmd.ftni,NOLIST
      include kerfil.ftni,NOLIST
      integer*2 i,match
 
      call gettok('?')                    !Isolate the parameter name
      i = match(setparms,setsiz)
      if (i .lt. 1) then                  !Just return on invalid choice
          return
      else
          cmTk = setparms(i)
      endif
  
      if (cmTk .eq. 'BINARY') then
          call Tok_On_True(fBnry)
          if (fBnry .and. Parity.ne.3 .and. .not.f8OK) then
              fBnry = .false.
              call tpFm('Can''t do binary transfers')
          endif
      else if (cmTk .eq. 'BQUOTE') then
          call SetBQuote
      else if (cmTk .eq. 'CHECK') then
          call SetCheck
      else if (cmTk .eq. 'DEBUG') then
          call SetDebug
      else if (cmTk .eq. 'DELAY') then
          call SetDelay
      else if (cmTk .eq. 'ESCAPE') then
          call SetEscape
      else if (cmTk .eq. 'IBM') then
          if (R .eq. L) then
              call tpFm('SET IBM is illegal in remote-host mode')
          else
              call Tok_On_True(fIBM)
          endif
      else if (cmTk .eq. 'LINE') then
          call SetLine
      else if (cmTk .eq. 'PACKET') then
          call SetPacket
      else if (cmTk .eq. 'PARITY') then
          call SetParity
      else if (cmTk .eq. 'PROMPT') then
          call SetPrompt
      else if (cmTk .eq. 'QUOTE') then
          call SetQuote
      else if (cmTk .eq. 'REPEAT') then
          call SetRepeat
      else if (cmTk .eq. 'RETRY') then
          call SetRetry
      else if (cmTk .eq. 'RMASK') then
          call gettok(' ')                !Get the server-receive mask
          rmask = cmTk
      else if (cmTk .eq. 'SYNC') then
          call SetSync
      else if (cmTk .eq. 'WARNING') then
          call Tok_On_True(fWarn)
      endif
  
      return
      end
  
      subroutine show                                    ,<890525.1144>
     >Process SHOW command
      implicit none
  
      include kercom.ftni,NOLIST
      include kerdbg.ftni,NOLIST
      include kerfil.ftni,NOLIST          !To define fBnry
  
      call HostMode                       !Show who's boss
  
      if (R .ne. L) then                  !we're in local-host mode
          call tpCh('ESCAPE character is ^-',char(eschar+64),1)
          call tpFm('IBM flag is_')
          if (fIBM) then
              call tpFm(' ON; prompt char is DC1')
          else
              call tpFm(' OFF')
          endif
      endif
  
      call tpFm('Binary transfers are_')
      if (fBnry) then
          call tpFm(' enabled')
      else
          call tpFm(' disabled')
      endif
      call tpFm('Receiving a duplicate file will be_')
      if (fWarn) then
          call tpFm(' aborted')
      else
          call tpFm(' allowed')
      endif
      call tpI2('File-send delay (seconds) = -',delay/100,0)
      call tpI2('Checksum type is -',ChkTyp,0)
      call tpI2('PACKET size is -',paksiz,0)
      call tpCh('QUOTE is -',char(quote),1)
      if ( f8OK ) then
          call tpCh('BQUOTE is -',char(Bit8),1)
      else
          call tpFm('Binary quoting is disabled')
      endif
      call tpCh('REPEAT is -',char(Repc),1)
      call tpCh('SYNC is ^-',char(sync+64),1)
      call tpCh('File transfer-state is -',state,1)
      if (dbNm .eq. ' ') then
          call tpFm('The debug log-file is undefined; not debugging')
      else if (dbLv .eq. 0) then
          call tpCh('Nothing is being debug-logged to -',dbNm,0)
      else if (dbLv .eq. ALL) then
          call tpCh('Everything is being debug-logged to -',dbNm,0)
      else if (dbLv .eq. STATES) then
          call tpCh('States are being debug-logged to -',dbNm,0)
      else if (dbLv .eq. PACKETS) then
          call tpCh('Packets are being debug-logged to -',dbNm,0)
      endif
  
      return
      end
  
      subroutine status                                  ,<890525.1144>
     >Give transmission statistics
      implicit none
  
      include kercom.ftni,NOLIST
      include kersta.ftni,NOLIST
      integer*4 time,baud,tbytes,work
      integer*2 hr,min,sec
  
      work = tspak + trpak
      call tpCh(char(10),'Statistics since startup:',0)
      call tpI2(' Packets sent =_',tspak,7)
      call tpI2(' Packets received =_',trpak,7)
      call tpI4(' Total packets =',work,9)
      call tpI2('  (_',trtry,0)
      call tpFm(' of the total were retries)')
  
      time = endtim - startim             !How long did it take (seconds)
      hr = time/3600                      !Get time in hours
      time = time - hr * 3600             !Remove hours from the time
      min = time/60                       !Get time in minutes
      sec = time - min * 60               !...and in seconds
      call tpCh(char(10),'Statistics of last transfer:',0)
      call tpI2(' Transfer time (hh:mm:ss) =_',hr,3)
      call tpI2(':_',min,-2)
      call tpI2(':',sec,-2)
      call tpI4(' Avg tx-packet size =_',sbytes/spak,3)
      call tpI4('  Avg rx-packet size =',rbytes/rpak,3)
  
      work = spak + rpak
      call tpI2(' Packets sent =_',spak,7)
      call tpI2(' Packets received =_',rpak,7)
      call tpI4(' Total packets =',work,9)
      call tpI2('  (_',rtry,0)
      call tpFm(' of the total were retries)')
  
      work = sbytes + rbytes
      call tpI4(' Bytes sent =_',sbytes,9)
      call tpI4(' Bytes received =_',rbytes,9)
      call tpI4(' Total bytes =',work,11)
  
      work = sovrhd + rovrhd
      call tpI4(' Send overhead (bytes) =_',sovrhd,9)
      call tpI4(' Receive overhead (bytes) =',rovrhd,9)
      call tpI4('  Total overhead (bytes) =',work,0)
  
      time = endtim - startim
      work = (sbytes + rbytes) / time
      call tpI4(' Total bytes per second: -',work,0)
  
      work = ( (sbytes+rbytes) - (sovrhd+rovrhd) ) / time * 10
      call tpI4('    Effective baud rate: -',work,0)
  
      return
      end
  
$alias lurq, NOABORT
      subroutine RunProgram                              ,<890525.1144>
     >Process RUN command
      implicit none
  
      include kcmnds.ftni,NOLIST
      include kercom.ftni,NOLIST
      include kercmd.ftni,NOLIST
      integer*2 prams(5),err,FmpRunProgram,TrimLen
      character*5 RunName
  
      if (cmTk .eq. 'RUN') then
          call GetTok('!')                !See if a program name was given
      endif
      if (cmTk .eq. '!') then
          call tpFm('Usage: [ru ]program [params...]')
      else
          call lurq(40000b,L,1,*10)       !Allow other progs to use this LU
 10       err = FmpRunProgram(cmRu,prams,RunName)
          if (err .lt. 0) then
              if (err .eq. -6) then
                  call match(commands,CmtSiz)
              else
                  call FmpReportError(err,cmTk)
              endif
          else
              call exec(14,1,cmIn,-78)    !Get possible run-string
              call abreg(err,cmLn)        !Get length of that run-string
              if (err .ne. 0) then        !Was a string returned?
                  cmLn = 0                !No - clear the length return
              else
                  cmLn = min(TrimLen(cmCh),cmLn)
              endif
              if (cmLn.gt.0 .or. prams.ne.0) then
                  call tpCh('"_',RunName)
                  call tpFm('" has returned the following _')
                  if (cmLn .gt. 0) then
                      call tpFm('string:')
                      call tpFm('  '//cmCh(:cmLn))
                      if (prams.ne.0) call tpFm('and the following _')
                  endif
                  call tpFm('parameters (decimal):')
                  if (prams .ne. 0) then
                      do err = 1,5
                          call tpI2('  _',prams(err),6)
                      end do
                  endif
                  call tpFm(' -')         !Can't send all blanks to tpFm
              endif
              call HostMode               !Re-assert locks as needed
          endif
      endif
  
      return
      end
  
      subroutine SetDebug()                              ,<890525.1144>
     >Process SET DEBUG commands
      implicit none
  
      include kcmnds.ftni,NOLIST
      include kercmd.ftni,NOLIST
      include kercom.ftni,NOLIST
      include kerdbg.ftni,NOLIST
      integer*2 match,i,err,FmpOpen,FmpSetEof,DcbOpen
  
      call gettok('?')                    !Locate the next token
      i = match(debugs,dbtsiz)
      if (i .lt. 1) return                !Ignore bad parameter
  
      if (cmTk .eq. 'FILE') then
          dbLv = 0                        !Changing the file turns it off
          if (dbNm .ne. ' ') then
              call FmpClose(dbCb,err)
              dbNm = ' '
          endif
          call gettok(' ')                !Get the file-name pointers
          if (cmP1 .lt. 1) then           !None supplied?
              call tpFm('Usage: SET DEBUG FILE <file-name>')
              return
          endif
          dbNm = cmTk                     !Get the name
          if (FmpOpen(dbCb,err,dbNm,'wco',1) .lt. 0) then
              dbNm = ' '
              call ReportFileError(err,dbNm)   !(error on open - tell user)
          endif
          if (FmpSetEof(dbCb,err) .lt. 0) then   !Insure we can write
              call FmpClose(dbCb,err)
              dbNm = ' '
              call ReportFileError(err,dbNm)
          else
              call FmpRewind(dbCb,err)
              return
          endif
      endif
  
      if (DcbOpen(dbCb,err) .ne. 0) then  !Is debug file open?
          call tpFm('You need to SET DEBUG FILE <file-name> first')
      else if (cmTk .eq. 'ALL') then
          dbLv = ALL
      else if (cmTk .eq. 'STATES') then
          dbLv = STATES
      else if (cmTk .eq. 'PACKETS') then
          dbLv = PACKETS
      else if (cmTk .eq. 'OFF') then
          dbLv = 0
      endif
  
      return
      end
  
      subroutine SetDelay                                ,<890525.1144>
     >Process SET DELAY command
      implicit none
  
      include kercom.ftni,NOLIST
      integer*2 i
      logical*2 ctoi
  
      if (R .ne. L) then
          call tpFm('Set Delay is invalid in Local Host mode')
      else
          if (ctoi(i)) then
              if (i .lt. 0) then
                  call tpFm('Invalid delay value')
              else if (i .gt. 30) then
                  call tpFm('Value too big; using 30 seconds')
                  delay = 3000
              else
                  delay = i * 100
              endif
          else
              call tpFm('Usage: SET DELAY <value from 1 to 30>')
          endif
      endif
      return
      end
  
      subroutine SetEscape                               ,<890525.1144>
     >Process SET ESCAPE command
      implicit none
  
      include kercom.ftni,NOLIST
      integer*2 i
      logical*2 ctoi
  
      if (R .eq. L) then
          call tpFm('SET ESCAPE is invalid in Remote Host mode')
      else
          if (.not. ctoi(i)) then
              call tpFm('Usage: SET ESCAPE <control-character code>')
          else if (i.gt.0 .and. i.lt.32) then
              eschar = i
          else
              call tpFm('The escape must a control character')
          endif
      endif
  
      return
      end
  
      Logical*2 function SetLine()                       ,<890525.1144>
     >Process SET LINE command
      implicit none
  
      include kercom.ftni,NOLIST
      include kercmd.ftni,NOLIST
      include kercnf.ftni,NOLIST
      integer*2 rmtlu,lutru,p30val,p30add,idadd,user(3),lu,sylu
      character*6 cUser
      character*1 CmdSav
      integer*2 WhoLockedLu,bngdb
      logical*2 ctoi
      equivalence (cUser,user)
  
      CmdSav = CmTk                       !Save 1st command character
      SetLine = .false.                   !"abort" command on error condition
      call lurq(100000b)                  !Clear all locks
      if (.not. ctoi(rmtlu)) then         !Get the LU# parameter
          if (CmdSav .eq. 'C') then       !Called from CONNECT?
              call tpFm('Usage: CONNECT [<logical unit #>]')
          else
              call tpFm('Usage: SET LINE <logical unit #>')
          endif
          goto 10
      endif
  
      sylu = lutru(rmtlu)                 !Get the system LU equivalent
      if (sylu .lt. 1) then               !In user's session?
          call tpFm('That LU is not in your session')
          goto 10
      endif
  
      if (R .ne. L) then                  !If switching remote lu's...
          call control(R,2600b,1)
          call restore(R)                 !Restore old configuration
          call enable(R,fRmx)
          R = 0
      endif
  
      if (lutru(L) .ne. sylu) then
          R = rmtlu                       !Set new remote-LU
          call lurq(100001b,R,1)          !Try to lock it
          call abreg(idadd,lu)            !Get return status from lock
          if (idadd .ne. 0) then          !Were we successful?
              idadd = WhoLockedLu(sylu)   !No - find out who has it
              call IdAddToName(idadd,user,lu)
              call tpI2('LU _',R,0)
              call tpCh(' is locked to _',cUser,0)
              call tpI2('/_',lu,0)
              call tpFm(' ...Sorry Charlie')
              R = 0
              goto 10
          endif
          call GetMux(R,RemCnf)           !Get its configuration
          if (.not. fRmx) then            !Is the LU on a mux?
              call tpFm('That LU is not on a mux')
              R = 0
          else if (r30c .eq. 0) then      !Has the port been configured?
              call tpFm('That LU has never been configured')
              R = 0
          else
              call disable(R,fRmx)        !Kill remote interrupt-scheduling
              call KillEnqAck             !Disable ENQ/ACK as needed
              SetLine = .true.            !OK to continue a Connect...
          endif
      endif
  
 10   call HostMode
  
      return
      end
  
      subroutine SetParity                               ,<890525.1144>
     >Process SET PARITY command
      implicit none
  
      include kercom.ftni,NOLIST
      include kercmd.ftni,NOLIST
      include kcmnds.ftni,NOLIST
      include kercnf.ftni,NOLIST
      include kerfil.ftni,NOLIST          !To define fBnry
  
      integer*2 i,j,match,pmask,ixget,pvals(5,2)
      logical*2 MustBeLocal
      parameter (pmask = 36377b)          !Mask removes current parity bits
      equivalence (pvalu,pvals)
  
      if (.not. MustBeLocal() ) return    !Can't be remote
  
      call gettok('?')                    !Get the parity type requested
      i = match(parits,prtsiz)            !Do we recognize it?
      if (i .lt. 1) return
      Parity = i                          !Set B-quoting as needed
      r30c = r30c .and. pmask             !Get configuration w/o parity
      j = (iRmx .and. 1) + 1              !Set pvals index
      r30c = r30c .or. pvals(i,j)         !Plug in desired parity
      call control(R,3000b,r30c)          !Send it to the card
      call sleep(100)                     !Let the card catch up (?)
      call ShowParity                     !Show the changed parity
  
      if (parity.ne.3 .and. fBnry .and. .not.f8OK) then
          call tpFm('Can''t do binary transfers')
          fBnry = .false.
      endif
  
      return
      end
  
      subroutine SetPacket                               ,<890525.1144>
     >Process SET PACKET command
      implicit none
  
      include kercom.ftni,NOLIST
      integer*2 i
      logical*2 ctoi
  
      if (ctoi(i)) then
          if (i.gt.30 .and. i.lt.95) then
              PakSiz = i
          else
              call tpFm('Packet Size must be from 31 to 94')
          endif
      else
          call tpFm('Usage: SET PACKET <number from 31 to 94>')
      endif
  
      return
      end
  
      subroutine SetCheck                                ,<890525.1144>
     >Process SET CHECK command
      implicit none
  
      include kercom.ftni,NOLIST
      integer*2 i
      logical*2 ctoi
  
      if (ctoi(i)) then
          if (i.gt.0 .and. i.lt.4) then
              ChkTyp = i
          else
              call tpFm('Checksum type must be from 1 to 3')
          endif
      else
          call tpFm('Usage: SET CHECK <number from 1 to 3>')
      endif
  
      return
      end
  
      subroutine SetPrompt                               ,<890525.1144>
     >Process SET PROMPT command
      implicit none
  
      include kercmd.ftni,NOLIST
      include kercom.ftni,NOLIST
  
      call gettok('Kermit-RTE>')          !Set default
      if (cmP1 .ne. 0) then               !Was new prompt given?
          Prompt = cmRu(cmP1:cmP2)        !Yes - retrieve from original line
      else
          Prompt = CmTk                   !Else retrieve the default prompt
      endif
  
      return
  
      end
  
      subroutine SetQuote                                ,<890525.1144>
     >Process SET QUOTE command
      implicit none
  
      include kercom.ftni,NOLIST
      integer*2 i
      logical*2 ctoi
  
      if (ctoi(i)) then
          if (i.gt.32 .and. i.lt.127) then
              if (i .eq. Bit8) then
                  call tpFm('Invalid: conflicts with BQUOTE')
              else if (i .eq. Repc) then
                  call tpFm('Invalid: conflicts with REPEAT')
              else
                  Quote = i
              endif
          else
              call tpFm('Invalid: value must be from 33 to 126')
          endif
      else
          call tpFm('Usage: SET QUOTE <number from 33 to 126>')
      endif
  
      return
      end
  
      subroutine SetBQuote                               ,<890525.1144>
     >Process SET BQUOTE command
      implicit none
  
      include kercom.ftni,NOLIST
      include kerfil.ftni,NOLIST          !To define fBnry
      integer*2 i
      logical*2 ctoi
  
      if (ctoi(i)) then
          if ( (i.gt.31 .and. i.lt.63) .or.
     >         (i.gt.95 .and. i.lt.127) ) then
              if (i .eq. Quote) then
                  call tpFm(' Invalid: conflicts with QUOTE')
              else if (i .eq. Repc) then
                  call tpFm(' Invalid: conflicts with REPEAT')
              else
                  Bit8 = i
                  f8OK = Bit8 .ne. 32     !.true. if 8th-bit quote enabled
                  if (.not. f8OK) then    !Did they turn it on?
                      if (fBnry .and. Parity.ne.3) then  !Can we do binary?
                          fBnry = .false.
                          call tpFm('Can''t do binary transfers')
                      endif
                  endif
              endif
          else
              call tpFm('Invalid: value must be 32-62 or 96-126')
          endif
      else
          call tpFm('Usage: SET BQUOTE <value (32-62 or 96-126)>')
      endif
  
      return
      end
  
      subroutine SetRepeat                               ,<890525.1144>
     >Process SET REPEAT command
      implicit none
  
      include kercom.ftni,NOLIST
      integer*2 i
      logical*2 ctoi
  
      if (ctoi(i)) then
          if ( (i.gt.32 .and. i.lt.63) .or.
     >         (i.gt.95 .and. i.lt.127) ) then
              if (i .eq. Quote) then
                  call tpFm(' Invalid: conflicts with QUOTE')
              else if (i .eq. Bit8) then
                  call tpFm(' Invalid: conflicts with BQUOTE')
              else
                  Repc = i
              endif
          else
              call tpFm('Invalid: value must be 33-62 or 96-126')
          endif
      else
          call tpFm('Usage: SET REPEAT <value (33-62 or 96-126)>')
      endif
  
      return
      end
  
      subroutine SetRetry                                ,<890525.1144>
     >Process SET RETRY command
      implicit none
  
      include kercom.ftni,NOLIST
      include kercmd.ftni,NOLIST
      integer*2 i
      logical*2 ctoi,fInit
  
      if (ctoi(i)) then
          call GetTok(' ')                !Look for (I)nitial
          fInit = cmTk(1:1) .eq. 'I'
          if (i.lt.5 .or. i.gt.30) then
              call tpFm('Invalid: value must be from 5 to 30')
          else
              if ( fInit ) then
                  ImxTry = i
              else
                  maxtry = i
              endif
          endif
      else
          call tpFm('Usage: SET RETRY <number from 5 to 30> [I]')
      endif
  
      return
      end
  
      subroutine SetSync                                 ,<890525.1144>
     >Process SET SYNC command
      implicit none
  
      include kercom.ftni,NOLIST
      integer*2 i
      logical*2 ctoi
  
      if (ctoi(i)) then
          if (i.lt.1 .or. i.gt.31) then
              call tpFm('Invalid: value must be from 1 to 31')
          else if (i.eq.EOLch .or. i.eq.17) then
              call tpFm('Conflicts with EOL or IBM-PROMPT')
          else
              sync = i
          endif
      else
          call tpFm('Usage: SET SYNC <number from 1 to 31>')
      endif
  
      return
      end
  
      subroutine Skip2Bl(ptr)                            ,<890525.1144>
     >Skip to blanks in commands
      implicit none
  
c     This routine finds the first blank in cmCh past the current
c     PTR position (if any) and returns it in PTR.  If there are no
c     blank characters from PTR to the end of the string, PTR is
c     returned pointing to the end of the string + 1.
  
      include kercmd.ftni,NOLIST
      integer*2 ptr
  
      do while (ptr .le. cmLn)            !Stay in the string
          if (cmCh(ptr:ptr) .eq. ' ') then
              return
          else
              ptr = ptr + 1
          endif
      end do
  
      return
      end
  
      subroutine SkipBl(ptr)                             ,<890525.1144>
     >Skip blanks in commands
      implicit none
  
c     This routine finds the first non-blank in cmCh past the current
c     PTR position (if any) and returns it in PTR"  If there are no
c     non-blank characters from PTR to the end of the string, PTR is
c     returned unchanged.
  
      include kercmd.ftni,NOLIST
      integer*2 i,ptr
  
      i = ptr
      do while (i .le. cmLn)              !Stay in the string
          if (cmCh(i:i) .ne. ' ') then
              ptr = i
              return
          else
              i = i + 1
          endif
      end do
  
      return
      end
  
      subroutine tok_on_true(flag)                       ,<890525.1144>
     >Flag if next token = "ON"
      implicit none
  
c     This routine sets its parameter "true" if the next command-line
c     token is "ON"; or sets it "false" if that token is "OFF".  If
c     the token is neither of these, subroutine MATCH prints a message,
c     and this routine leaves its parameter alone.
  
      logical*2   flag
      character*3 on_off(2)
      integer*2   match,i
  
      data on_off/'OFF','ON'/
  
      call gettok('?')                    !Locate next token
      i = match(on_off,2)                 !Match it to "ON" or "OFF"
      if (i .eq. 1) then                  !If "OFF" matched...
          flag = .false.                  !...do the "off" thing
      else if (i .eq. 2) then             !If "ON" matched...
          flag = .true.                   !...do the "on" thing
      endif                               !Else do nothing
  
      return
      end
  
  
      subroutine SndFile(*)                              ,<890525.1144>
     >Send file(s)
      implicit none
  
      include kercmd.ftni,NOLIST          !defines cmTk
      include kercnf.ftni,NOLIST          !defines fRmx
      include kerfil.ftni,NOLIST          !defines mask, first, and fiNm
  
!     This routine was split into a command-processing section (this one)
!     and a packet-sending section (in the main) for revision 1.99.
  
      if (.not. fRmx) then                !Are transfers ok?
          call tpFm('You need to SET LINE first')
          return 1
      endif
  
      call gettok(' ')                    !Get the ind-file or mask
      if (cmTk .eq. ' ') then             !None given?
          call tpFm('Usage: SEND <file-descriptor>')
          return 1
      else
          mask = cmTk
      endif
  
      call gettok(' ')                    !Look for 2nd file name (initial)
      fiNm = cmTk
  
      first = .true.
      return
 
      end
  
      subroutine RecFile(*)                              ,<890525.1144>
     >Receive file(s)
      implicit none
  
      include kercmd.ftni,NOLIST          !Defines cmTk
      include kercnf.ftni,NOLIST          !Defines fRmx
      include kerfil.ftni,NOLIST          !Defines mask and first
  
!     This routine was split into a command-parsing section (this one) and
!     a packet-receiving section (in the 3rd segment) at revision 1.99.
 
      if (.not. fRmx) then                !OK to transfer files?
          call tpFm('You need to SET LINE first')
          return 1
      endif
  
      call gettok(' ')                    !Get the optional local name
      first = .true.
      mask = cmTk
      return
  
      end
  
      subroutine GetFile(*)                              ,<890525.1144>
     >Receive from a server
      implicit none
  
      include kercmd.ftni,NOLIST          !Defines cmTk
      include kerfil.ftni,NOLIST          !Defines GetMask, mask, and first
  
      call gettok(' ')                    !Get the (remote) file name
      if (cmTk .eq. ' ') then             !Was one given?
          call tpFm('Usage: GET <remote-name> [<local-name>]')
          return 1
      else
          GetMask = cmTk                  !Save the mask for the get
      endif
  
      call gettok(' ')                    !Get optional local file-name
      mask = cmTk
      first = .true.
      return
  
      end
  
      subroutine ServerInit(*)                           ,<890525.1144>
     >Start a KERMIT Server
      implicit none
  
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST          !Defines fRmx
  
      if (R .ne. L) then                  !If local host...
          call tpFm('Server not available in local-host mode')
          return 1
      else if (.not. fRmx) then
          call tpFm('You are not on a Mux LU')
          return 1
      else
          fServ = .true.
          call tpFm('[KERMIT Server running on an HP-1000 host.')
          call tpFm(' You must escape to your local machine now!]')
      endif
      return
  
      end
  
      logical*2 function MustBeLocal()                   ,<890525.1144>
     >Insure local-host mode
      implicit none
  
      include kercom.ftni,NOLIST
  
      MustBeLocal = .false.               !Assume we are in remote host
      if (R .eq. L) then                  !Are we remote?
          call tpFm('You need to Set Line to a mux port first!')
      else
          MustBeLocal = .true.
      endif
      return
  
      end
      program K2MSK(5)                                   ,<890525.1144>
     >KERMIT file-masking
      implicit none
  
      include kercom.ftni,NOLIST          !To define seg
  
      seg = 2                             !Keep the segment-loader happy
      call SegRt
  
      end
  
      Subroutine NextFile                                ,<890525.1144>
     >Get next file to send
      implicit none
  
!     The purpose of this routine is to supply an file, opened for reading,
!     to the packet-I/O handler in masked searches.  A simple file-name is
!     handled as if it was a mask, which doesn't bother the file-system at
!     all.  This routine is used only to find files to be sent.
  
      include kercom.ftni,NOLIST
      include kerfil.ftni,NOLIST
  
      integer*2 err,dntry(32),j
      integer*2 FmpInitMask,TrimLen,FmpOpen
      logical*2 FmpNextMask
      character*64 name1
      character*5 openopts
  
  
      if (first) then                     !Do 1st-entry stuff if needed
  
          ! On masked searches, 1st entry consists of initializing
          ! the search mask.  Note that, on error, Error will re-
          ! turn to the caller if we are a KERMIT server; otherwise,
          ! execution will continue in the command-processor.
          ! If the initial file-name was given, then we copy it to
          ! Name1 and delay clearing the First flag.
  
          call FmpEndMask(maCb)           !Be sure old mask is closed
          if (FmpInitMask(maCb,fiEr,mask,CurPath,372) .lt. 0)
     >        call ReportFileError(fiEr,mask)
          if (fiNm .ne. ' ') then         !Was an initial name given?
              name1 = fiNm                !Yes - save it
          else
              first = .false.             !else no initial-name search
          endif
  
      endif
  
      ! Normal processing on masked sends involves getting the next
      ! name, as above, but the file-system will tell us if there
      ! is anything else to find.  If an initial file-name was given
      ! we will attempt to match it here.
  
  10  fMore = FmpNextMask(maCb,fiEr,CurPath,dntry)
      fiNm = ' '
      if (fiEr .lt. 0) then               !On mask error...
          if (fiEr.ne.-208) then          !(except duplicate directory)
              call ReportFileError(fiEr,CurPath)
          else
              if (fMore) goto 10          !Get another name, if possible
              goto 20
          endif
      else
          if (fMore) then
              call FmpMaskName(maCb,fiNm,dntry,CurPath)
          else
              goto 20
          endif
      endif
  
      if (first) then                     !Doing initial-name search?
          j = TrimLen(name1)              !Use only as much as user gave
          if (name1 .eq. fiNm(:j)) then   !Now check: found it yet?
              first = .false.             !Yes - stop searching
          else
              goto 10                     !not found yet - keep searching
          endif
      endif
  
!     If we have a file, open it and return the name to the caller
  
 20   if (fiNm .ne. ' ') then
          if (fBnry) then
              openopts = 'rofx'
          else
              openopts = 'ro'
          endif
          if (FmpOpen(fiCb,fiEr,fiNm,openopts,1) .lt. 0) then
              call ReportFileError(fiEr,fiNm)
              fiNm = ' '
          else
              fiPt = 0                    !Force 1st record to be read
          endif
      endif
  
      return                              !Return to main
  
      end
      program K3XFR(5)                                   ,<890525.1144>
     >KERMIT file-transfer
      implicit none
  
      include kercom.ftni,NOLIST          !To define seg
  
      seg = 3
      call SegRt
  
      end
      subroutine bye                                     ,<890525.1144>
     >BYE command processor
      implicit none
  
      include kercom.ftni,NOLIST
      integer retry,err,num,len
      logical*2 fRtryi
      character*1 ptype,RecPack
  
c     This routine sends a generic-logout packet to a server running on
c     another system.  On success, we terminate gracefully.
  
      pdata = 'L'                         !Set data to L(ogout)
      retry = 0                           !Reset retry counter
  
 10   if ( fRtryi(retry) ) then           !Exceeded retry limit?
          call tpFm('Unable to send LOGOUT')
          return                          !Go back to command processor
      endif
  
      call SndPack('G',seq,1)             !Send the logout packet
      ptype = RecPack(len,num)            !Get the response
  
      if (ptype .eq. 'T') then            !time-out?
          call tpFm('<timed out>')
          goto 10
  
      else if (ptype .eq. 'N') then       !NAK?
          if (mod(seq+1,64) .ne. num) goto 10
          ptype = 'Y'
          num = num - 1
      endif
  
      if (ptype .eq. 'Y') then            !ACK?
          if (seq .ne. num) goto 10
          call quit                       !Shut ourselves down
          Stop
      else if (ptype .eq. 'X') then       !Checksum error?
          call tpFm('Checksum error; retrying')
      else if (ptype .eq. 'E') then       !Error packet?
          call tpCh('Received error packet: -',RecPkt(5:len+4),0)
          return
      else
          call tpCh('Unknown packet type: -',ptype,1)
      endif
      goto 10
  
      end
  
      subroutine finish                                  ,<890525.1144>
     >FINISH command processor
      implicit none
  
      include kercom.ftni,NOLIST
      integer*2 retry,err,len,num
      logical*2 fRtryi
      character*1 ptype,RecPack
  
      pdata = 'F'                         !Set data to F(inish)
      retry = 0
  
 10   if ( fRtryi(retry) ) then
          call tpFm('Unable to FINISH')
          return
      endif
  
      call SndPack('G',seq,1)             !Send the finish packet
      ptype = RecPack(len,num)
  
      if (ptype .eq. 'T') then            !time-out?
          call tpFm('<timed out>')
          goto 10
  
      else if (ptype .eq. 'N') then       !NAK?
          if (mod(seq+1,64) .ne. num) goto 10
          ptype = 'Y'
          num = num - 1
      endif
  
      if (ptype .eq. 'Y') then            !ACK?
          if (num .ne. seq) goto 10
          return
      else if (ptype .eq. 'X') then       !Checksum error?
          call tpFm('Checksum error - retrying')
      else if (ptype .eq. 'E') then       !Error packet?
          call tpFm('Received error packet:')
          call tpFm(RecPkt(5:len+4))
          return
      else
          call tpCh('Unknown packet type: -',ptype,1)
      endif
  
      goto 10
  
      end
  
      subroutine Logoff3                                 ,<890525.1144>
     >(LogOff caller)
      implicit none
  
      call LogOff                         !We never return...
      call exec(6)                        !(just in case)
  
      end
  
      logical*2 function receive(istate)                 ,<890525.1144>
     >Receive-state switch
      implicit none
  
c     This routine performs state switching for file-receive operations.
c     If file-recepetion is successful, receive returns .true.
 
      include kercom.ftni,NOLIST
      include kerdbg.ftni,NOLIST
      include kersta.ftni,NOLIST
      character*(*) istate
      integer*2 retry
      character*1 rdata,rinit,rfile
      character*3 c_r
  
      state = istate                      !Show receiving state
      call startstats                     !restart statistics logging
      retry = 0
      c_r = char(13) // ' _'
      receive = .false.
  
 10   call kdebug(states,'RxState: ',state)
      if (retry .ne. 0) rtry = rtry + 1
      if (R .ne. L) then
          call tpI2(c_r,rpak,6)
          call tpI2('/_',rtry,-3)
          call tpFm(' _-')
      endif
  
      if (state .eq. 'D') then            !read a DATA packet
          state = rdata(retry)
      else if (state .eq. 'R') then       !read a SINIT packet
          state = rinit(retry)
      else if (state .eq. 'F') then       !read a file header
          state = rfile(retry)
      else if (state .eq. 'C') then       !file transfer complete?
          call endstats                   !turn off statistics logging
          sCheck = 1                      !Revert to type-1 checksums
          receive = .true.
          return
      else if (state .eq. 'E') then       !We received an error packet
          call endstats
          call fClose
          if (.not. fServ) call tpFm(ErrMsg)
          return
      else if (state .eq. '!') then       !we got an error
          call endstats
          call fClose
          call SndErr
          return
      else                                !Unknown receive state
          call endstats
          call fClose
          ErrMsg = 'Receive-state error; state = ' // state
          call kdebug(states,ErrMsg,' ')
          if (R .ne. L) then
              call tpFm(ErrMsg)
          endif
          call SndErr
          return
      endif
  
      goto 10
 
      end
  
      character*1 function rinit(retry)                  ,<890525.1144>
     >Receive initial packet
      implicit none
  
      include kercom.ftni,NOLIST
      include kerfil.ftni,NOLIST          !To define fBnry
      integer*2 retry,len,num,svCheck
      logical*2 fRtryi
      character*1 ptype,recpack
  
      rinit = state                       !Assume no state change
 
      if ( fRtryi(retry) ) then
          rinit = '!'                     !exceeded max. # of re-try
          return                          !give up
      endif
  
      ptype = recpack(len,num)            !read a packet
      if (ptype .eq. 'S') then            !we got a SINIT packet
          call RecPar(len)                !store partner's params
          if (fBnry .and. Parity.ne.3 .and. .not.fBit8) then
              ErrMsg = 'Can''t receive binary file (parity problem)'
              call SndErr
              fBnry = .false.
              rinit = 'E'
              return
          endif
          call SndPar('Y',num)            !Send my parameters now
          sCheck = newChk                 !OK to change check type now
          seq = mod(num+1,64)             !Set new sequence number
          retry = 0                       !Clear the retry counter
          rinit = 'F'                     !New state = File header
      else if (ptype .eq. 'X') then       !we got a checksum error
          call SndPack('N',num,0)         !NAK the packet
      else if (ptype .eq. 'T') then       !Timed out?
          call SndPack('N',seq,0)         !just nak it
      else if (ptype .eq. 'E') then       !Error packet?
          ErrMsg = 'Sender error: ' // RecPkt(5:len+4)
          rinit = 'E'
      else
          ErrMsg = 'Unknown packet type: ' // ptype
          rinit = '!'                     !Unexpected packet, so give up
      endif
  
      return
      end
  
      character*1 function rfile(retry)                  ,<890525.1144>
     >Read file-header packet
      implicit none
  
      include kercom.ftni,NOLIST
      include kerfil.ftni,NOLIST
      integer*2 retry,num,len,FmpOpen,TrimLen,err,typ
      logical*2 fRetry
      character*1 recpack,ptype
      character*5 openopts
  
      if ( fRetry(retry) ) then
          rfile = '!'
          return
      endif
  
      rfile = state
      ptype = RecPack(len,num)            !Read a packet
      if (ptype .eq. 'F') then            !we got a file-header
          if (num .ne. seq) then          !If the sequence# is bad...
              ErrMsg = 'Bad sequence number'
              rfile = '!'                 !...abort
              return
          endif
          pdata = RecPkt(5:len+4)         !copy off the file-name info...
          call legalize(typ)              !...validate & move it to fiNm
          openopts = 'wc'                 !min open options: write & create
          if (.not. fWarn) then           !If files can be overlayed...
              call chApp(openopts,'o')    !allow (O)ld files
          endif
          if (fBnry) then                 !If in binary mode...
              call chApp(openopts,'f')    !...(F)orce to type 1
              if (typ .ne. 6) then        !if not an rp-able program...
                  call chApp(openopts,'x')!...allow e(X)tent access
              endif
          endif
          if (FmpOpen(fiCb,err,fiNm,openopts,1) .lt. 0) then
              Call ReportFileError(err,fiNm)
          else
              fiCh = ' '                  !Clear the record buffer
              fiPt = 0                    !Set record pointer
              call SndPack('Y',num,0)
              seq = mod(seq+1,64)
              rfile = 'D'                 !Switch to data state
              if (R.ne.L) then            !Display the file name locally
                  call tpCh('Receiving -',fiNm,TrimLen(fiNm))
              endif
              retry = 0
          endif
  
      else if (ptype .eq. 'S') then       !Old send-init packet?
          if (mod(num+1,64) .eq. seq) then
              call SndPar('Y',num)        !Yes - send my parameters
              retry = 0
          else
              ErrMsg = 'Bad sequence# on old SINIT'
              rfile = '!'
          endif
  
      else if (ptype .eq. 'Z') then       !Old EOF packet?
          if (mod(num+1,64) .eq. seq) then
              call SndPack('Y',num,0)     !Yes - just ack it
              retry = 0
          else
              ErrMsg = 'Bad sequence# on old EOF'
              rfile = '!'
          endif
  
      else if (ptype .eq. 'B') then       !Break packet?
          if (num .ne. seq) then
              ErrMsg = 'Bad sequence# on BREAK'
              rfile = '!'
          else
              call SndPack('Y',num,0)
              rfile = 'C'                 !Change state to Complete
              retry = 0
          endif
  
      else if (ptype .eq. 'X') then       !Checksum error?
          call SndPack('N',num,0)
  
      else if (ptype .eq. 'T') then       !Time-out?
          call SndPack('N',seq,0)         !just NAK it
  
      else if (ptype .eq. 'E') then       !Error packet?
          ErrMsg = 'Sender error: ' // RecPkt(5:len+4)
          rfile = 'E'
  
      else                                !Invalid packet type
          ErrMsg = 'Unknown packet type: ' // ptype
          rfile = '!'
      endif
  
      return
      end
  
      subroutine chApp(dest,newstuff)                    ,<890525.1144>
     >Append to string
      implicit none
  
      character*(*) dest,newstuff
      integer*2 TrimLen,i
  
      i = TrimLen(dest) + 1           !Find 1st available character
      if (i .le. Len(dest)) dest(i:) = newstuff
  
      return
      end
  
      character*1 function rdata(retry)                  ,<890525.1144>
     >Receive data packet
      implicit none
  
      include kercom.ftni,NOLIST
      integer*2 retry,num,len
      logical*2 fRetry
      character*1 ptype,recpack
  
      rdata = state                       !Assume no change in state
      if ( fRetry(retry) ) then
          rdata = '!'
          return
      endif
  
      ptype = recpack(len,num)            !read a packet
  
      if (ptype .eq. 'D') then            !we got the data packet
          if (num .ne. seq) then          !Sequence error?
              if (mod(num+1,64).eq.seq) then   !Was prev packet re-sent?
                  call SndPack('Y',num,0)      !Yes - just ack it
                  retry = 0
              else
                  ErrMsg = 'Bad Sequence#'
                  rdata = '!'
              endif
          else
              call BufEmp(len)            !Sequence # ok - copy to disc
              call SndPack('Y',num,0)     !Ack the packet
              seq = mod(num+1,64)         !Bump the sequence number
              retry = 0                   !Show no more retries
          endif
  
      else if (ptype .eq. 'F') then       !Old filename packet?
          if (mod(num+1,64).eq.seq) then  !Yes - sequence# ok?
              call SndPack('Y',num,0)     !Yes - ack it
              retry = 0                   !Show no retries
          else
              ErrMsg = 'Bad Sequence#'
              rdata = '!'
          endif
  
      else if (ptype .eq. 'Z') then       !EOF packet?
          if (num .ne. seq) then          !Yes - sequence# ok?
              rdata = '!'                 !No - abort the transfer
          else
              call SndPack('Y',num,0)     !Yes - ACK it
              call dputc(-2)              !Post poss pending buffer to file
              rdata = 'F'                 !Look for another file-header
              seq = mod(num+1,64)         !Set next sequence number
              retry = 0
          endif
          call fClose
  
      else if (ptype .eq. 'X') then       !Checksum error?
          call SndPack('N',num,0)         !NAK the packet
  
      else if (ptype .eq. 'T') then       !time-out?
          call SndPack('N',seq,0)
  
      else if (ptype .eq. 'E') then       !Error packet?
          ErrMsg = 'Sender error: ' // RecPkt(5:len+4)
          rdata = 'E'
  
      else                                !Unknown packet type?
          ErrMsg = 'Unknown packet type: ' // ptype
          rdata = '!'                     !Abort the transfer
      endif
  
      return
      end
  
      subroutine legalize(typ)                           ,<890525.1144>
     >Insure valid file names
      implicit none
  
c     This routine is called for any received file to insure that its name
c     is valid in this system.  Name validity has two main components:
c         * No illegal characters
c         * Correct specification of directory path
c     Once validity is insured, this routine copies that name to fiNm, the
c     global used for files' names in KERMIT-RTE.
c
c     The first issue is addressed by editing the file name so that any
c     occurrences of "+", "-", ",", or "@" are changed to an underscore.
c     If the first character is numeric, it also is replaced by an under-
c     score, as are any embedded blanks in the name.  RTE system can only
c     use a period to separate file-names from the type-extension, if the
c     other system uses something else, this system won't understand but
c     won't change it unless it violates one of the rules above.  "/" and
c     ":" are used in different contexts to describe directory paths in
c     this system; if they appear in the name sent from the other system,
c     they and their associated information will be removed!
c
c     This routine causes the file to be put into the current working-
c     directory, or into the directory given by the first parameter of
c     a RECEIVE command or the second parameter of the GET command.  If
c     there is no active working-directory and no directory was given
c     by the RECEIVE or GET command, the file will be put in FMGR-space,
c     and the file-name will be truncated to the left-most 6 characters.
c
c     NOTE: if a full file name is given in GET or RECEIVE, that name is
c     used for the first file received only; any other files received in
c     the same stream can be renamed in all parts BUT the file name.
  
      include kercom.ftni,NOLIST
      include kerfil.ftni,NOLIST
      integer*2   ij,sc,typ,rl,i,TrimLen
      character   name*16,typx*4,rtpx*4,ds*40,junk*1
 
      if (first) then                     !First time after GET or RECEIVE?
          ds = ' '                        !Clear the DS-information string
          rtpx = ' '                      !...and the (mask) type-extendion
          first = .false.                 !Don't do this again
          if (mask .ne. ' ') then         !If a name was given...
              fiNm = mask                 !Is it a name and/or a mask?
              call FmpParsePath(fiNm,mask,name,rtpx,junk,sc,typ,fiSz,
     >                          rl,ds)    !NOTE: qualifier is illegal here
                                          !      but DS-stuff is not!
              call checkname(rtpx)        !Validate the type-extension
              if (name .ne. ' ') then          !If anything is left...
                  if (rtpx .ne. ' ') then      !do we also have type-ext?
                      i = TrimLen(name)
                      pdata = name(:i) // '.' // rtpx
                  else
                      pdata = name
                  endif
              endif
          endif
          if (typ .lt. 1) typ = 4         !Default to var-length/editable
          if (fiSz.lt. 1) fiSz = 24       !...and 24 blocks
          if (rl .lt. 0) rl = 0
      endif
  
c     Directory-, qualifier-, or DS-info will never be sent from another
c     KERMIT, but I parse for them in the following call (the "JUNK" in
c     3 places) so that I won't be fooled by something that looks like
c     that kind of stuff.  Further, the security-code, file-type, -size,
c     and -record-length fields are also dummies ("IJ" in 4 places).
  
      call FmpParsePath(pdata,junk,name,typx,junk,ij,ij,ij,ij,junk)
  
      call CheckName(name)                !Replace illegals in the name
      if (rtpx .ne. ' ') then             !Replace type-extension?
          typx = rtpx                     !Yes - do it
      else
          call CheckName(typx)            !Replace illegals in type-extension
      endif
  
c     Now reconstruct the name.  If anything beyond a file-name was given in
c     a GET or RECEIVE command, it was parsed above; it will now be used
c     here to build a full file-name.
  
      call FmpBuildPath(fiNm,mask,name,typx,' ',sc,typ,fiSz,rl,ds)
  
      return
      end
  
      subroutine CheckName(name)                         ,<890525.1144>
     >Make file-name info legal
      implicit none
  
      character*(*) name
      integer*2     i,TrimLen
      character*1   b
  
c     This routine checks file-name and -extensions to insure that all
c     occurrences of '+', '-', ',', '@', leading numeric characters, and
c     embedded blanks or control-characters are replaced by '!'.
  
      do i = 1,TrimLen(name)              !Scan the file name
          b = name(i:i)                   !Extract a character
          if (i .eq. 1) then              !Check for numeric 1st character
              if (b.ge.'0' .and. b.le.'9') then
                  b = '!'
              endif
          else if (b .eq. '+') then
              b = '!'
          else if (b .eq. '-') then
              b = '!'
          else if (b .eq. '@') then
              b = '!'
          else if (b .eq. ',') then
              b = '!'
          else if (b .le. ' ') then
              b = '!'
          endif
          name(i:i) = b                   !Replace (possibly) changed byte
      end do
  
      return
      end
  
      character*1 function sinit(retry)                  ,<890525.1144>
     >Send initial packet
      implicit none
  
      include kercom.ftni,NOLIST
      include kerfil.ftni,NOLIST
      integer*2 retry,num,len,FmpOpen,err
      logical*2 fRtryi
      character*1 ptype,RecPack
      character*4 openopts
  
      if ( fRtryi(retry) ) then           !Retry limit exceeded?
          sinit = '!'                     !Yes - abort the send
          call SendAbort                  !Close all associated files
          return
      endif
  
      sCheck = 1                          !SINIT always uses 1-byte checks
      call SndPar('S',seq)                !Send my parameters
      ptype = RecPack(len,num)            !Get the response
      sinit = state                       !Assume no change in state
  
      if (ptype .eq. 'N') then            !NAK?
          return                          !Yes - try again
      else if (ptype .eq. 'T') then       !Time-out?
          return                          !try again
  
      else if (ptype .eq. 'E') then       !Error packet?
          ErrMsg = 'Receiver error: ' // RecPkt(5:len+4)
          sinit = 'E'
          call SendAbort
          return
  
      else if (ptype .eq. 'Y') then       !ACK?
          if (seq .ne. num) then          !Yes - for this packet?
              return                      !No - try again
          endif
          call RecPar(len)                !Get partner's parameters
          sCheck = NewChk                 !Ok to do new checksum type now
          if (fBnry .and. Parity.ne.3 .and. .not.fBit8) then
              ErrMsg = 'Can''t send binary file (parity problem)'
              fBnry = .false.
              sinit = 'E'
              call SendAbort
              return
          endif
          retry = 0                       !Clear the retry counter
          seq = mod(seq+1,64)             !Get next sequence number
          if (fBnry) then
              openopts = 'rofx'
          else
              openopts = 'ro'
          endif
          if (FmpOpen(fiCb,err,fiNm,openopts,1).lt.1) then
              call ReportFileError(err,fiNm)
          else
              fiPt = 0                    !Force a record to be read
              sinit = 'F'                 !Go to File-name state
          endif
  
      else if (ptype .ne. 'X') then       !Any response except checksum err?
          ErrMsg = 'Unknown packet type: ' // ptype
          sinit = '!'                     !Yes - abort the send
          call SendAbort
      endif
  
      return
      end
  
      character*1 function sfile(retry)                  ,<890525.1144>
     >Send file-name packet
      implicit none
  
      include kercom.ftni,NOLIST
      include kerfil.ftni,NOLIST
      integer*2 retry,len,num,TrimLen,j
      logical*2 fRetry
      character*1 ptype,RecPack
      character name*16,typex*4,cj*1
  
      if ( fRetry(retry) ) then           !Exceeded retry limit?
          sfile = '!'                     !Yes - abort the transfer
          call SendAbort                  !Close all files
          return
      endif
  
c     Get the "normal form" of the file-name.  The "J" and "CJ" variables
c     are "junk" (unused fields) from the parse.
  
      call FmpParsePath(fiNm,cj,name,typex,cj,j,j,j,j,cj)
      j = TrimLen(name)
      if (typex .ne. ' ') then            !Was a type-extension given?
          pdata = name(:j) // '.' // typex
      else
          pdata = name
      endif
      call SndPack('F',seq,TrimLen(pdata))  !Send the file name
      ptype = RecPack(len,num)            !Get the response
      sfile = state                       !Assume no change in state
  
      if (ptype .eq. 'T') then            !Time-out?
          return                          !just retry
  
      else if (ptype .eq. 'E') then       !Error packet?
          ErrMsg = 'Receiver error: ' // RecPkt(5:len+4)
          sfile = 'E'
          call SendAbort
          return
 
      else if (ptype .eq. 'N') then       !NAK or time-out?
          if (mod(seq+1,64) .ne. num) then
              return
          else
              ptype = 'Y'
              num = num - 1
          endif
      endif
  
      if (ptype .eq. 'Y') then            !ACK?
          if (seq .ne. num) then
              return
          endif
          retry = 0
          seq = mod(seq+1,64)             !Get next sequence number
          sfile = 'D'                     !Go to the data state
          if (R.ne.L) then                !Display the file name locally
              call tpCh('Sending -',fiNm,TrimLen(fiNm))
          endif
          call buffill                    !Get first data packet's worth
  
      else if (ptype .ne. 'X') then       !Anything else but checksum err...
          ErrMsg = 'Unknown packet type: ' // ptype
          sfile = '!'                     !...makes us abort the send
          call SendAbort
      endif
  
      return
      end
  
      character*1 function sdata(retry)                  ,<890525.1144>
     >Send file-data packets
      implicit none
  
      include kercom.ftni,NOLIST
      integer*2 retry,len,num,buffill
      logical*2 fRetry
      character*1 ptype,RecPack
  
      if ( fRetry(retry) ) then           !Exceeded retry limit?
          sdata = '!'                     !Yes - give up
          call SendAbort
          return
      endif
  
      sdata = state                       !Assume no change in state
      call SndPack('D',seq,slen)          !Send the data packet
  
      ptype = RecPack(len,num)            !Get the reply
  
      if (ptype .eq. 'T') then            !Time-out?
          return                          !Just retry
  
      else if (ptype .eq. 'E') then       !Error packet?
          ErrMsg = 'Receiver error: ' // RecPkt(5:len+4)
          sdata = 'E'
          call SendAbort
          return
  
      else if (ptype .eq. 'N') then       !Got a NAK?
          if (mod(seq+1,64) .eq. num) then
              return
          else
              ptype = 'Y'                 !A NAK on the 'next' packet is
              num = num - 1               !...an ACK on this one
          endif
      endif
  
      if (ptype .eq. 'Y') then            !Got an ACK?
          if (seq .ne. num) return
          retry = 0
          seq = mod(seq+1,64)
          if (buffill() .lt. 1) then      !Did we get EOF?
              sdata = 'Z'                 !Yes - change state
          endif
  
      else if (ptype .ne. 'X') then       !Something besides checksum?
          ErrMsg = 'Unknown packet type: ' // ptype
          sdata = '!'                     !Abort the transfer
          call SendAbort
      endif
  
      return
      end
  
      character*1 function sbreak(retry)                 ,<890525.1144>
     >Send EOT packet
      implicit none
  
      include kercom.ftni,NOLIST
      integer*2 retry,len,num
      logical*2 fRetry
      character*1 ptype,RecPack
  
      if ( fRetry(retry) ) then           !Did we exceed the retry limit
          sbreak = '!'                    !Yes - abort the transfer
          call SendAbort
          return
      endif
  
      sbreak = state                      !Assume no state change
      call SndPack('B',seq,0)
      ptype = RecPack(len,num)
  
      if (ptype .eq. 'T') then            !timed out?
          return                          !just retry
  
      else if (ptype .eq. 'E') then       !Error packet?
          ErrMsg = 'Receiver error: ' // RecPkt(5:len+4)
          sbreak = 'E'
          call SendAbort
          return
  
      else if (ptype .eq. 'N') then       !Were we NAKed?
          if (mod(seq+1,64).ne.num) then  !Yes - is it an old NAK?
              return                      !No - do another break
          else
              ptype = 'Y'
              num = num - 1
          endif
      endif
  
      if (ptype .eq. 'Y') then            !Were we ACKed?
          if (num .ne. seq) then          !Yes - in sequence?
              return                      !No - do the break again
          endif
          retry = 0
          seq = mod(seq+1,64)
          sbreak = 'C'                    !Change to Complete status
  
      else if (ptype .ne. 'X') then       !Anything else but checksum?
          ErrMsg = 'Unknown packet type: ' // ptype
          sbreak = '!'                    !Yes - abort the send
          call SendAbort
      endif
  
      return
      end
  
      integer*2 function buffill()                       ,<890525.1144>
     >Fill transmit buffer
      implicit none
  
c     This routine copies data from the sending disc file to the data
c     portion of the transmit packet.  It is responsible for assuring
c     that control, 8th-bit, and repeat-count prefixing sequences are
c     not broken across a packet boundary.
  
      include kercom.ftni,NOLIST
      integer*2 i,j,b,dgetc,ctl,psave,DataMax,TrimLen,xbufL
      character*20 xBuf                   !"excess" buffer
      data xBuf /' '/                     !(SegLd always clears this)
  
      p = 1                               !Reset packet byte pointer
      DataMax = sPkSiz - (sCheck+1)       !(This is last available byte + 1)
      if (xBuf .ne. ' ') then             !Anything in the overflow buffer?
          pData = xBuf                    !Yes - put it in front of packet
          p = xBufL + 1                   !...and reset pointer to end of it
          xBuf = ' '                      !(show overflow buffer is clear)
      endif
      do while (dgetc(b) .ge. 0)          !Read from disc 'til EOF
  
          psave = p                       !In case of buffer overflow
          if (fRepc) then                 !Can we do repeat-counts?
              i = 1                       !Yes - find non-match/too many
              do while (dgetc(j).eq.b .and. i.lt.94)
                  i = i + 1               !Max repeat-count is 94
              end do
              call dPutBack(j)            !Put back the non-match
              if (i .lt. 4) then          !Below the repeat threshold?
                  do while (i .gt. 1)     !Yes - put 'em all back
                      call dPutBack(b)
                      i = i - 1
                  end do
              else
                  call pPutc(sRepc)       !Yes - plug in the prefix
                  call pPutc(i + 32)      !Make the count printable
              endif
          endif
  
          if (fBit8 .and. b.gt.127) then  !Do 8th-bit prefixing?
              call pPutc(sBit8)           !Yes - output the prefix
              b = iand(b,127)             !...then clear 8th bit
          endif
 
          if (b.lt.32 .or. b.eq.127 .or. b.eq.sQUOTE .or.
     >                      (b.eq.sBit8 .and. fBit8) .or.
     >                      (b.eq.sRepc .and. fRepc)      ) then
              call pPutc(sQUOTE)          !We need to quote a character
              if (b.lt.32 .or. b.eq.127) b = ctl(b)
          endif
          call pPutc(b)
  
          if (p .eq. DataMax) then        !Packet exactly filled?
              goto 10
          elseif (p .gt. DataMax) then    !Packet too full?
              xBuf = pData(psave:p)       !Save part that doesn't fit
              xbufL = p - psave           !Save length of the overflow
              p = psave                   !Back up to last char that fits
              goto 10                     !Done with this packet
          endif
      end do
  
c     Falling thru to here means we hit EOF in the disc file, or the packet
c     is full.  If at EOF and this routine is called again, it will return
c     zero, and SDATA will know to go to EOF state.
  
 10   slen = p - 1
      buffill = slen
  
      return
      end
  
      integer*2 function dGetc(b)                        ,<890525.1144>
     >Get a disc-file byte
      implicit none
  
c     The RTE file-system doesn't readily accept the notion that a file
c     could be a "stream" of bytes.  This subroutine fills that gap by
c     doing record unpacking and a limited "push-back" facility.
  
      include kercom.ftni,NOLIST
      include kerfil.ftni,NOLIST
      include kerdbg.ftni,NOLIST
  
      integer*2 dPutBack,b,pbbyt
      logical*2 EORpend
      integer*2 pbpt,err,fiBf(128)
      integer*2 FmpRead
      character pbbf*20                   !Push-back buffer
      equivalence (fiCh,fiBf)
      data pbpt /0/                       !if > 0, is a push-back pointer
      data EORpend /.false./              !EOR sequence is not pending
  
      if (pbpt .gt. 0) then               !Was a byte pushed back?
          b = ichar(pbbf(pbpt:pbpt))      !Yes - get it
          pbpt = pbpt - 1                 !Back up the push-back pointer
          goto 20
      endif
  
      if (EORpend) then                   !Doing 2nd byte of EOR sequence?
          EORpend = .false.               !Not any more
          b = 10                          !Return the LF character
          goto 20
      endif
  
 10   if (fiPt .lt. 1) then               !Need to read a record?
          fiLn = FmpRead(fiCb,err,fiBf,MAXREC)   !Yes - do it
          if (err .lt. 0) then                   !File-read error?
              if (fBnry .and. err.eq.-12) then   !EOF during binary mode?
                  fiLn = -1                      !Yes - show EOF
              else
                  call ReportFileError(err,fiNm) !Else report other errors
              endif
          endif
          fiPt = 1                               !Point to 1st byte
      endif
  
      if (fiLn .lt. 0) then               !EOF? (always returns -1)
          b = -1                          !NOTE: EOF can't be pushed back!
          goto 20
      endif
  
      if (fiPt .gt. fiLn) then            !EOR?
          fiPt = 0                        !Yes - Arrange to get next record
          if (fBnry) goto 10              !Don't map EOR to CRLF if binary
          b = 13                          !Else flag with a CR
          EORpend = .true.                !Be sure to do 2nd byte of EOR
      else
          b = ichar( fiCh(fiPt:fiPt) )    !Get the current byte
          fiPt = fiPt + 1                 !Point to next byte
      endif
  
 20   dGetc = b                           !Return byte as function value
      return
  
      entry dPutBack(pbbyt)
  
      if (pbpt .ge. 20) then              !Too many pushed back?
          ErrMsg = 'Too many bytes pushed back!'
          call kDebug(all,ErrMsg,' ')
          call SndErr
          call quit
      else if (pbbyt .ge. 0) then         !(Don't push EOF back!)
          pbpt = pbpt + 1                 !Bump the pointer
          pbbf(pbpt:pbpt) = char(pbbyt)   !"push back" the byte
      endif
  
      return
      end
  
      subroutine BufEmp(len)                             ,<890525.1144>
     >Empty receive-buffer
      implicit none
  
c     This routine writes the packet buffer contents to the receiving
c     disc file.  Note that the "LEN" parameter is actually a pointer
c     to the last data-byte in the packet (type-2/-3 checksums???)
  
      include kercom.ftni,NOLIST
  
      integer*2 ctl,i,len,b
      logical*2 f8Set
      integer*2 rep,j
  
      i = 5                               !1st data byte is packet byte #5
      do while (i .le. len+4)             !put (len) bytes in disc file
          b = ichar(R1cPkt(i))            !Get next packet byte
  
          if (fRepc .and. b.eq.Repc) then !Is this my repeat-count char?
              i = i + 1                   !Yes - bump to the count itself
              rep = ichar(R1cPkt(i))-32   !Get the count
              i = i + 1                   !position to next byte
              b = ichar(R1cPkt(i))        !Get character to repeat
          else
              rep = 1                     !Default repeat-count to 1
          endif
  
          if (fBit8 .and. b.eq.Bit8) then !Do 8th-bit prefixing?
              f8Set = .true.              !Yes - set the bit-8 flag
              i = i + 1                   !...and bump the byte pointer
              b = ichar(R1cPkt(i))
          else
              f8Set = .false.
          endif
  
          if (b .eq. Quote) then          !If this is my quote character
              i = i + 1                   !...bump the byte pointer
              b = ichar(R1cPkt(i))        !...and get the next byte
              if (b.ge.63 .and. b.le.95) then  !if in range...
                  b = ctl(b)              !...de-controllify it (else it is
              endif                       !sent literally after a quote)
          endif
  
          if (f8Set) b = ior(b,200b)      !Turn on 8th bit as needed
  
          do j = 1,rep                    !Repeat-count processing
              call dPutc(b)               !Put the byte in the file
          end do
          i = i + 1
      end do
      return
      end
  
      subroutine dPutc(b)                                ,<890525.1144>
     >Write byte in file-buffer
      implicit none
  
      include kerfil.ftni,NOLIST
  
      integer*2 b,err,fiBf(129)
      logical*2 CRpend                    !True if CR is pending
      logical*2 fEmpty                    !True if file-buffer is empty
      equivalence (fiCh,fiBf)
      data CRpend /.false./
  
c     This routine is called with a single INTEGER parameter (b) being the
c     ichar() of the byte to store into the record, except:
c         b = -2: post the current (non-empty) record
c         b = -1: post the current record, empty or not
c     If b is any other negative number, it is not written to the file.
  
      if (b.eq.-2 .and. fEmpty) return    !This was an un-needed post call
      fEmpty = .false.
  
      if (fBnry) goto 10                  !Don't map CRLF to EOR if binary
  
      if (CRpend) then                    !Is a CR pending?
          CRpend = .false.                !Yes - not after this stuff
          if (b.eq.10 .or. b.lt.0) then   !Is this the logical EOR?
              b = -1                      !Yes - flag it
          else
              fiPt = fiPt + 1             !Not EOR, so store the CR
              fiCh(fiPt:fiPt) = char(13)  !...into the file
          endif
      endif
  
      if (b .eq. 13) then                 !Is this a CR?
          CRpend = .true.                 !Yes - flag it for next call
          return                          !Don't write it to the file (yet)
      endif
 
!     Do end-of-record (EOR) processing if requested (b=-1) or if the
!     record-buffer gets "full".
  
 10   if (fiPt.ge.MAXREC .or.  b.lt.0) then
          call FmpWrite(fiCb,err,fiBf,fiPt)
          if (err .lt. 0) then
              call ReportFileError(err,fiNm)
          endif
          fiCh = ' '                      !Clear the record buffer
          fiPt = 0                        !Reset char pointer
          fEmpty = .true.                 !"buffer is empty"
      endif
  
      if (b .ge. 0) then                  !Add this byte to the record?
          fiPt = fiPt + 1                 !Yes - bump the pointer
          fiCh(fiPt:fiPt) = char(b)       !...and add the byte
      endif
  
      return
      end
  
      logical*2 function fRetry(try)                     ,<890525.1144>
     >OK to retry?
      implicit none
  
      include kercom.ftni,NOLIST
      integer*2 try,tmax
      logical*2 IfBrk,fInit,tf
      logical*2 fRtryI                    !Alternate entry for initial retry
  
      tmax = MaxTry                       !Set for "normal" retry-limit
      fInit = .false.                     !Not doing initial retry limiting
      goto 10
  
      entry fRtryi(try)
      tmax = ImxTry                       !Set for initial retry limit
      fInit = .true.                      !Doing initial retry-limiting
  
 10   tf = .true.                         !Intialize to 'not ok to retry'
      if (try .gt. tMax) then
          ErrMsg = 'Retry limit exceeded'
          if (R .ne. L) call tpFm(ErrMsg)
      else
          try = try + 1
          tf = .false.
      endif
  
      If (IfBrk()) then                   !Operator break?
          tf = .true.
          ErrMsg = 'Operator break'
          if (R .ne. L) call tpFm(ErrMsg)
      endif
  
      if ( fInit ) then                   !Doing Initial or normal?
          fRtryi = tf
      else
          fRetry = tf
      endif
  
      return
      end
  
      character*1 function RecPack(len,num)              ,<890525.1144>
     >Read a packet
      implicit none
 
      include kercom.ftni,NOLIST
      include kerdbg.ftni,NOLIST
      include kersta.ftni,NOLIST
  
      integer*2 len,num
      integer*2 unchar,getpak
      integer*2 RecBuf,i,b,ck,type,numw1(3),numw2(3),check1
      character num1*2,num2*2,work*10,rpinfo*256
      equivalence (RecBuf,RecPkt),(num1,numw1(3)),(num2,numw2(3))
  
c     By definition, anything I read in will terminate with EOLch (a
c     carriage-return), so all I need to do is left-justify the SYNC
c     portion in the packet-buffer.  Packet input is always from the
c     REMOTE lu.  The rest of the routine "parses" the packet into
c     fields by setting appropriate variables.
c     RECPACK returns the packet-type as its value, or a 'bad-packet'
c     indicator if the checksum is bad.  The data length is returned
c     in LEN, and the sequence number is returned in NUM.
  
c     NOTE: it is assumed that type-ahead has been enabled prior to
c           calling this routine.  RTE's internal I/O processing
c           makes "true" full-duplex impossible (see the code in
c           CONNECT for proof of this); type-ahead on the mux card
c           at least allows us to capture data sent to us before we
c           are actually ready to receive it.  (While testing KERMIT
c           with two computers of different execution speed, data
c           losses DID occur because of the time needed to do stuff
c           between the sending of a packet and receipt of the ACK
c           or NAK.)
 
 5    i = getpak()                        !Do system-dependent packet-read
  
      if ( btest(i,rtoBit) ) then         !Did we time-out?
          recpack = 'T'                   !Give'em a time-out
          return
      endif
      if (rlen .lt. 1) goto 5             !Must have been just a <CR>
      rbytes = rbytes + rlen              !Count bytes
      rovrhd = rovrhd + rlen              !all are overhead for now
      RecPkt(rlen+1:) = ' '               !Clear unused part of packet
      call IBMrd                          !look for IBM-PROMPT as needed
      call kdebug(packets,'RecPack: ',RecPkt(:rlen))
      rpak = rpak + 1                     !Count a received packet
      p = index(RecPkt,char(Sync))        !Find the sync character
      if (p .lt. 1) goto 5                !No sync mark; retry read
  
 10   if (p .lt. 1) then                  !No sync found?
          RecPack = 'T'                   !Act as if it timed out
          return
      endif
      if (p .gt. 1) then                  !Left-justify the sync byte
          rpinfo = RecPkt(p:)             !(Ftn7x can't assign substring to
          RecPkt = rpinfo                 !  a variable of the same name)
          rlen = rlen - (p - 1)           !Adjust the packet-length
          p = 1                           !Reset the pointer to the mark
      endif
      len  = -1                           !Clear the field variables to
      num  = -1                           !  allow each field to be picked
      type = -1                           !  off in the correct order
      i = 0                               !Clear the data-byte counter
  
      do while (p .le. rlen)              !Scan the packet
          p = p + 1                       !Go to next byte
          b = ichar(R1cPkt(p))            !...and get it
  
          if (b .eq. Sync) then           !Re-sync?
              goto 10
  
          else if (len .lt. 0) then       !Do data-length field
              len = unchar(b)-2-sCheck    !...set data length
  
          else if (num .lt. 0) then       !Do sequence-number field
              num = unchar(b)
  
          else if (type .lt. 0) then      !Do packet-type field
              type = b
  
          else if (i .lt. len) then       !Do packet-data field (if any)
              i = i + 1                   !Count a data byte
  
          else                            !Do checksum field
              ck = check1(R1cPkt,p)       !Compute the checksum
              b = unchar(b)
              if (ck .ne. b) then         !bad checksum?
                  recpack = 'X'           !...report it to sender
                  call cnumd(ck,numw1)    !computed cksm --> ASCII
                  call cnumd(b,numw2)     !actual cksm --> ASCII
                  work = num1 // ', got ' // num2
                  call kdebug(packets,'Bad Checksum, needed ',work)
              else
                  recpack = char(type)
              endif
              rlen = p                    !Note the end of the packet
              rovrhd = rovrhd - len       !Adjust overhead for data count
              return
          endif
  
      end do
  
      ErrMsg = 'Illegally formed packet'
      recpack = '!'            !!!!If we got here, we ran out of data
  
      return
      end
  
      integer*2 function ctl(b)                          ,<890525.1144>
     >Make controls printable
      implicit none
  
c     Toggle the 7th bit of a byte such that CTRL-A <--> A
  
      integer*2 b
  
      ctl = ixor(b,64)
  
      return
      end
  
      subroutine pPutc(b)                                ,<890525.1144>
     >Store a packet-data byte
      implicit none
  
      include kercom.ftni,NOLIST
      integer*2 b
  
      p1ata(p) = char(b)                  !Store the byte
      p = p + 1                           !...and count it
  
      return
      end
  
      subroutine recpar(len)                             ,<890525.1144>
     >Save other's parameters
      implicit none
  
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST          !Defines fRmx
      integer*2 len
      integer*2 pblocksize
      parameter (pblocksize = 9)
      integer*2 sdefs(pblocksize)         !Remote default parameters
      integer*2 unchar,ctl,pgetc,i,b,maxp
  
      Data sdefs /                        !Set default remote parameters
     >            80,                     !Maximum packet = 80 bytes
     >            30,                     !receive timeout = 30 seconds
     >            0,                      !no padding required
     >            0,                      !(padding uses nulls)
     >            13,                     !<CR> terminates a packet
     >            35,                     !Control-quoting uses "#"
     >            32,                     !No 8th-bit prefixing will be done
     >            1,                      !1-byte checksums
     >            32/                     !No repeat-counts will be done
  
      call MoveWords(sdefs,sPkSiz,pblocksize) !Set remote defaults
      call Set_Timeout(R,sTime*100,fRmx)  !Preset remote timeout
      NewChk = 1                          !Reset default checksum type
      p = 5                               !Start with the MAXL field
      fBit8 = .false.                     !No 8th-bit stuff unless agreed
      fRepC = .false.                     !No repeat-count unless agreed
      maxp = rlen - 1                     !Get last param pos (w/ checkt=1)
  
      do i = 1,pblocksize                 !parse each parameter field
          if (p .gt. maxp) then           !Past end of received data?
              sPcnt = i - 1               !Save # of parameters passed
              return
          endif
          b = ichar(R1cPkt(p))            !Get a parameter byte
          if (b .eq. 0) return            !Done?
          p = p + 1                       !bump the byte pointer
  
          if (i .eq. 1) then              !Packet size?
              sPkSiz = min(94,unchar(b))
          else if (i .eq. 2) then         !Timeout value?
              b = unchar(b)               !Yes - get it as usual
              sTime = b                   !Copy it to parameter block
              call Set_timeout(R,b*100,fRmx) !...and set the timeout up
          else if (i .eq. 3) then
              sPad = unchar(b)
          else if (i .eq. 4) then         !Is it the pad character?
              sPadch = ctl(b)
          else if (i .eq. 5) then         !EOL character?
              sEOL = unchar(b)
          else if (i.eq.6) then           !Quote character?
              sQuote = b
          else if (i.eq.7) then           !8th-bit prefix character?
              call valBquote(b)
          else if (i.eq.8) then           !Checksum type?
              if (b.gt.48 .and. b.lt.52) NewChk = b-48   !Allow only '1'-'3'
              ChkTyp = NewChk    !>>>1.98c I'll use that checksum-type too
          else if (i.eq.9) then           !Repeat-character prefix?
              sRepc = b                   !Yes - save it
              if (b.eq.Repc .and. b.gt.32) then !If same as mine & not blank
                  fRepc = .true.          !...then we'll do it
              endif
          endif
      end do
  
      return
      end
  
      subroutine SndPar(ptype,num)                       ,<890525.1144>
     >Send my parameters
      implicit none
  
      include kercom.ftni,NOLIST
      integer*2 num
      integer*2 i,ctl,toChar,svCheck
      character*1 ptype
  
      toChar(i) = i+32                    !Raise controls to printable
  
      svCheck = sCheck                    !Save partner's checksum type
      sCheck = 1                          !Always send params w/ 1-byte check
      p = 1                               !Reset the packet pointer
      pdata = ' '                         !Remove the old data
      call pPutc(toChar(PakSiz))          !Send my current packet size
      call pPutc(toChar(Timeout))         !Set my timeout in
      call pPutc(toChar(nPad))            !I don't need padding
      call pPutc(ctl(Padch))              !(and my pad-character is NULL)
      call pPutc(toChar(EOLch))           !My EOL is always 13
      call pPutc(Quote)                   !Give 'em my quote character
      call pPutc(Bit8)                    !...and my 8th-bit prefix
      call pPutc(ChkTyp + 48)             !Show which checksum type I want
      call pPutc(Repc)                    !Give 'em my repeat character
      i = min(sPcnt,9)                    !Don't send too many parameters
      call SndPack(ptype,num,i)           !Now send the packet
  
      sCheck = svCheck                    !Restore partner's checksum type
  
      return
      end
  
      integer*2 function unchar(ch)                      ,<890525.1144>
     >Undo "TOCHAR" operation
      implicit none
  
      integer*2 ch
  
      unchar = ch - 32
      return
      end
  
      subroutine fClose                                  ,<890525.1144>
     >Close current s/r file
      implicit none
  
      include kerfil.ftni,NOLIST
      integer*2 err
      integer*4 r,p
  
      if (fbnry) then                     !Need to trim a type-1 transfer?
          call FmpPosition(fiCb,err,r,p)  !Yes - where are we in the file?
          call FmpTruncate(fiCb,err,r-1)  !...truncate at one record less
      endif
      call FmpClose(fiCb,err)
  
      return
      end
  
      subroutine SendAbort                               ,<890525.1144>
     >Kill all send stuff
      implicit none
  
      include kercom.ftni,NOLIST
      include kerfil.ftni,NOLIST
      integer*2 err
  
      call fClose
      call FmpEndMask(maCb)
  
c -->  More to do???
  
      return
      end
 
      subroutine success(pass)                           ,<890525.1144>
     >Print pass/fail if local
      implicit none
  
      include kercom.ftni,NOLIST
      logical*2 pass
  
      if (R .ne. L) then                  !If we are local...
          call tpFm('_')                 !Sound the bell
          call sleep(100)
          if (pass) then
              call tpFm('File transfer(s) completed')
          else
              call tpFm('File transfer(s) failed')
          endif
          call sleep(100)
          call tpFm('')                  !Beep again
      endif
  
      return
      end
  
      subroutine startstats                              ,<890525.1144>
     >Start statistics logging
      implicit none
  
      include kersta.ftni,NOLIST
      integer*4 timenow
  
c     Clear all counters associated with the 'last transfer'
  
      spak = 0                            !Packets sent
      rpak = 0                            !Packets received
      rtry = 0                            !# of retries (sent or received)
      sbytes = 0                          !Bytes (total) sent
      rbytes = 0                          !...and recieved
      sovrhd = 0                          !Overhead bytes sent
      rovrhd = 0                          !...and received
  
      startim = timenow()                 !Start the clock
  
      return
      end
  
      subroutine endstats                                ,<890525.1144>
     >End statistics logging
      implicit none
  
      include kersta.ftni,NOLIST
      integer*4 timenow
  
      trpak = trpak + rpak                !Total the packets received
      tspak = tspak + spak                !Total the packets sent
      trtry = trtry + rtry                !Total the packets retried
  
      endtim = timenow()                  !Stop the clock
      if (endtim .lt. startim) then       !Did we cross midnight?
          endtim = endtim + 86400J        !Yes - add a day's seconds
      endif
  
      return
      end
  
      subroutine ValBQuote(b)                            ,<890525.1144>
     >Validate BQuote param
      implicit none
  
      include kercom.ftni,NOLIST
      integer*2 b,BIGY,AMPERSAND
      parameter (AMPERSAND = 38)
      parameter (BIGY      = 89)
 
      sBit8 = b                           !Save partner's 8-th bit character
      fBit8 = .false.                     !Preset BQuote processing off
      if (.not. f8OK) return              !Don't process if user has it off
  
      if (b .eq. BIGY) then               !Partner wants to use my byte?
          fBit8 = .true.                  !Yes - turn it on
          if (.not. fSend) then           !If I am to receive...
              Bit8 = AMPERSAND            !...need to use default bquote
          endif
          sBit8 = Bit8                    !Set sender's BQuote to mine
          return
      endif
  
      if ((b.gt.32 .and. b.lt.63) .or. (b.gt.95 .and. b.lt.127)) then
          Bit8 = b                        !Remote: "Do it with this byte"
          fbit8 = .true.                  !Flag the agreement
      endif
  
      return
      end
  
      subroutine doIpacket                               ,<890525.1144>
     >Process 'I' packet
      implicit none
  
      include kercom.ftni,NOLIST
      include kerfil.ftni,NOLIST          !To define fBnry
  
!     This routine's purpose is to perform all of those
!         "set param value"
!     on receipt of a server I (initialize) packet.  We are currently only
!     interested in the quote, bquote, and repeat characters, and the
!     checksum type.  Note that if b-quoting is disabled and parity isn't
!     none, we will not be able transfer binary, so if that flag is on,
!     turn it off!
  
      Quote = sQuote                      !Set myself to partner's quote
      Bit8 = sBit8                        !...and partner's bquote
      f8OK = Bit8 .ne. 32                 !Allow binary quoting?
      ChkTyp = sCheck                     !Partner wants special checksums?
      Repc = sRepc                        !Get partner's repeat character
  
      if (fBnry .and. Parity.ne.3 .and. .not.f8OK) fBnry = .false.
  
      return
      end
 
      character*1 function seof(retry)                   ,<890525.1144>
     >Send the EOF packet
      implicit none
  
      include kercom.ftni,NOLIST
      include kerfil.ftni,NOLIST
      integer*2 retry,num,len,err,FmpOpen
      logical*2 fRetry
      character*1 ptype,RecPack
      character*4 openopts
  
      if ( fRetry(retry) ) then
          seof = '!'
          call SendAbort
          return
      endif
  
      call SndPack('Z',seq,0)             !Send the EOF packet
      seof = state                        !Assume no change in state
      ptype = RecPack(len,num)            !Get the response
  
      if (ptype .eq. 'T') then            !Time-out?
          return                          !just retry
  
      else if (ptype .eq. 'E') then       !Error packet?
          ErrMsg = 'Receiver error: ' // RecPkt(5:len+4)
          seof = 'E'
          call SendAbort
          return
  
      else if (ptype .eq. 'N') then       !NAK?
          if (mod(seq+1,64) .ne. num) then
              return
          else
              ptype = 'Y'
              num = num - 1
          endif
      endif
  
      if (ptype .eq. 'Y') then            !ACK?
          if (num .ne. seq) return
          retry = 0
          call fClose                     !Close the current file
          seq = mod(seq+1,64)             !Set next sequence number
          seof = '@'
  
      else                                !Unknown packet type
          ErrMsg = 'Unknown packet type: ' // ptype
          seof = '!'                      !Abort the transfer
          call SendAbort                  !Close sending/search files
      endif
  
      return
      end
  
      subroutine SndErr                                  ,<890525.1144>
     >Send error-packet
      implicit none
  
      include kercom.ftni,NOLIST
      integer*2 len,TrimLen
  
      pdata = ErrMsg
      len = TrimLen(pdata)
      if (fPkIO) then
          call SndPack('E',seq,len)       !Send error-packet
          if (R .ne. L) call tpFm(ErrMsg) !Inform local user
      else
          call tpFm(ErrMsg)
      endif
  
      return
      end
  
      subroutine sndpack(type,num,len)                   ,<890525.1144>
     >Transmit a packet
      implicit none
  
c     NOTE: it is assumed that asynchronous interrupts on the remote
c           LU have been disabled prior to this routine.
  
      include kercom.ftni,NOLIST
      include kerdbg.ftni,NOLIST
      include kersta.ftni,NOLIST
  
      character*1 type
      integer*2 num,len
      integer*2 i,j,check1,check2,check3
      character*1 toChar
  
      toChar(i) = char(i+32)          !Raise controls to printable range
  
      i = sPad + len + 5 + sCheck     !Compute length of packet
      sbytes = sbytes + i             !Count 'em
      sovrhd = sovrhd + i - len       !Adjust overhead for data
  
      if (sPad .gt. 0) then           !Need to do padding?
          do i = 1,50                 !Yes - build a pad-character buffer
              P1cket(i) = char(sPadCh)
          end do
          do i = 1,sPad,50            !Send padding in 50-byte pieces
              j = min(50,sPad-(i-1))  !Set tx count (don't overdo padding!)
              call putpak(j)
          end do
      endif
  
      Packet = char(sSync)                !Clear packet/install sync byte
      P1cket(2) = toChar( len+2+sCheck )  !...and the length byte
      P1cket(3) = toChar( num )           !...and the sequence number
      P1cket(4) = type                    !...and the packet type
      Packet(5:) = pData                  !...add the data part
      p = 5 + len                         !Adjust the store-pointer
      P1cket(p) = toChar(check1(P1cket,p))!Perform/store the checksum
      p = p + 1                           !Bump pointer for EOL character
      if (sCheck .ne. 1) then             !Do 2- or 3-byte checks?
          P1cket(p) = toChar(check2())    !Yes - add the 2nd byte
          p = p + 1
      endif
      if (sCheck .eq. 3) then             !Doing 3-byte CRC?
          P1cket(p) = toChar(check3())    !Yes - add last byte
          p = p + 1
      endif
      P1cket(p) = char(sEOL)              !Voila - packet is ready to send
  
      call kdebug(packets,'SndPack: ',packet(:p))
  
      call putpak(p)                      !send the packet
  
      spak = spak + 1                     !Count the packet
  
      return
      end
  
      integer*2 function Check1(pack,plen)               ,<890525.1144>
     >Generate checksums
      implicit none
  
!     When called as Check1, this function calculates the 1- or 2-byte
!     checksum or a 3-byte CRC, AS DICTATED BY MY PARTNER'S PARAMETERS!
!     The part of the packet which is subject to checking is the length
!     field through the current value of "P" (the pointer to the next
!     byte of the packet) less 1.  It is called either to encode the
!     checksum/CRC or to test it on a received packet.  The returned
!     value of Check1 is the first of a possibly multi-byte checksum or
!     CRC.  Check2 and Check3 return the remaining bytes of the 2-byte
!     checksum or 3-byte CRC as needed.  Note that the form of the 1st
!     byte of the 1- and 2-byte checksums is NOT the same!.
  
      include kercom.ftni,NOLIST
      character*1 pack(*)
      integer*2   plen,i,csum,b
      integer*2   check2,check3
      integer*2   x,y,crc1(0:15),crc2(0:15)
      data crc1 /
     >000000b,010201b,020402b,030603b,041004b,051205b,061406b,071607b,
     >102010b,112211b,122412b,132613b,143014b,153215b,163416b,173617b/
      data crc2 /
     >000000b,010611b,021422b,031233b,043044b,053655b,062466b,072277b,
     >106110b,116701b,127532b,137323b,145154b,155745b,164576b,174367b/
  
      csum = 0                            !Clear checksum accumulator
  
      do i = 2,plen-1                     !Checksum length thru data
          b = ichar( pack(i) )            !Get a packet byte
          if (sCheck .ne. 3) then         !Doing 1- or 2-byte checks?
              csum = csum + b
          else                            !else doing CCITT-CRC
              b = ixor(b,csum)
              x = iand(b,17b)             !Get lower nybble
              y = ibits(b,4,4)            !...and upper nybble
              b = ixor(crc2(x),crc1(y))   !Get CRC factor
              csum = ibits(csum,8,8)      !Shift off byte from previous CRC
              csum = ixor(csum,b)         !and add in new value
          endif
      enddo
  
      if (sCheck .eq. 1) then             !Return proper 1-byte checksum
          check1 = iand( 63,(csum + (iand(csum,192)/64)))   !Form type-1 check
      elseif (sCheck .eq. 2) then         !Return 1st of 2-byte checksum
          check1 = ibits(csum,6,6)        !...as upper 6 of 12-bit checksum
      else                                !Return 1st of 3-byte CRC
          check1 = ibits(csum,12,4)       !...as upper 4 of 16-bit CRC
      endif
      return
  
      entry check2()
      if (sCheck .eq. 2) then             !Return 2nd of 2-byte checksum
          check2 = iand(csum,77b)         !...as lower 6 of 12-bit checksum
      else                                !else return 2nd of 3-byte CRC
          check2 = ibits(csum,6,6)        !...as bits 6-11 of 16-bit CRC
      endif
      return
  
      entry check3()
      check3 = iand(csum,77b)             !Return low 6 bits of CRC
      return
  
      end
  
      subroutine get                                     ,<890525.1144>
     >Get from a server
      implicit none
  
      include kercom.ftni,NOLIST
      include kercmd.ftni,NOLIST
      include kerfil.ftni,NOLIST
      logical*2 succeed,receive,fRetry,fRtryi
      integer*2 retry,err,len,num,TrimLen,j
      character*1 ptype,RecPack
  
      retry = 0                           !Reset the retry-counter
  
 5    if ( fRtryi(retry) ) then           !Retry-limit exceeded?
          call tpFm('Unable to initialize on a Get command')
          return
      endif
  
      call SndPar('I',seq)                !Try to initialize
      ptype = RecPack(len,num)            !Get the response
      if (ptype .eq. 'Y') then            !ACK?
          if (num .ne. seq) goto 5        !Retry if out of sequence
      endif
 
      seq = 0                             !Reset the sequence number
      retry = 0                           !...and retry counter
      pdata = GetMask                     !Set 1st param as get's data
      j = TrimLen(pdata)                  !Get the name's length
  
 10   if ( fRetry(retry) ) then           !Exceeded the retry limit?
          call tpFm('Unable to GET')
          return
      endif
  
      call SndPack('R',seq,j)             !Send the request for files
      ptype = RecPack(len,num)            !Get the response
  
      if (ptype .eq. 'S') then            !Correct response is send-init
          if (num .ne. seq) goto 10
          fSend = .false.                 !Do params as a receive
          call RecPar(len)                !get partner's parameters
          if (fBnry .and. Parity.ne.3 .and. .not.fBit8) then
              ErrMsg = 'Can''t receive binary file (parity problem)'
              call SndErr
              fBnry = .false.
              return
          endif
          call SndPar('Y',seq)            !...and send mine
          sCheck = NewChk                 !Change checksum type now
          seq = mod(seq+1,64)
          succeed = receive('F')          !Try to receive
          call success(succeed)
          sCheck = 1                      !Revert to 1-byte checksums
          return
      else if (ptype .eq. 'E') then       !Error packet?
          call tpCh('Received error packet: -',RecPkt(5:len+4),0)
          return
      else if (ptype .eq. 'X') then       !Checksum error?
          call tpFm('Checksum error - retrying')
      else if (ptype .eq. 'T') then       !Time-out?
          call tpFm('<timed out>')
      else
          call tpCh('Unknown packet type: -',ptype,1)
      endif
  
      goto 10
 
      end
  
      subroutine IBMrd                                   ,<890525.1144>
     >Look for IBM-prompt
      implicit none
  
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST          !To define remote configuration
      include kersta.ftni,NOLIST
      integer*2 xr(2),rc
      equivalence (xr(2),rc)
  
      if ( fIBM ) then                    !Need to wait for PROMPT?
          xr = R
          if ( btest(iRmx,0) ) then       !D-mux?
              Rc = 100b                   !Yes - just set for binary
          else
              Rc = 1100b                  !Binary + keep type-ahead data
          endif
          p = 18                          !Yes - read at least one byte
          do while (p .ne. 17)            !Look for prompt byte
              rbytes = rbytes + 1
              rovrhd = rovrhd + 1
              call xluex(1,xr,p,-1)
              p = ishft(p,-8)             !Move byte for look for IBM-PROMPT
          end do
      endif
      return
  
      end
 
      subroutine PakIO                                   ,<890525.1144>
     >Prepare for packet-I/O
      implicit none
  
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST
  
      if (R .eq. L) then                  !If remote-host mode...
          call disable(R,fRmx)            !...disable scheduling
          call KillEnqAck                 !...and handshake
      endif
      call control(R,2600b,1)             !Clear all input buffers
      fPkIO = .true.
      seq = 0                             !Reset sequence#
      return
  
      end
  
      subroutine NrmIO                                   ,<890525.1144>
     >Restore from packet-I/O
      implicit none
  
      include kercom.ftni,NOLIST
      include kercnf.ftni,NOLIST          !Defines fRmx
  
      sCheck = 1                          !Revert to 1-byte checksums
      fPkIO = .false.
      if (R .eq. L) then
          call restore(R)
          call enable(R,fRmx)
      endif
      return
  
      end
<<< KCMNDS.FTNI >>>
!     Goes with rev 1.98 or later; edited  1:00 PM  Thu., 12  Jun., 1986
  
!     This common provides storage for KERMIT's command-tables
  
      integer*2 cmtsiz                    !command-table size
      integer*2 setsiz                    !SET-parameter-table size
      integer*2 prtsiz                    !parity parameter-table size
      integer*2 dbtsiz                    !debug-table size
      parameter (cmtsiz = 15)
      parameter (setsiz = 17)
      parameter (prtsiz =  5)
      parameter (dbtsiz =  5)
      character*8 commands(cmtsiz)        !Top-level commands
      character*7 setparms(setsiz)        !SET parameter names
      character*5 parits(prtsiz)          !Parity types
      character*7 debugs(dbtsiz)          !Debug types
      common /kcmnds/ commands,setparms,parits,debugs
  
<<< KCONCW.FTNI >>>
!     Goes with rev 1.99b or later; edited  2:48 PM  THU., 15  OCT., 1987
  
!     This common provides storage for the control-words used by Connect
!     and its assistants.
  
      integer*2 Ltx(2),Lrx(2),Rtx(2),Rrx(2)
      integer*2 Ltc,Lrc,Rrc,Rtc,term,dstat
      logical*2 fASI,fRcm,fLcm
      common /kconcw/ Ltx,Lrx,Rtx,Rrx,term,dstat,fASI,fRcm,fLcm
      equivalence (Ltx(2),Ltc),(Lrx(2),Lrc)
      equivalence (Rtx(2),Rtc),(Rrx(2),Rrc)
  
<<< KERCMD.FTNI >>>
!     Goes with rev 1.99 or later; edited  1:00 PM  Thu., 12  Jun., 1986
  
!     This common provides storage for KERMIT's command-parsing routines
  
      integer*2 cmP1                      ! parsing pointer #1
      integer*2 cmP2                      ! parsing pointer #2
      integer*2 cmLn                      ! current length of command
      integer*2 cmIn(40)                  ! the command-line array
      character cmCh*80                   ! same as cmIn
      character cmTk*80                   ! A command-line token
      character cmRu*80                   ! A run-command save
      common /kercmd/ cmP1,cmP2,cmLn,cmIn,cmTk,cmRu
      equivalence (cmCh,cmIn)
  
<<< KERCNF.FTNI >>>
!     Goes with rev 1.99 or later; edited  1:02 PM  TUE., 14  APR., 1987
  
!     This common provides storage for KERMIT's configuration-dependent code
  
      integer*2 CnfSiz                    !Size of configuration arrays
      parameter (CnfSiz = 11)
      logical*2 fLmx,fRmx                 !TRUE if LU is on a MUX
      integer*2 iLmx,iRmx                 !equivalenced to the above
      integer*2 Lsyu,Rsyu                 !System LU number
      integer*2 Ltim,Rtim                 !timeout value save
      integer*2 Ltrg,Rtrg                 !trigger-character saves
      integer*2 L17v,R17v                 !terminator-character saves
      integer*2 L30c,L33c,L34c            !Current local cn30/33/34 values
      integer*2 L30s,L33s,L34s            !Saved local cn30/33/34 values
      integer*2 R30c,R33c,R34c            !Current remote cn30/33/34 values
      integer*2 R30s,R33s,R34s            !Saved remote cn30/33/34 values
  
!     The following parameters allow major changes to the structure of the
!     configuration arrays with no changes to the routines using them!
  
      integer*2 fMx,syu,tim,trg,v17,c30,c33,c34,s30,s33,s34
      parameter (fMx =  1)                !Mux-flag word
      parameter (syu =  2)                !System unit-number
      parameter (tim =  3)                !Saved timeout value
      parameter (trg =  4)                !Saved trigger character
      parameter (v17 =  5)                !Saved terminator character
      parameter (c30 =  6)                !Current CN30 parameter
      parameter (c33 =  7)                !Current CN33 parameter
      parameter (c34 =  8)                !Current CN34 parameter
      parameter (s30 =  9)                !Saved CN30 parameter
      parameter (s33 = 10)                !Saved CN33 parameter
      parameter (s34 = 11)                !Saved CN34 parameter
  
      integer*2 LocCnf(CnfSiz),RemCnf(CnfSiz),cfg(32)
      equivalence (fLmx,iLmx,LocCnf(fmx)),(fRmx,iRmx,RemCnf(fmx))
      equivalence (Lsyu,LocCnf(syu)),(Rsyu,RemCnf(syu))
      equivalence (Ltim,LocCnf(tim)),(Rtim,RemCnf(tim))
      equivalence (Ltrg,LocCnf(trg)),(Rtrg,RemCnf(trg))
      equivalence (L17v,LocCnf(v17)),(R17v,RemCnf(v17))
      equivalence (L30c,LocCnf(c30)),(R30c,RemCnf(c30))
      equivalence (L33c,LocCnf(c33)),(R33c,RemCnf(c33))
      equivalence (L34c,LocCnf(c34)),(R34c,RemCnf(c34))
      equivalence (L30s,LocCnf(s30)),(R30s,RemCnf(s30))
      equivalence (L33s,LocCnf(s33)),(R33s,RemCnf(s33))
      equivalence (L34s,LocCnf(s34)),(R34s,RemCnf(s34))
  
      common /kercnf/ LocCnf,RemCnf,cfg
<<< KERCOM.FTNI >>>
!     Goes with rev 1.99d or later; edited  2:26 PM  Thu.,  7  DEC., 1989
  
!     This is KERMIT's main control storage; see the main program for info
  
!     Notice: If you encounter an undefined external reference to FTRAP
!             as you link KERMIT, you should set the value of the SysRev
!             (below) to any value less than 2440, then re-compile.  This
!             parameter is only used in the KermInit subroutine.  Any other
!             undefined externals mean a real problem - call me!
  
      integer*2 SysRev
      parameter (SysRev = 5010)           !The current latest system revision
  
      !Warning: Do Not allocate any storage between PakSiz and sSync!
 
      integer*2    Delay,EsChar,L,ImxTry,MaxTry,R,p,rlen,seq,class,
     >             slen,trCb(144),fePath,sPcnt,parity,seg,pvalu(10),
     >             NewChk,rtoBit,
     >             PakSiz,Timeout,nPad,Padch,EOLch,Quote,   ! My params
     >              Bit8,ChkTyp, Repc,capas(2),  Sync,      ! My params
     >             sPkSiz,sTime,sPad,sPadch,sEOL,sQuote,    ! other's parms
     >             sBit8,sCheck,sRepc,sCapas(2),sSync       ! other's parms
      logical*2    fWarn,fIBM,fServ,fTrans,fBit8,fRepc,fpkio,fEcho,
     >             fSend,f8OK
      character    HlpNam*64,Packet*100,RecPkt*256,pdata*96,state*1
      character*1  P1cket(100),R1cPkt(256),p1ata(96)
      equivalence  (Packet,P1cket),(RecPkt,R1cPkt),(pdata,p1ata)
      character    ErrMsg*72,Prompt*20
  
      common /ker/ Delay,EsChar,L,ImxTry,MaxTry,R,p,rlen,seq,class,
     >             slen,trCb     ,fePAth,sPcnt,parity,seg,pvalu    ,
     >             NewChk,rtoBit,
     >             PakSiz,Timeout,nPad,Padch,EOLch,Quote,   ! My params
     >              Bit8,ChkTyp, Repc,capas   ,  Sync,      ! My params
     >             sPkSiz,sTime,sPad,sPadch,sEOL,sQuote,    ! other's parms
     >             sBit8,sCheck,sRepc,sCapas   ,sSync,      ! other's parms
     >             fWarn,fIBM,fServ,fTrans,fBit8,fRepc,fpkio,fEcho,
     >             fSend,f8OK,
     >             HlpNam   ,Packet    ,RecPkt    ,pdata   ,state  ,
     >             ErrMsg   ,Prompt
<<< KERDBG.FTNI >>>
c     Goes with rev 1.96c or later; edited  1:00 PM  Thu., 12  Jun., 1986
      integer*2 dbCB(144)                 ! Debug-file control-block
      integer*2 dbLv                      ! Debugging level
      integer*2 states,packets,all        ! debugging level (binary) codes
      parameter (states  = 1)
      parameter (packets = 2)
      parameter (all     = 3)
      character dbNm*64                   ! Debugging log-file name
      common /kerdbg/ dbCB,dbLv,dbNm
  
<<< KERFIL.FTNI >>>
!     Goes with rev 1.99a or later; edited 11:02 AM  WED., 22  JULY, 1987
  
!     This common provides storage for KERMIT's file-control routines
!     Changed at 1.99a: increased maCb from 356 to 372 for rev 5.0 of RTE
  
      integer*2 MAXREC                    ! Maximum record size I handle
      parameter (MAXREC = 256)            ! (...in bytes)
      integer*2 fiCB(144)                 ! S/R-file control-block
      integer*2 fiEr                      ! Last reported file-error code
      integer*2 fiPt                      ! current byte in fiBf
      integer*2 fiLn                      ! current record length in bytes
      integer*2 fiSz                      ! Allocated size of received file
      integer*2 maCb(372)                 ! Mask-search control-block
      logical*2 first                     ! Flags 1st-time for file-masks
      logical*2 fMore                     ! Flags more files can be found
      logical*2 fBnry                     ! Binary flag: True if binary
      character*258 fiCh                  ! File record-buffer
      character*64 fiNm                   ! S/R-file name
      character*64 mask                   ! file-mask or indirect-file name
      character*64 Rmask                  ! Server-receive file-mask
      character*96 GetMask                ! Mask used in a "GET" command
      character*64 CurPath                ! Current file-mask path
      common /kerfil/
     >    fiCB,fiCh,fiEr,fiPt,fiLn,fiSz,maCb,
     >    first,fMore,fBnry,fiNm,mask,Rmask,GetMask,CurPath
  
<<< KERSTA.FTNI >>>
!     Goes with rev 1.99 or later; edited 16:00 PM  Sat., 29  Aug., 1986
  
!     This common provides storage for KERMIT's transmission statistics
  
      integer*2 tspak,trpak,trtry         ! Total send/receive/retry packets
  
                                          ! Last transfer statistics
      integer*4 startim,endtim            ! Start- & end-time
      integer*2 spak,rpak,rtry            ! # send/receive/retry packets
      integer*4 sbytes,rbytes             ! # bytes (data) sent/received
      integer*4 sovrhd,rovrhd             ! # bytes overhead sent/received
  
      common /kstats/ tspak,trpak,trtry,startim,endtim,spak,rpak,
     >               rtry,sbytes,rbytes,sovrhd,rovrhd
  
