Columbia Kermit/kermit.zip/cdccyber/cdcker.for

Text File | 2020-01-01 | 186KB | 6,006 lines

*comdeck comcker
cc    comcker - kermit symbol definitions.
c
c     this comdeck contains all symbol definitions needed by kermit.  it
c     contains items found in several different areas in the texas
c     version of kermit, and cleans up usage conflicts among the various
c     parameter values.  this comdeck should be *called into every
c     kermit module.
c
      implicit integer (a - z)

cc    kermit site definitions.
c
c     character set information.
c
c     ipc641 = ip.c64.1 (from iptext).
c     ipc642 = ip.c64.2 (from iptext).
c     ipc63 = ip.c63 (from iptext).
c     ipcset = ip.cset = character set in use at your site.
c     n.b.  ipcset is ignored if ut2d = 1.
c
      parameter (ipc641=0, ipc642=1, ipc63=2)
*if def,63cset,1
      parameter (ipcset=ipc63)
*if def,641cset,1
      parameter (ipcset=ipc641)
*if def,642cset,1
      parameter (ipcset=ipc642)

cc    o.s. definitions.  set your o.s. to 1, all others to 0.
c
*if def,nos,1
      parameter (ut2d=0, nos=1, nosbe=0, scope=0)
*if def,nosbe,1
      parameter (ut2d=0, nos=0, nosbe=1, scope=0)
*if def,scope,1
      parameter (ut2d=0, nos=0, nosbe=0, scope=1)
*if def,ut2d,1
      parameter (ut2d=1, nos=0, nosbe=0, scope=0)

cc    site definitions.  used for sites with non-standard opsys.
c
*if def,uariz,1
      parameter (utexas=0, uariz=1)
*if def,utexas,1
      parameter (utexas=1, uariz=0)
*if def,other,1
      parameter (utexas=0, uariz=0)

cc    nos definitions.  used for nos sites.
c
c     nosver = version number (14, 20, 21, etc).
c     noslvl = psr level.

      parameter (nosver = 22, noslvl=602)

cc    file i/o definitions.
c
      parameter (stdin=1, stdout=2)

cc    ascii character definitions.
c
      parameter (soh=1, tab=9, lf=10, cr=13, blank=32, minus=45)
      parameter (qmark=63, del=127, nel=o"0205", null=o"4000", eof=-1)

cc    miscellaneous.
c
      parameter (ok=1, error=-2, on=1, off=0, yes=1, no=0)

cc    protocol definitions.
c
      parameter (unknown=0, fulldup=1, halfdup=2)
      parameter (none=0, even=1, odd=2, mark=3, space=4)
      parameter (maxinit=20, maxtry=5)
      parameter (maxpack=94, mytime=10, mypad=0, mypadch=0)
      parameter (myeol=13, myquote=35, quot8ch=78, mycktyp=49)
      parameter (prefxch=126)

cc    packet types.
c
      parameter (a=65, b=66, c=67, d=68, e=69, f=70, g=71, l=76, n=78)
      parameter (r=82, s=83, y=89, z=90)

cc    packet error definitions
c
      parameter (toomany=o"1000", invalid=o"2000", seqerr=o"4000")
      parameter (lclfile=o"10000", notlcl=o"20000", invfn=o"40000")
      parameter (srvcmd=o"100000")
      parameter (sending=o"100", reading=o"200")
      parameter (initerr=1, filerr=2, dataerr=4, eoferr=o"10")
      parameter (brkerr=o"20")


cccc  kermit saved common block header
c
c     all common blocks to be saved when executing monitor
c     commands must be placed between /header/ and /trailer/
c
      common /header/ header


cccc  kermit command processor common block.
c
      common /kermcmd/ autoret, dskcset, rdelay


cccc  kermit packet description common block.
c
c     do not allocate any storage between packsiz and sndsync!

c     allocate storage for what i want.

      common /packet/ packsiz, timeout, npad, padch, eolch, quotech,
     +                quote8, chktyp, rprefix, reserve(2), sync,

c     allocate storage for what partner wants.

     +                spksiz, stimout, spad, spadch, speol, spquote,
     +                s8quote, schktyp, srepeat, unused(2), sndsync


cccc  kermit protocol common block.
c
      common /proto/ packet(maxpack), recpack(maxpack),
     +   filestr(maxpack),
     +   psize, packnum, numtry, maxrtry, maxrini, state, ifd, ofd, ffd,
     +   delayfp, savedpx,

c     storage for statistics.

     +   abortyp, startim, endtim, schcnt, rchcnt, schovrh, rchovrh


cccc  debug common block.
c
      parameter (dbgoff=0, dbgstat=1, dbgpack=2, dbgall=3)
      common /debug/ debug, debugfd, debugfn(8)


cccc  ascii string message common block defintions.
c
      integer errmsg(maxpack)

      common /msg/ errmsg


cccc  kermit saved common block trailer
c
      common /trailer/ trailer


cccc  file i/o common block definitions.
c
      parameter (maxfile=5)

c     cio related parameters.
c
c     ciord = cio read function code.
c     ciowt = cio write function code.
c     ciobufl = cio buffer length (must be .gt. pru size of device).
c     fetl = fet length in words.
c     maxwd = line size in words; must be an even number.
c     normal = flag to exitpgm that this is a normal exit.

      boolean ciord, ciowt
      parameter (ciord = o"10", ciowt = o"14")
      parameter (asciiio = 43, nosbit = 42, cioodd = o"2")
      parameter (ciobufl=129, fetl=6, maxwd=32)

      parameter (closed=0, rd=1, wr=2, create=3)
      parameter (nopar=0, evepar=1, oddpar=2, mrkpar=3, spcpar=4)
      parameter (dskdpc=0, dsknos8=1, dskut8=2, dskimag=4)
      parameter (dskasci = dsknos8 .or. dskut8)

      character*10 fname(maxfile)
      common /fileioc/ fname

      boolean fchbuf(maxwd,maxfile)
      boolean fets(0:fetl - 1,maxfile), ciobuff(ciobufl,maxfile)
      integer fmode(maxfile), fnwds(maxfile), fwptr(maxfile),
     +        fwshft(maxfile)
      logical feof(maxfile), ctdev(maxfile), rawmode, binmode
      logical normal
      common /fileio/ fmode, fwptr, fnwds, feof, fwshft,
     +   ctdev, rawmode, binmode, parity, duplex, normal
      common /fetcom/ fets, ciobuff, fchbuf
c     common // ciobuff, fchbuf


cccc  message common block.
c
      character*37 version
      character*15 ambig
      character*38 nomatch
      character*24 follow
      character*53 nodigit
      character*31 missing
      character*33 confmsg
      character*19 notconf
      character*42 hlpdlfp
      character*37 hlpdbfn
      character*24 hlpplen
      character*34 hlppadl
      character*74 hlpasch
      character*29 hlpiprc
      character*21 hlpprtr
      character*43 hlptimo
      character*19 hlpsnfn
      character*41 hlprdel

      common /message/ version, ambig, nomatch, follow, nodigit,
     +   missing, confmsg, notconf,
     +   hlpasch, hlpdlfp, hlpdbfn, hlpplen, hlppadl, hlpiprc, hlpprtr,
     +   hlptimo, hlpsnfn, hlprdel


cccc  character conversion tables.
c
c     dpctbl = ascii to display code table.
c     lascii = display code to lower case ascii.
c     uascii = display code to upper case ascii.

      boolean dpctbl(0:127), lascii(0:63), uascii(0:63)
      common /charcom/ dpctbl, lascii, uascii
*comdeck kermcom  same as comcker, but turns off listing.
c$    list(s=0)
c
c     the following c$ lines are here instead of comcker because
c     ftn5 flags them as errors in a block data module (grrrr).
c
c$    collate(fixed)
c$    do(ot=0)
*call comcker
c$    list(s=1)
*deck kermit
*if def,ovcap
          ident  kermit
          lcc    overlay(0,0,ov=8)
          ldset  lib
          ldset  lib=kermlib/azlib/ftn5lib
          ldset  omit=syserr.  saves 2000b+ words
          entry  kermit
          syscom b1
 kermit   title  kermit - micro computer file exchange/kermit protocol.
          comment micro computer file exchange/kermit protocol.
 kermit   space  4,10
*****     kermit - micro computer file exchange/kermit protocol.
*
*         kermit is a file shipping program used by micro computers to
*         transfer files to/from another computer.  it was originally
*         developed by columbia university for their decsystem-20, and
*         adapted by the university of texas for their cyber and ut2d
*         operating system.
 kermit   space  4,10
***       micro computer file interchange/kermit protocol.
*
*         this version is for use under nos/be.  in case you are
*         wondering, kermit stands for (k)l10 (e)rror-free (r)eciprocal
*         (m)icroprocessor (i)nterchange over (t)ty lines.  (x)
*         indicates a letter in the acronym.  a kl-10 (aka kl-20) is a
*         digital equipment corporation 36 bit cpu.
 kermit   space  4,10
**        internal documentation.
*
*         due to the nasty habit intercom has of swapping out jobs that
*         go into terminal input wait, kermit's field length must be
*         kept to a minimum.  since kermit does ascii i/o, it cannot
*         use fortran read and write statements.  thus, an easy way to
*         save memory is to kick out most ftn5lib modules.  this is
*         complicated by some needed modules calling 'syserr.', which
*         in turn drags in about 3000b words of other stuff.  for this
*         reason, i have included an 'ldset omit=syserr.' in this
*         module.  thus, should some error condition arise that
*         would cause ichar, char, xovcap, or whoever to call 'syserr.',
*         an error mode 1 at will happen in the routine making the
*         call.  since this should not occur, i am willing to live
*         with the user hostile diagnostic.  for debugging purposes,
*         the ldset may be commented out so you get the ftn5 error
*         diagnostic.
*
*         i also used ovcaps instead of segmenting kermit so the core
*         image can be installed in nucleus, with the ovcaps in sysovl.
*         cdc has not yet answered a psr we submitted regarding fdl.ocr
*         not looking in sysovl for caps for nucleus programs.  thus,
*         without our suggested code, ovcaps will need to be in nucleus
*         also.
*
*         each ovcap has a compass front-end so that the comment field
*         of the binary has useful information in it.  this is useful
*         when you itemize a deadstart tape.  also, making the main
*         be in compass gets rid of a call to 'q5ntry=' which also
*         saves some memory.
 kermit   title  main program.
**        main program.


 kermit   sb1    1
          if     def,actr,1
          sa1    actr        get control card parameter count
          if     def,ra.act,1
          sa1    ra.act      get control card parameter count
          sx1    x1
          zr     x1,kermit1  if no parameters
          message (=c* kermit - too many parameters.*),,rcl
          abort  ,nd,s

 kermit1  rj     =xkermain   call the real workhorse
          endrun

          end    kermit
*if def,nos
          ident  nostuff
          title  nostuuf - nos version 2 *kermit* assist.
*comment  nostuuf - nos version 2 *kermit* assist.
          entry  memstat
          entry  nosinit
          entry  nosexit
          entry  nosetlf
          entry  nosctab
          entry  noswait
          ldset  lib=srvlib/symlib
          sst
          syscom b1
 nostuff  space  4,10
***       nostuuf - nos version 2 *kermit* assist.
*         bill russell.      84/07/01.
 nostuff  space  4,10
***              nostuff contains various subroutines that interface
*         kermit to nos version 2.
          title  nosinit - initialize *kermit* in a nos system.
 nosinit  space  4,10
***       nosinit - initialize *kermit* in a nos system.
*
*         entry  none.
*
*         exit   the following will be true:
*                            all nos/iaf prompts will be *off*
*                            the terminal will be in *ascii* mode


 nosinit  subr
          sb1    1
          prompt off
          cset   ascii
          eq     nosinit
          title  nosexit - terminate *kermit* in a nos system.
 nosexit  space  4,10
***       nosexit - terminate *kermit* in a nos system.
*
*         entry  none.
*
*         exit   final status message will be issued.


 nosexit  subr
          sb1    1
          move   endcl,endc,endb
          sx6    3
          sa6    mema
          rj     memstat
          endrun
          title  memstat - issue *b display* kermit memory status.
 memstat  space  4,10
***       memstat - issue *b display* kermit memory status.
*
*         entry  none.
*
*         exit   kermit status message will be displayed on the
*                *b display*.
*
*         calls  cmm.gss (in nos system library symlib).
*                cmm.op4 (to shrink memory).

 memstat  subr
          sb1    1
          rj     =xcmm.op4   shrink at end of memory
          rj     =xcmm.gss   fetch memory stats
          sa1    x1+b1
          rj     =xcod=
          sa1    endb+2
          mx0    42
          lx6    18
          bx6    x0*x6
          bx7    -x0*x1
          bx6    x6+x7
          sa6    a1

          sa4    mema
          message endb,x4,r
          eq     memstat

 mema     con    1             only line 1 of the display
 enda     con    0
 endb     data   c* kermit running.     xxxxxxb  cm used.*
 endc     data   c* kermit complete.    xxxxxxb  cm used.*
*                  1234567890123456789012345678901234567890
 endcl    equ    *-endc
          title  nosetlf - set the list-of-files.
 nosetlf  space  4,10
***       nosetlf - set the list-of-files.
*
*         entry  arg1 = fet pointer.
*                arg2 = fet ordinal.
*
*         exit   (ra+arg2) = 42/ file name, 18/ fet address


 nosetlf  subr
          sb1    1
          mx0    42
          sa3    x1
          bx3    x0*x3       file name only
          sa4    a1+b1
          sa4    x4          file ordinal
          sx6    x4-3        check if special name
          pl     x6,slf1     if not a special name
          sa3    slfa+x4     fetch special nos name

 slf1     sx6    x1
          bx6    x6+x3       file name + pointer to fet
          sa6    x4+b1       set name in lof
          eq     nosetlf

 slfa     bss    0           special list of files filenames

          vfd    60/0             for *nothing*
          vfd    42/0linput,18/0  for *stdin*
          vfd    42/0loutput,18/0 for *stdout*
          title  nosctab - check type-ahead buffer in a nos system.
 nosctab  space  4,10
***       nosctab - check type-ahead buffer in a nos system.
*
*         entry  none.
*
*         exit   (x6) = 0 = if no characters in the type-ahead buffer.


 nosctab  subr
          sb1    1
          system tlx,r,ctab,1600b *check* type-ahead buffer
          sa1    ctab
          bx6    x1
          eq     nosctab     return
 ctab     bssz   1           type-ahead present flag
          title  noswait - wait at a control point for 24 milli-seconds.
 noswait  space  4,10
***       noswait - wait at a control point for 24 milli-seconds.
*
*         entry  none.


 noswait  subr
          sb1    1
          wait   24          ** current nos 2.2 system default **
          eq     noswait
          end
*endif
*if def,ovcap
      subroutine kermain
*endif
*if -def,ovcap
      program kermit
*endif

ccc   kermit - a cyber file transfer program using the kermit protocol
c
c     this program may not be sold for profit.
c
c     modifications:
c
c     2.2   8/22/84  ric anderson, university of arizona at tuscon
c        add update ifdefs for character set, operating system, and site
c        selection.  fix execmd to work under nos/be.  fix cfe for use
c        under nos/be.  correct spelling errors.
c
c     2.1   8/16/84  bill russell, new york university
c        added nos 2.2 support (up through level 602).  add
c        timeout during reads (nos 2.2 level 602 or above only).
c        problems with the nos version should be directed to:
c
c           bill russell
c           new york university
c           courant institute of mathematical sciences
c           251 mercer street
c           ny, ny  10012
c
c           arpa:  [e-mail]
c           uucp:  ...!allegra!cmcl2!russell
c
c     2.0   4/17/84  jim knutson, university of texas at austin
c        fix filename packet to send uppercase file names only.
c        cleanup error packet handling (added to state table handlers).
c        fix retry counts to use proper number. modify character tables.
c        merge ric anderson's nos/be code.  try to organize the
c        source a little better.  added push and ! commands.
c        add read delay for performance tuning.  changed nel back to
c        205b.  the binary data-mode ignores nel though.
c        ut2d requires the nel be a 205b.  changed character tables
c        to use octal constants for non-representable characters.
c
c     1.1   01/21/84  ric anderson, university of arizona at tuscon
c        add ovcaps for installation in nucleus.  add display code
c        support.  remove gobs and gobs of field length.  changed
c        nel to 4012b to avoid confusion with data byte.  updated
c        character tables for 63 and 64 character sets.  changed
c        percents in fprintfs to at-signs since 63 character set has
c        no percent sign.
c
c     1.0   10/14/83  jim knutson, university of texas at austin
c        original implementation.
c
c     jim knutson
c     computation center room 1
c     univerisity of texas
c     austin, tx   78712
c
c     aprpanet address:  knutson@ut-ngp
c
c     special thanks to king ables for his contribution.
c
c     modified for nos/be by ric anderson
c     university of arizona
c     computer center
c     tucson, arizona 85721
c
c
c     future enhancements:
c        8th bit quoting
c        repeat counts
c        wild card sends
c        conditional code generation for i/o checks
c
c
c     build sequence:
c        build an update oplpl from the source file.
c        create the compile file, changing the site parameter in the
c           common deck comcker.  also use *defines for ovcaps vs.
c           segload version and site dependent compass.  see
c           implementation notes.
c        for the ovcap version:
c           ftn5,i,opt=2.
c           ftn5,i,opt=2,b=librel.
c           libgen,p=kermlib,f=librel.
c           load,lgo.
c           nogo,kermit.
c        for the segload version:
c           ftn5,i,opt=2.
c           segload,i=segdef,b=kermit.
c           load,lgo.
c           nogo.
c        load it with the following segload directives:
c          tree     kermit-(set,hlpcmd,execmd,server-(receive,send))
c set      include  show,status,match,setval
c receive  include  rinit,rfile,rdata
c send     include  sinit,sfile,sdata,seof,sbreak
c kermit   global   proto,packet,debug,message,fileio,fileioc
c          end      kermit
c
c     implementation notes:
c
c        there are now two versions available for kermit.  one uses
c        segload the other uses ovcaps.  only the ovcap version may
c        be installed on the system nucleus (cld for you ut2d fans).
c        the default version you get from update is for segload.
c        the ovcap version may be obtained by using the update
c        directive *define,ovcap.

c        the following defines have also been setup to select character
c        set, operating system, and site.  nos sites still need to
c        modify the nosver and noslvl parameter in deck comcker.
c
c           *define cset (63cset, 641cset, 642cset)
c           *define opsys (ut2d, nos, nosbe, scope)
c           *define site (utexas, uariz, other)
c
c        this version of kermit should be portable to other cdc sites
c        except for the above mentioned conditional updates and the
c        following cases.
c
c        the delay subroutine uses subroutine rtime to return the system
c        real time clock (number of jifs since deadstart).  nos and
c        nos/be rtime macros allegedly return slightly different
c        formats of data, so nos sites may need to modify delay().
c
c        the server knows how to logout on ut2d and nos/be sites.
c        ut2d uses a local funtion called bellc to perform this.  nos/be
c        and nos sites use a function to essentially pcc a logout
c        control command.  for nos sites, only those running level
c        596 or above may logout.  see subroutine logout().
c
c        the ascii i/o is also probably not portable since
c        cdc does not really support ascii i/o yet.
c        ascii i/o on ut2d (univ. of texas op. sys.) is done by
c        setting bit 2**43 in fet+1.  the ascii character set that
c        is used is "8 in 12".  this is 8 bits of an ascii character
c        stored in a 12 bit byte.  nulls are represented as 4000b,
c        and the newline character (nel) is 205b.  this is slightly
c        different from the cdc end-of-line which is 0000b in the
c        low order byte of the word.  currently, 0000b bytes are ignored
c        since nulls are guarded.
c
c        the display code character mappings for ut2d are different
c        than the 64 and 63 character set (sigh).  these should
c        already be taken care of in the conditional compilation.
c
c        sites that modify kermit to run on their system should
c        modify the appropriate parameter definition to allow
c        conditional compilation for their site.  try to be
c        as general as you can when making mods.
c
c        ****** above all send your mods back to ut *******
c
c     kermit i/o considerations:
c
c        kermit uses two modes of i/o.  it does coded i/o when reading
c        from the terminal to get commands.  this causes the front
c        end to map the cr/lf pair into a single nel character.
c        normal cyber sites will have the nel character added for
c        them by the subroutine findeol.
c        command editing (backspace and cancel)  and parity is taken
c        careof by the front-end.  binary i/o is used when reading
c        and sending packets.  this allows kermit to control the
c        parity bit.  other nos sites may have to set transparent mode
c        to do this.  binary i/o also causes no command editing to be
c        done (backspaces are treated as regular ascii characters) and
c        cr/lf is not mapped to nel. rawmode is a mode internal
c        to kermit that causes no cr/lf <-> nel mapping.
c
c        kermit opens two files (stdin and stdout) and connects
c        them to the terminal for doing the ascii i/o.  this was
c        done to prevent problems with trying to buffer reads and
c        writes to the same file.  when reading/writing disk files,
c        kermit will try to buffer 2 disk sectors (128 words) worth
c        of data per read/write.  this was changed from the 8 disk
c        sectors (512 words) since this reduced wasted space for
c        the terminal files and helped reduce field length.
c        all i/o is done through interface routines to the compass
c        i/o macros.
c
c        the only implementation dependent i/o routines should be
c        the compass i/o interface routines, stty() and perhaps
c        the rtime() subroutine.
c        see these routines for more info on what they do.
c
c     subroutine ordering:
c        main program and initialization
c           kermit
c           blkdat.
c           exitpgm
c           abtp
c        kermit command subroutines
c           execmd
c           hlpcmd
c           rcvfile
c           sndfile
c           set
c           show
c           status
c           server
c
c        kermlib routines:
c
c           dmodcmd
c           dbugcmd
c           setpack
c           dplxcmd
c           parcmd
c        command parsing subroutines
c           match
c           outtbl
c           setval
c           confirm
c        server subroutines
c           logout
c        kermit receive state protocol subroutines
c           receive
c           rinit
c           rfile
c           rdata
c        kermit send state protocol subroutines
c           send
c           sinit
c           sfile
c           sdata
c           seof
c           sbreak
c        packet i/o subroutines
c           sndpack
c           rdpack
c           buffill
c           bufemp
c        standard i/o subroutines
c           fopen
c           fclose
c           fflush
c           getc
c           ungetc
c           getword
c           putc
c           fread
c           fwrite
c           putstr
c           putint
c           putday
c           putmnth
c           fprintf
c           sprintf
c           doprnt
c           stty
c           gtty
c        utility subroutines
c           as2dpc
c           asc
c           dpc2as
c           ctoi
c           itos
c           getemsg
c           creat
c           getnow
c           filchk
c           rdparam
c           remove
c           strcpy
c           slen
c           sndpar
c           sleep
c           delay
c        nos/be utility modules.
c           echoplx
c           getrec
c           findeol
c           edl
c           cfe
c           getrec
c        nos utility routines
c           conbuff
c
*call kermcom
      logical cfe
      external exitpgm
      parameter (tsize=11)
      character*10 cmd(tsize)
      data cmd / 'exit', 'help', 'push', 'quit', 'receive', 'send',
     +    'server', 'set', 'show', 'status', '!' /

c
c     insure we are an interactive job.
c
c$    if (nosbe .eq. 1) then
      call xgjo(ipriv,iorig)
      if(iorig .ne. 3) then
          call remark(' kermit - incorrect job origin.')
          call abtp("nd,s")
      endif
c$    endif
c$    if (ut2d .eq. 1)
      call jobinfo(11,iorig)
      if ((iorig.and.4) .ne. 4) then
         call remark(' kermit - incorrect job origin.')
         call abtp("nd,s")
      endif
c$    endif
c
c     if running from a system library, set infinite cpu
c     time limit for this job step.
c
c$    if (nosbe .eq. 1) then
      if(ipriv .eq. -1) call entl(o"77777")
c$    endif
c
c     if running under nos - initialize kermit.
c
c$    if (nos .eq. 1)
      call nosinit
c$    endif
c
c     open the i/o files
c
      if (fopen('stdin',rd) .ne. stdin) then
         call displa(' cannot open standard input')
         call abtp("nd")
      else if (fopen('stdout',wr) .ne. stdout) then
         call displa(' cannot open standard output')
         call abtp("nd")
      endif
c
c     read in environment if needed
c
      if (cfe('zzzzken')) then
         cfd = fopen('zzzzken',rd)
         if (cfd .eq. error) then
            call displa(' cannot open temp file')
         else
            call fread(cfd,header,locf(trailer)-locf(header))
            call fclose(cfd)
         endif
         call retfile('zzzzken')
      endif
c
c     make sure things get fixed during aborts
c
c$    if (nos .eq. 1)
      call recovr(exitpgm,o"277",0)
c$    else
      call recovr(exitpgm,o"77",0)
c$    endif
c
c     parse and execute any commands
c
5     call fprintf(stdout,'^kermit-170>',0,0,0,0)
      call fflush(stdout)
c$    if (nos .eq. 1)
c
c     if running under nos - issue memory status message.
c
      call writer(fets(0,stdout))
      call memstat
c$    endif
      call fflush(stdin)
      indx = match(cmd,tsize,.true.)
      if (indx .eq. error .or. indx .eq. 0) go to 5
      if (indx .eq. eof) then
          normal = .true.
          call exitpgm
      endif
      go to (10, 20, 30, 10, 40, 50, 60, 70, 80, 90, 100), indx
c
c     thats all folks
c
10    normal = .true.
      call exitpgm
c
c     give some help
c
*if def,ovcap
20    call xovcap('kermhlp')
      call uovcap('kermhlp')
*endif
*if -def,ovcap
20    call hlpcmd
*endif
      go to 5
c
c     same as exit and quit but allows you to reenter with
c     the same environment as before
c
30    autoret = no
*if def,ovcap
      call xovcap('kermxcc')
      call uovcap('kermxcc')
*endif
*if -def,ovcap
      call execmd
*endif
      go to 5
c
c     receive a file
c
*if def,ovcap
40    call xovcap('kermrcv')
      call uovcap('kermrcv')
*endif
*if -def,ovcap
40    call rcvfile
*endif
      go to 5
c
c     send a file
c
*if def,ovcap
50    call xovcap('kermsnd')
      call uovcap('kermsnd')
*endif
*if -def,ovcap
50    call sndfile
*endif
      go to 5
c
c     enter server mode
c
*if def,ovcap
60    call xovcap('kermsrv')
      call uovcap('kermsrv')
*endif
*if -def,ovcap
60    call server
*endif
      go to 5
c
c     set some attributes
c
*if def,ovcap
70    call xovcap('kermset')
      call uovcap('kermset')
*endif
*if -def,ovcap
70    call set
*endif
      go to 5
c
c     show current settings
c
*if def,ovcap
80    call xovcap('kermsho')
      call uovcap('kermsho')
*endif
*if -def,ovcap
80    call show
*endif
      go to 5
c
c     give the status of last transfer
c
*if def,ovcap
90    call xovcap('kermsta')
      call uovcap('kermsta')
*endif
*if -def,ovcap
90    call status
*endif
      go to 5
c
c     exec a control command
c
100   autoret = yes
*if def,ovcap
      call xovcap('kermxcc')
      call uovcap('kermxcc')
*endif
*if -def,ovcap
      call execmd
*endif
      go to 5
      end
      block data
*call comcker


      data fmode / maxfile*closed /
      data fwptr,fnwds / maxfile*0, maxfile*0 /
      data rawmode, binmode / 2*.false. /
      data parity, duplex / nopar, fulldup /
      data dskcset / dskdpc /
      data normal / .false. /
      data ifd, ofd         / stdin, stdout /
      data ffd              / 0 /
      data maxrtry, maxrini / maxtry, maxinit /
      data packnum          / 0 /
      data startim, endtim  / 2*0 /
      data schcnt , rchcnt  / 2*0 /
      data schovrh, rchovrh / 2*0 /
      data state            / c /
      data delayfp          / 5 /
      data rdelay           / 100 /
      data sync   , sndsync / 2*soh /
      data packsiz, spksiz  / 2*maxpack /
      data timeout, stimout / 2*mytime  /
      data npad   , spad    / 2*mypad   /
      data padch  , spadch  / 2*mypadch /
      data eolch  , speol   / 2*myeol   /
      data quotech, spquote / 2*myquote /
      data quote8 , s8quote / 2*quot8ch /
      data chktyp , schktyp / 2*mycktyp /
      data rprefix, srepeat / 2*prefxch /
      data debug  , debugfd / dbgoff, 0 /
      data debugfn          / 75, 69, 82, 77, 76, 79, 71, 0 /
c                              k   e   r   m   l   o   g
      data (errmsg(i),i=1,14) / 63, 75, 101, 114, 109, 105, 116, 45, 49,
c                             ?   k    e    r    m    i    t   -   1
     +                       55, 48, 58, 2*32 /
c                             7   0   :
      data version / '^cyber-170 ^k^e^r^m^i^t version 2.2\n' /
      data ambig   / '?^ambiguous - "' /
      data nomatch / '?^does not match switch or keyword - "' /
      data follow  / '^one of the following:\n' /
      data nodigit /
     +   '?^invalid, ^first nonspace character is not a digit\n' /
      data missing / '?^invalid, ^missing parameter\n' /
      data confmsg / '^confirm with a carriage return\n' /
      data notconf / '?^not confirmed - "' /
      data hlpasch / '^decimal, octal (^b), or hexidecimal (^h) code for
     + ^a^s^c^i^i character \n' /
      data hlpdlfp / '^number of seconds to delay first packet\n' /
      data hlpdbfn / '^debug output logfile specification\n' /
      data hlpplen / '^maximum packet length\n' /
      data hlppadl / '^number of pad characters to use\n' /
      data hlpiprc / '^initial packet retry count\n' /
      data hlpprtr / '^packet retry count\n' /
      data hlptimo / '^number of seconds to wait before timeout\n' /
      data hlpsnfn / '^filename to send\n' /
      data hlprdel / '^milliseconds to delay each ^t^t^y read\n' /

c$    if (ut2d .eq. 1)
      data dpctbl/r" ",31*r" ",r" ",r"!",r"""",o"65",r"$",o"71",r"&",
     +            o"64",r"(",r")",r"*",r"+",r",",r"-",r".",r"/",r"0",
     +            r"1",r"2",r"3",r"4",r"5",r"6",r"7",r"8",r"9",
     +            o"63",r";",r"<",r"=",r">",o"75",r"@",
     +            r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i",
     +            r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r",
     +            r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z",
     +            r"[",o"76",r"]",o"70",r" ",r" ",
     +            r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i",
     +            r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r",
     +            r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z",
     +            5*r" "/
      data lascii/0,97,98,99,100,101,102,103,104,105,106,107,108,109,
c                    a  b  c   d   e   f   g   h   i   j   k   l   m
     +            110,111,112,113,114,115,116,117,118,119,120,121,122,
c                   n   o   p   q   r   s   t   u   v   w   x   y   z
     +            48,49,50,51,52,53,54,55,56,57,
c                  0  1  2  3  4  5  6  7  8  9
     +            43,45,42,47,40,41,36,61,32,44,46,34,91,93,58,
c                  +  -  *  /  (  )  $  =     ,  .  "  [  ]  :
     +            39,35,33,38,94,37,60,62,64,63,92,59/
c                  '  #  !  &  ^  <pct>  <  >  @  ?  \  ;
      data uascii/0,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,
c                    a  b  c  d  e  f  g  h  i  j  k  l  m  n  o  p  q
     +            82,83,84,85,86,87,88,89,90,48,49,50,51,52,53,54,55,
c                 r  s  t  u  v  w  x  y  z  0  1  2  3  4  5  6  7
     +            56,57,43,45,42,47,40,41,36,61,32,44,46,34,91,93,58,
c                 8  9  +  -  *  /  (  )  $  =     ,  .  "  [  ]  :
     +            39,35,33,38,94,37,60,62,64,63,92,59/
c                   '  #  !  &  ^  <pct>  <  >  @  ?  \  ;
c$    else
c$      if(ipcset .eq. ipc63)
        data dpctbl/r" ",31*r" ",r" ",r"!",r"""",o"60",r"$",r" ",r"&",
     +              o"70",r"(",r")",r"*",r"+",r",",r"-",r".",r"/",r"0",
     +              r"1",r"2",r"3",r"4",r"5",r"6",r"7",r"8",r"9",
     +              o"63",r";",r"<",r"=",r">",o"71",r"@",
     +              r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i",
     +              r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r",
     +              r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z",
     +              r"[",o"75",r"]",o"76",o"65",r"@",
     +              r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i",
     +              r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r",
     +              r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z",
     +              r"[",r"\",r"]",r"^",r" "/
        data lascii/32,97,98,99,100,101,102,103,104,105,106,107,108,109,
c                       a  b  c   d   e   f   g   h   i   j   k   l   m
     +              110,111,112,113,114,115,116,117,118,119,120,121,122,
c                     n   o   p   q   r   s   t   u   v   w   x   y   z
     +              48,49,50,51,52,53,54,55,56,57,
c                    0  1  2  3  4  5  6  7  8  9
     +              43,45,42,47,40,41,36,61,32,44,46,35,91,93,58,
c                    +  -  *  /  (  )  $  =     ,  .  %  [  ]  :
     +              34,95,33,38,39,63,60,62,64,92,94,59/
c                    "  #  !  &  '  ?  <  >  @  \  ^  ;
        data uascii/32,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,
c                       a  b  c  d  e  f  g  h  i  j  k  l  m  n  o  p
     +              81,82,83,84,85,86,87,88,89,90,48,49,50,51,52,53,54,
c                    q  r  s  t  u  v  w  x  y  z  0  1  2  3  4  5  6
     +              55,56,57,43,45,42,47,40,41,36,61,32,44,46,35,91,93,
c                    7  8  9  +  -  *  /  (  )  $  =     ,  .  %  [  ]
     +              58,34,95,33,38,39,63,60,62,64,92,94,59/
c                    :  "  #  !  &  '  ?  <  >  @  \  ^  ;
c$      else
        data dpctbl/r" ",31*r" ",r" ",r"!",r"""",o"60",r"$",o"63",r"&",
     +              o"70",r"(",r")",r"*",r"+",r",",r"-",r".",r"/",r"0",
     +              r"1",r"2",r"3",r"4",r"5",r"6",r"7",r"8",r"9",
     +              o"0",r";",r"<",r"=",r">",o"71",r"@",
     +              r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i",
     +              r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r",
     +              r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z",
     +              r"[",o"75",r"]",o"76",o"65",r"@",
     +              r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i",
     +              r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r",
     +              r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z",
     +              r"[",r"\",r"]",r"^",r" "/
        data lascii/58,97,98,99,100,101,102,103,104,105,106,107,108,109,
c                    :  a  b  c   d   e   f   g   h   i   j   k   l   m
     +              110,111,112,113,114,115,116,117,118,119,120,121,122,
c                     n   o   p   q   r   s   t   u   v   w   x   y   z
     +              48,49,50,51,52,53,54,55,56,57,
c                    0  1  2  3  4  5  6  7  8  9
     +              43,45,42,47,40,41,36,61,32,44,46,35,91,93,37,
c                    +  -  *  /  (  )  $  =     ,  .  %  [  ]  <pct>
     +              34,95,33,38,39,63,60,62,64,92,94,59/
c                    "  #  !  &  '  ?  <  >  @  \  ^  ;
        data uascii/58,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,
c                    :  a  b  c  d  e  f  g  h  i  j  k  l  m  n  o  p
     +              81,82,83,84,85,86,87,88,89,90,48,49,50,51,52,53,54,
c                    q  r  s  t  u  v  w  x  y  z  0  1  2  3  4  5  6
     +              55,56,57,43,45,42,47,40,41,36,61,32,44,46,35,91,93,
c                    7  8  9  +  -  *  /  (  )  $  =     ,  .  %  [  ]
     +              37,34,95,33,38,39,63,60,62,64,92,94,59/
c                <pct>  "  #  !  &  '  ?  <  >  @  \  ^  ;
c$      endif
c$    endif
      end
      subroutine exitpgm

ccc   exitpgm - exit the program
c
*call kermcom
c
c     set complete bit in all fets, in case we died in mid-cio call.
c
      if(.not. normal) then
          call remark (' kermit aborted.')
          do 10 i = 1, maxfile
              fets(0,i) = or(fets(0,i),1)
10        continue
      endif

      call fflush(stdout)
      call stty('raw',off)
      call stty('binary',off)
      if (savedpx .ne. halfdup) call stty('duplex',fulldup)
      call fclose(stdin)
      call fclose(stdout)
      if (debugfd.ne.0) call fclose(debugfd)
c
c     if running under nos - issue memory status message.
c
c$    if (nos .eq. 1)
      call nosexit
c$    else
      call endrun
c$    endif

      end
      subroutine abtp(type)

cc    abtp - abort program.
c
c     this subroutine should not return.
c
*call kermcom
      boolean type
c$    if (ut2d .eq. 1) then
      call abort
c$    else
      call abort(type)
c$    endif
      return
      end
*if def,ovcap
          ident    kermxcc
          entry    kermxcc
          lcc      ovcap.
          ldset    noept=unlfile
kermxcc   title    kermxcc - kermit execute control command processor.
          comment kermxcc - kermit execute control command processor.
kermxcc   space    4,10
**        kermxcc - kermit execute control command processor.
*
kermxcc   subr                     entry/exit
          rj       =xexecmd        call the real workhorse
          eq       kermxccx        return

          end
*endif
      subroutine execmd

ccc   execmd - execute a control command
c
c     execute a control command and return to command mode or
c     exit to the operating system.  next execution of kermit
c     will return with current environment.  this subroutine
c     does not return.
c
*call kermcom
      logical confirm, eatline
c$    if (nos .eq. 1)
c
c     if running under nos - issue memory status message.
c
      call memstat
c$    endif
c
c     before we do anything rash
c
      if (autoret .eq. no) then
         if (.not. confirm(stdin)) return
      endif
c
c     write out the current environment
c
      call retfile('zzzzken')
      cfd = fopen('zzzzken',wr)
      if (cfd .eq. error) then
         call remark(' cannot create environment file.')
         return
      endif
      call fwrite(cfd,header,locf(trailer)-locf(header))
      call fclose(cfd)
c
c     if only exit to the operating system
c
      if (autoret .eq. no) then
         normal = .true.
         call exitpgm
      endif
c
c     write the control command file
c
      dskcset = dskdpc
      call retfile('zzzzkcc')
      fd = fopen('zzzzkcc',create)
      if (fd .eq. error) then
         call remark(' cannot create ccl file.')
         fd = closed
         return
      endif
c$    if (nos .eq. 1 .or. nosbe .eq. 1)
      call fprintf(fd, '.proc,zzzzkcc.\n',0,0,0,0)
c$    endif
c
c     copy command to command file
c
      eatline = .false.
10    if (getc(stdin,ch) .eq. blank) then
         go to 10
      else
         if (ch .eq. qmark) then
            eatline = .true.
            call fprintf(stdout,'^monitor command to execute\n',0,0,0,0)
c$          if (nos .eq. 1)
            call fflush(stdout)
            call writer(fets(0,stdout))
c$          endif
         else
            call putc(ch,fd)
         endif
      endif
20    ch = getc(stdin,ch)
      if (.not. eatline) call putc(ch,fd)
      if (ch .ne. nel) go to 20
c
c     copy cleanup commands to command file
c
c$    if (nosbe .eq. 1) then
      call fprintf(fd,'skip(ok)\nexit(s)\nendif(ok)\n' //
     +  'return(zzzzkcc)\nkermit.\n',0,0,0,0)
c$    endif
c$    if (ut2d .eq. 1)
      call fprintf(fd,'.skipcc\n.exit\n.return zzzzkcc\n.kermit\n',
     +             0,0,0,0)
c$    endif
c$    if (nos .eq. 1)
      call fprintf(fd, 'return(zzzzkcc)\nrevert,ex.kermit.\n',
     +             0,0,0,0)
      call fprintf(fd, 'exit.\nreturn(zzzzkcc)\nrevert,ex.kermit.\n',
     +             0,0,0,0)
c$    endif
      call fclose(fd)
c
c     execute the command file
c
c$    if (nosbe .eq. 1) then
      call excst('begin,,zzzzkcc.')
c$    endif
c$    if (ut2d .eq. 1)
      call excst('.cntrl,zzzzkcc')
c$    endif
c$    if (nos .eq. 1)
      call excst('zzzzkcc.')
c$    endif
      end
*if def,ovcap
          ident  kermhlp
          entry  kermhlp
          lcc    ovcap.
          ldset  noept=unlfile
 kermhlp  title  kermhlp - kermit help command processor.
          comment kermit help command processor.
 kermhlp  space  4,10
**        kermhlp - kermit help command processor.


 kermhlp  subr               entry/exit
          rj     =xhlpcmd    call the real workhorse
          eq     kermhlpx    return

          end
*endif
      subroutine hlpcmd

ccc   hlpcmd - process the help command.
c
*call kermcom
      parameter (tsize=12)
      character*10 hlptyp(tsize)
      logical confirm
      data hlptyp / 'exit', 'help', 'kermit', 'push', 'quit', 'receive',
     +              'send', 'server', 'set', 'show', 'status', '!' /

c$    if (nos .eq. 1)
c
c     if running under nos - issue memory status message.
c
      call memstat
c$    endif
      indx = match(hlptyp,tsize,.true.)
      if (indx .eq. eof .or. indx .eq. error) return
      if (indx .eq. 0) go to 30
      if (.not. confirm(stdin)) return
      go to (10, 20, 30, 40, 10, 50, 60, 70, 80, 90, 100, 110), indx
c
c     help exit
c
10    call fprintf(stdout,'^exit from ^kermit-170\n')
      return
c
c     help help
c
20    call fprintf(stdout,'\n^h^e^l^p [topic]\n\n^typing ^h^e^l^p alone
     +prints a brief summary of ^kermit-170 and its commands.\n^you can
     +also type\n\n   ^h^e^l^p command\n\nfor any ^kermit-170 command, e
     +.g. "help send", to get more detailed information\nabout a specifi
     +c command.  ^type\n\n   ^h^e^l^p ?\n\nto see a list of all the ava
     +ilable help commands, or consult the ^kermit ^users\n^guide.\n\n')
      return
c
c     help kermit
c
30    call fprintf(stdout,'\n^kermit is a file transfer protocol for use
     + over an asynchronous serial\ntelecommunication line.  ^files are
     +broken up into "packets" with checksums and\nother control informa
     +tion to ensure (with high probability) error-free and\ncomplete tr
     +ansmission.\n\n^kermit-170 is the implementation for the ^cyber 17
     +0/730 and is\nrun "remotely" from another computer (e.g. a microco
     +mputer).\n\n^you can run ^kermit interactively by typing repeated
     +commands in response to\nits "^kermit-170>" prompt, or you can run
     + it as a remote server.\n\n^kermit-170 command summary -- optional
     + parts are in [brackets]:\n\n')
      call fprintf(stdout,'* ^for exchanging files:         ^s^e^n^d fil
     +e\n')
      call fprintf(stdout,'                                ^r^e^c^e^i^v^
     +e\n\n')
      call fprintf(stdout,'* ^for acting as a server:       ^s^e^r^v^e^r
     +\n\n')
      call fprintf(stdout,'* ^setting nonstandard transmission and file
     +parameters:\n        ^s^e^t ^d^e^b^u^g, ^d^e^l^a^y, ^d^u^p^l^e^x,
     +^p^a^r^i^t^y, ^i^n^i^t-^r^e^t^r^y, ^r^e^t^r^y\n')
      call fprintf(stdout,'        ^s^e^t ^s^e^n^d (or ^r^e^c^e^i^v^e) ^
     +end-of-^line, ^packet-length, ^pad-^character,\n                ^p
     +ad-^length, ^quote-^character, ^sync-^character, ^time-^out\n')
      call fprintf(stdout,'* ^getting information:          ^h^e^l^p [to
     +pic], ^s^t^a^t^u^s, ^s^h^o^w\n\n')
      call fprintf(stdout,'* ^leaving the program:          ^e^x^i^t, ^q
     +^u^i^t\n\n')
      call fprintf(stdout,'^for further information, type "help" for any
     + of the above, e.g. "help set",\nor see the "^kermit ^users ^guide
     +" and the "^kermit ^protocol ^manual" for complete\ndetails.\n\n')
      return
c
c     help push
c
40    call fprintf(stdout,'\n^p^u^s^h\n\n^exit from ^kermit-170 saving t
     +he current environment.  ^the environment will be\nrestored upon r
     +eentering ^kermit-170.\n')
      return
c
c     help receive
c
50    call fprintf(stdout,'\n^r^e^c^e^i^v^e\n\n^receive a file or group
     +of files from the other host.  ^if the name in the\n')
      call fprintf(stdout,'header packet is not a legal ^cyber file name
     +, the first 7 legal characters\n')
      call fprintf(stdout,'will be used.\n\n^if the file already exits a
     +s a local file, ^kermit will abort the transfer.\n')
      call fprintf(stdout,'^if an error occurs during transfer, the file
     + being received will be\nremoved from the local file list to allow
     + the transfer to be retried.\n')
      call fprintf(stdout,'^you should escape back to your local ^kermit
     + after entering ^r^e^c^e^i^v^e\nmode and give the ^s^e^n^d command
     +.\n\n')
      return
c
c     help send
c
60    call fprintf(stdout,'\n^s^e^n^d filename\n\n')
      call fprintf(stdout,'^send a file to the other host.  ^the name of
     + the file is passed\nto the other host in a file header packet, so
     + that the file can be\nstored there with the same name.\n\n')
      call fprintf(stdout,'^you should escape back to your local ^kermit
     + and give the ^r^e^c^e^i^v^e\ncommand.  ^if you don''t do this fas
     +t enough the "send-init" packet may\narrive prematurely.  ^to prev
     +ent this, use ^s^e^t ^d^e^l^a^y or hit the ^r^e^t^u^r^n key\non yo
     +ur microcomputer if it does not timeout.\n\n')
      return
c
c     help server
c
70    call fprintf(stdout,'\n^s^e^r^v^e^r\n\n')
c$    if(ut2d .eq. 1)
      call fprintf(stdout,'^act as a server for another ^kermit.  ^take
     +all further commands only from\nthe other ^kermit.  ^after issuing
     + this command, escape back to your local\nsystem and issue ^s^e^n^
     +d, ^r^e^c^e^i^v^e or ^g^e^t, ^b^y^e, or other server-oriented\ncom
     +mands from there.  ^if your local ^kermit does not have a ^b^y^e c
     +ommand,\nit does not have the full ability to communicate with a ^
     +kermit server (in\nwhich case you can only use the ^s^e^n^d comman
     +d).  ^if your local ^kermit\ndoes have a ^b^y^e command, use it to
     + shut down and log out the ^kermit\nserver when you are done with
     +it; otherwise, connect back to the ^cyber, type\nseveral ^control-
     +^c''s to stop the server, and logout.\n\n')
c$    else
c$    if(nosbe .eq. 1  .or.  scope .eq. 1)
      call fprintf(stdout,'^act as a server for another ^kermit.  ^take
     +all further commands only from\nthe other ^kermit.  ^after issuing
     + this command, escape back to your local\nsystem and issue ^s^e^n^
     +d, ^r^e^c^e^i^v^e or ^g^e^t, ^b^y^e, or other server-oriented\ncom
     +mands from there.  ^if your local ^kermit does not have a ^b^y^e c
     +ommand,\nit does not have the full ability to communicate with a ^
     +kermit server (in\nwhich case you can only use the ^s^e^n^d comman
     +d).  ^if your local ^kermit\ndoes have a ^b^y^e command, use it to
     + shut down and log out the ^kermit\nserver when you are done with
     +it; otherwise, connect back to the ^cyber, type\nseveral ^percent-
     +^a''s to stop the server, and logout.\n\n')
c$    else
      call fprintf(stdout,'^act as a server for another ^kermit.  ^take
     +all further commands only from\nthe other ^kermit.  ^after issuing
     + this command, escape back to your local\nsystem and issue ^s^e^n^
     +d, ^r^e^c^e^i^v^e or ^g^e^t, ^b^y^e, or other server-oriented\ncom
     +mands from there.  ^if your local ^kermit does not have a ^b^y^e c
     +ommand,\nit does not have the full ability to communicate with a ^
     +kermit server (in\nwhich case you can only use the ^s^e^n^d comman
     +d).  ^if your local ^kermit\ndoes have a ^b^y^e command, use it to
     + shut down and log out the ^kermit\nserver when you are done with
     +it; otherwise, connect back to the ^cyber, type\nseveral ^control-
     +^t''s to stop the server, and logout.\n\n')
c$    endif
c$    endif
      return
c
c     help set
c
80    call fprintf(stdout,'\n^s^e^t\n')
      call fprintf(stdout,'  ^establish system-dependent parameters.  ^y
     +ou can examine their values with the\n  ^s^h^o^w command.  ^numeri
     +c values may be decimal, octal (postfixed with a ^b),\n  or hexade
     +cimal (postfixed by an ^h).  ^the following may be ^s^e^t:\n\n')
      call fprintf(stdout,' ^d^a^t^a-^m^o^d^e keyword\n')
      call fprintf(stdout,'   ^declares the data mode to be used while p
     +rocessing disk files.  ^the choices\n   are ^a^s^c^i^i, ^d^i^s^p^l
     +^a^y, and ^image-^a^s^c^i^i.  ^a^s^c^i^i means the disk file conta
     +ins\n   ^a^s^c^i^i data, ^d^i^s^p^l^a^y means the file contains ^d
     +isplay ^code data, and ^image-\n   ^a^s^c^i^i means the file conta
     +ins 8-bit ^a^s^c^i^i data.  ^the default is ^d^i^s^p^l^a^y.\n\n')
      call fprintf(stdout,' ^d^e^b^u^g options\n   ^show packet traffic
     +explicitly.  ^options are:\n')
      call fprintf(stdout,'   ^a^l^l      ^set all debug options.\n')
      call fprintf(stdout,'   ^l^o^g-^f^i^l^e ^log states and packets to
     + the specified file.  ^the default\n            log-file is file ^
     +k^e^r^m^l^o^g.\n')
      call fprintf(stdout,'   ^o^f^f      ^don''t display debugging info
     +rmation (this is the default).  ^if\n            debugging was in
     +effect, turn it off and close any log file.\n')
      call fprintf(stdout,'   ^p^a^c^k^e^t^s  ^display each incoming and
     + outgoing packet (lengthy).\n')
      call fprintf(stdout,'   ^s^t^a^t^e^s   ^show kermit state transiti
     +ons and packet numbers (brief).\n\n')
      call fprintf(stdout,' ^d^e^l^a^y decimal-number\n')
      call fprintf(stdout,'   ^how many seconds to wait before sending t
     +he first packet.  ^this gives you\n   time to "escape" back and is
     +sue a ^r^e^c^e^i^v^e command.\n\n')
      call fprintf(stdout,' ^d^u^p^l^e^x keyword\n')
      call fprintf(stdout,'   ^changes the method of echoing characters
     +when being prompted for commands.\n   ^the choices are ^f^u^l^l an
     +d ^h^a^l^f.  ^full means the ^cyber will echo the\n   characters y
     +ou type.  ^half means the local systems echos them.  ^full is\n
     +the default, and is used by most hosts.\n\n')
      call fprintf(stdout,' ^i^n^i^t-^r^e^t^r^y decimal-number\n')
      call fprintf(stdout,'   ^set the maximum number of retries allowed
     + for the initial connection\n   before giving up.\n\n')
      call fprintf(stdout,' ^p^a^r^i^t^y keyword\n')
      call fprintf(stdout,'   ^if the other computer is using parity on
     +the communication line, you must\n   inform ^kermit-170, so it can
     + send the desired parity on outgoing characters,\n   and strip it
     +from incoming ones.\n')
      call fprintf(stdout,'\n   ^this must be set in ^kermit and the fro
     +nt-end.  ^see a system manual for\n   setting parity in the front-
     +end.\n')
      call fprintf(stdout,'\n   ^choices are ^n^o^n^e (the default), ^e^
     +v^e^n, ^o^d^d, ^m^a^r^k, and ^s^p^a^c^e.\n   ^n^o^n^e means no par
     +ity processing is done, and the 8th bit of each character\n   can
     +be used for data when transmitting binary files.\n\n')
      call fprintf(stdout,' ^r^d^e^l^a^y decimal-number\n')
      call fprintf(stdout,'   ^set the number of milliseconds of delay b
     +efore issuing a read to the\n   terminal.  ^this may be used to tu
     +ne reads so that data is ready\n   when the read function is issue
     +d and swapping does not take place.\n\n')
      call fprintf(stdout,' ^r^e^t^r^y decimal-number\n')
      call fprintf(stdout,'   ^set the maximum number of retries allowed
     + for sending a particular packet.\n\n')
      call fprintf(stdout,' ^s^e^n^d parameter\n   ^parameters for outgo
     +ing packets as follows:\n\n')
      call fprintf(stdout,'   ^end-of-^line octal-number\n')
      call fprintf(stdout,'     ^the octal value of the ^a^s^c^i^i chara
     +cter to be used as a line terminator\n     for packets, if one is
     +required by the other system.  ^carriage\n     return (15^b) by de
     +fault.\n\n')
      call fprintf(stdout,'   ^packet-^length decimal-number\n')
      call fprintf(stdout,'     ^maximum packet length to send, decimal
     +number, between 20 and 94,\n     94 by default.\n\n')
      call fprintf(stdout,'   ^pad-^character octal-number\n')
      call fprintf(stdout,'     ^character to use for padding.  ^default
     + is ^n^u^l.\n\n')
      call fprintf(stdout,'   ^pad-^length decimal-number\n')
      call fprintf(stdout,'     ^how much padding to send before a packe
     +t.  ^default is no padding.\n\n')
      call fprintf(stdout,'   ^quote-^character octal-number\n')
      call fprintf(stdout,'     ^what printable character to use for quo
     +ting of control characters.\n     ^the default is "#" (43^b).  ^th
     +ere should be no reason to change this.\n\n')
      call fprintf(stdout,'   ^sync-^character octal-number\n')
      call fprintf(stdout,'     ^the control character that marks the be
     +ginning of the packet.  ^normally\n     ^s^o^h (^control-^a, ^a^s^
     +c^i^i 1).  ^there should be no reason to change this.\n\n')
      call fprintf(stdout,'   ^time-^out decimal-number\n')
      call fprintf(stdout,'     ^how many seconds the other ^kermit want
     +s before being asked\n     for retransmission.  ^unfortunately, th
     +e ^cyber has no way of timing\n     out so this parameter is ignor
     +ed.\n\n')
      call fprintf(stdout,' ^r^e^c^e^i^v^e parameter\n   ^parameters to
     +request or expect for incoming packets, as follows:\n\n')
      call fprintf(stdout,'   ^end-of-^line octal-number\n')
      call fprintf(stdout,'     ^the octal value of the ^a^s^c^i^i chara
     +cter to be used as a line terminator\n     for packets, if one is
     +required by the other system.  ^carriage\n     return (15^b) by de
     +fault.\n\n')
      call fprintf(stdout,'   ^packet-^length decimal-number\n')
      call fprintf(stdout,'     ^maximum packet length to send, decimal
     +number, between 20 and 94,\n     94 by default.\n\n')
      call fprintf(stdout,'   ^pad-^character octal-number\n')
      call fprintf(stdout,'     ^character to use for padding.  ^default
     + is ^n^u^l.\n\n')
      call fprintf(stdout,'   ^pad-^length decimal-number\n')
      call fprintf(stdout,'     ^how much padding to send before a packe
     +t.  ^default is no padding.\n\n')
      call fprintf(stdout,'   ^quote-^character octal-number\n')
      call fprintf(stdout,'     ^what printable character to use for quo
     +ting of control characters.\n     ^the default is "#" (43^b).  the
     +re should be no reason to change this.\n\n')
      call fprintf(stdout,'   ^sync-^character octal-number\n')
      call fprintf(stdout,'     ^the control character that marks the be
     +ginning of the packet.  ^normally\n     ^s^o^h (^control-^a, ^a^s^
     +c^i^i 1).  ^there should be no reason to change this.\n\n')
      call fprintf(stdout,'   ^time-^out decimal-number\n')
      call fprintf(stdout,'     ^how many seconds the other ^kermit shou
     +ld wait for a packet before\n     asking for retransmission.\n\n')
      return
c
c     help show
c
90    call fprintf(stdout,'^display current ^s^e^t parameters, version o
     +f ^kermit-170, and other info.\n')
      return
c
c     help status
c
100   call fprintf(stdout,'^give statistics about the most recent file t
     +ransfer.\n')
      return
c
c     help !
c
110   call fprintf(stdout,'\n! ^monitor-^command\n\n^execute a monitor c
     +ommand from within ^kermit-170.  ^the current settings\nwill be pr
     +eserved.\n')
c$    if (nos .eq. 1)
      call fprintf(stdout,'\n^note: ^the command must be formmated corre
     +ctly with a ^n^o^s terminator [. or )].\n')
c$    endif
      return
      end
*if def,ovcap
          ident  kermrcv
          entry  kermrcv
          lcc    ovcap.
          ldset  noept=unlfile
 kermrcv  title  kermrcv - kermit receive file processor.
          comment kermit receive file processor.
 kermrcv  space  4,10
**        kermrcv - kermit receive file processor.


 kermrcv  subr               entry/exit
          rj     =xrcvfile   call the real workhorse
          eq     kermrcvx    return

          end
*endif
      subroutine rcvfile

ccc   rcvfile - top level subroutine to start receive state.
c
*call kermcom
      logical confirm
c$    if (nos .eq. 1)
c
c     if running under nos - issue memory status message.
c
      call memstat
c$    endif
c
c     confirm the command
c
      if (.not. confirm(stdin)) return
c
c     insure their is no junk in the file array.  this keeps remove
c     happy, in the event we blow off before we get a file spec.
c
      do 10 i = 1, maxpack
          filestr(i) = 0
10    continue

      call stty('binary',on)
      if(dskcset .eq. dskimag) call stty('raw',on)
      savedpx = gtty('duplex')
      call stty('duplex',halfdup)
      if (receive(r) .eq. ok) then
         call fprintf(stdout,'^receive complete.\n',0,0,0,0)
      else
         call fprintf(stdout,'^receive failed.\n',0,0,0,0)
      endif
      if(dskcset .eq. dskimag) call stty('raw',off)
      call stty('binary',off)
      if (savedpx .ne. halfdup) call stty('duplex',fulldup)
      return
      end
*if def,ovcap
          ident  kermsnd
          entry  kermsnd
          lcc    ovcap.
          ldset  noept=unlfile
 kermsnd  title  kermsnd - kermit send file processor.
          comment kermit send file processor.
 kermsnd  space  4,10
**        kermsnd - kermit send file processor.


 kermsnd  subr               entry/exit
          rj     =xsndfile   call the real workhorse
          eq     kermsndx    return

          end
*endif
      subroutine sndfile

ccc   sndfile - send a file to other kermit.
c
*call kermcom
      logical cfe
      character*10 lfn
c$    if (nos .eq. 1)
c
c     if running under nos - issue memory status message.
c
      call memstat
c$    endif
c
c     pick up the file name and save it for opening later
c
      call setval(filestr,'s',iret,7,0,0,hlpsnfn,.true.)
      if (iret .eq. error) return
c
c     make sure the name is legal.
c
      call as2dpc(filestr,lfn)
      if (xvfn(lfn) .ne. 0) then
         call fprintf(stdout,'?^illegal file name: @s.\n',filestr,0,0,0)
         return
      endif
c
c     map it to upper-case
c
      call dpc2as(lfn,filestr,slen(filestr))
c
c     check to make sure it's there to send
c
      if (.not. cfe(lfn)) then
         call fprintf(stdout,'?^file @s is not local.\n',filestr,0,0,0)
         return
      endif
c
c     delay the first packet
c
      if (delayfp .gt. 0) call sleep(delayfp)
      call stty('binary',on)
      if(dskcset .eq. dskimag) call stty('raw',on)
      savedpx = gtty('duplex')
      call stty('duplex',halfdup)
c
c     start sending packets
c
      packnum = 0
      if (send() .eq. ok) then
         call fprintf(stdout,'^send complete.\n',0,0,0,0)
      else
         call fprintf(stdout,'^send failed.\n',0,0,0,0)
      endif
      if(dskcset .eq. dskimag) call stty('raw',off)
      call stty('binary',off)
      if (savedpx .ne. halfdup) call stty('duplex',fulldup)
      return
      end
*if def,ovcap
          ident  kermset
          entry  kermset
          lcc    ovcap.
          ldset  noept=unlfile
 kermset  title  kermset - kermit set command processor.
          comment kermit set command processor.
 kermset  space  4,10
**        kermset - kermit set command processor.


 kermset  subr               entry/exit
          rj     =xset       call the real workhorse
          eq     kermsetx    return

          end
*endif
      subroutine set

ccc   set - set some attributes.
c
*call kermcom
      parameter (tsize=10)
      character*10 settyp(tsize)
      data settyp / 'data-mode', 'debug', 'delay', 'duplex',
     +    'init-retry', 'parity', 'receive', 'rdelay',
     +    'retry', 'send' /

c$    if (nos .eq. 1)
c
c     if running under nos - issue memory status message.
c
      call memstat
c$    endif
      indx = match(settyp,tsize,.false.)
      if (indx .le. 0) return
      go to (10, 20, 30, 40, 50, 60, 70, 75, 80, 90), indx
c
c     set character set
c
10    call dmodcmd
      return
c
c     set debugging modes
c
20    call dbugcmd
      return
c
c     set first packet delay
c
30    call setval(delayfp,'i',0,30,0,30,hlpdlfp,.true.)
      return
c
c     set the duplex
c
40    call dplxcmd
      return
c
c     set intial packet retry count
c
50    call setval(maxrini,'i',1,50,1,50,hlpiprc,.true.)
      return
c
c     set parity
c
60    call parcmd
      return
c
c     set receive packet attributes
c
70    call setpack(packsiz)
      return
c
c     set read data delay
c
75    call setval(rdelay,'i',0,2000,0,2000,hlprdel,.true.)
      return
c
c     set packet retry count
c
80    call setval(maxrtry,'i',1,50,1,50,hlpprtr,.true.)
      return
c
c     set send packet attributes
c
90    call setpack(spksiz)
      return
      end
*if def,ovcap
          ident  kermsho
          entry  kermsho
          lcc    ovcap.
          ldset  noept=unlfile
 kermsho  title  kermsho - kermit show command processor.
          comment kermit show command processor.
 kermsho  space  4,10
**        kermsho - kermit show command processor.


 kermsho  subr               entry/exit
          rj     =xshow      call the real workhorse
          eq     kermshox    return

          end
*endif
      subroutine show

ccc   show the current program settings
c
*call kermcom
      logical confirm
c$    if (nos .eq. 1)
c
c     if running under nos - issue memory status message.
c
      call memstat
c$    endif
c
c     confirm the command
c
      if (.not. confirm(stdin)) return
      call fprintf(stdout,version,0,0,0,0)
c$    if (nos .eq. 1)
      call fprintf(stdout,'^n^o^s ^version @d.@d - ^level @d ',
     +   nosver/10, (nosver-((nosver/10)*10)), noslvl, 0, 0)
c$    endif
c
c     display the current date and time
c
      call getnow(mm,dd,yy,hr,min,sec)
      call putday(stdout,mm,dd,yy)
      call fprintf(stdout,', ',0,0,0,0)
      call putmnth(stdout,mm)
      call fprintf(stdout,' @d, @d ',dd,yy,0,0)
      if (hr .lt. 10) call putc(asc('0'),stdout)
      call fprintf(stdout,'@d:',hr,0,0,0)
      if (min .lt. 10) call putc(asc('0'),stdout)
      call fprintf(stdout,'@d:',min,0,0,0)
      if (sec .lt. 10) call putc(asc('0'),stdout)
      call fprintf(stdout,'@d\n\n',sec,0,0,0)
c
c     display disk character set
c
      call fprintf(stdout,'  ^data-mode: ',0,0,0,0)
      if(dskcset .eq. dsknos8) then
          call fprintf(stdout,'^n^o^s 812 ^a^s^c^i^i\n',0,0,0,0)
      elseif(dskcset .eq. dskut8) then
          call fprintf(stdout,'^u^t 812 ^a^s^c^i^i\n',0,0,0,0)
      elseif(dskcset .eq. dskdpc) then
          call fprintf(stdout,'^display-^code\n',0,0,0,0)
      elseif(dskcset .eq. dskimag) then
          call fprintf(stdout,'^image-^a^s^c^i^i\n',0,0,0,0)
      else
          call fprintf(stdout,'^unknown',0,0,0,0)
      endif
c
c     display known parity
c
      call fprintf(stdout,'  ^parity:    ',0,0,0,0)
      parity = gtty('parity')
      if (parity .eq. none) then
         call fprintf(stdout,'^none\n',0,0,0,0)
      else if (parity .eq. even) then
         call fprintf(stdout,'^even\n',0,0,0,0)
      else if (parity .eq. odd) then
         call fprintf(stdout,'^odd\n',0,0,0,0)
      else if (parity .eq. mark) then
         call fprintf(stdout,'^mark\n',0,0,0,0)
      else if (parity .eq. space) then
         call fprintf(stdout,'^space\n',0,0,0,0)
      else
         call fprintf(stdout,'^unknown\n',0,0,0,0)
      endif
c
c     display the current duplex
c
      call fprintf(stdout,'  ^duplex:    ',0,0,0,0)
      duplex = gtty('duplex')
      if (duplex .eq. fulldup) then
         call fprintf(stdout,'^full\n',0,0,0,0)
      else if (duplex .eq. halfdup) then
         call fprintf(stdout,'^half\n',0,0,0,0)
      else
         call fprintf(stdout,'^unknown\n',0,0,0,0)
      endif
c
c     display current debug modes
c
      call fprintf(stdout,'  ^debugging: ',0,0,0,0)
      if ((debug.and.dbgstat).ne.0) call fprintf(stdout,'^states ',
     +   0,0,0,0)
      if ((debug.and.dbgpack).ne.0) call fprintf(stdout,'^packets',
     +   0,0,0,0)
      if (debug.eq.dbgoff) call fprintf(stdout,'^off',0,0,0,0)
      call putc(nel,stdout)
      if (debug .ne. dbgoff) then
         call fprintf(stdout,'   ^log file: @s\n',debugfn,0,0,0)
      endif
c
c     display packet settings
c
      call fprintf(stdout,'\n^packet ^parameters\n',0,0,0,0)
      call fprintf(stdout,
     +   '                    ^receive   ^send\n',0,0,0,0)
      call fprintf(stdout,'  ^size:             @d        @d\n',
     +   packsiz,spksiz,0,0)
      call fprintf(stdout,'  ^timeout:          @d        @d\n',
     +   timeout,stimout,0,0)
      call fprintf(stdout,'  ^padding:          @d',npad,0,0,0)
      if (npad .lt. 10) call putc(blank,stdout)
      call fprintf(stdout,'        @d\n',spad,0,0,0)
      call fprintf(stdout,'  ^pad character:    \^@c        \^@c\n',
     +   o"100".xor.(padch),o"100".xor.(spadch),0,0)
      call fprintf(stdout,'  ^end-of-^line:      \^@c        \^@c\n',
     +   o"100".xor.(eolch),o"100".xor.(speol),0,0)
      call fprintf(stdout,'  ^control quote:    @c         @c\n',
     +   quotech,spquote,0,0)
      call fprintf(stdout,'  ^start-of-^packet:  \^@c        \^@c\n',
     +   o"100".xor.(sync),o"100".xor.(sndsync),0,0)
c
c     display protocol stuff
c
      call fprintf(stdout,'\n^delay before sending first packet: @d\n',
     +   delayfp,0,0,0)
      call fprintf(stdout,
     +  '^delay @d milliseconds before each ^t^t^y read\n',rdelay,0,0,0)
      call fprintf(stdout,'^init packet retry count: @d\n',maxrini,0,0,
     +   0)
      call fprintf(stdout,'^packet retry count: @d\n\n',maxrtry,0,0,0)
      return
      end
*if def,ovcap
          ident  kermsta
          entry  kermsta
          lcc    ovcap.
          ldset  noept=unlfile
 kermsta  title  kermsta - kermit status command processor.
          comment kermit status command processor.
 kermsta  space  4,10
**        kermsta - kermit status command processor.


 kermsta  subr               entry/exit
          rj     =xstatus    call the real workhorse
          eq     kermstax    return

          end
*endif
      subroutine status

ccc   status - tell how long last transfer took.
c
*call kermcom
      logical confirm
c$    if (nos .eq. 1)
c
c     if running under nos - issue memory status message.
c
      call memstat
c$    endif
c
c     confirm the command
c
      if (.not. confirm(stdin)) return
      call fprintf(stdout,
     +   '^max characters in packet: @d received; @d sent\n',packsiz,
     +   spksiz,0,0)
      if (endtim .lt. startim) endtim = endtim + 86400
      nsec = endtim - startim
      hr = nsec / 3600
      nsec = nsec - (hr * 3600)
      min = nsec / 60
      nsec = nsec - (min * 60)
      call fprintf(stdout,'^number of characters transmitted in ',
     +   0,0,0,0)
      if (hr .gt. 0) call fprintf(stdout,'@d hours ',hr,0,0,0)
      if (min .gt. 0) call fprintf(stdout,'@d minutes ',min,0,0,0)
      call fprintf(stdout,'@d seconds\n\n',nsec,0,0,0)
      call fprintf(stdout,'             ^sent:  @20d',schcnt,0,0,0)
      call fprintf(stdout,' ^overhead:  @d\n',schovrh,0,0,0)
      call fprintf(stdout,'         ^received:  @20d',rchcnt,0,0,0)
      call fprintf(stdout,' ^overhead:  @d\n',rchovrh,0,0,0)
      call fprintf(stdout,'^total transmitted:  @20d',schcnt+rchcnt,0,0,
     +   0)
      call fprintf(stdout,' ^overhead:  @d\n',schovrh+rchovrh,0,0,0)
      call fprintf(stdout,
     +   '^total characters transmitted per sec: @d\n',
     +   (schcnt+rchcnt) / (endtim-startim),0,0,0)
      call fprintf(stdout,
     +   '^effective data rate: @d baud\n', ((schcnt+rchcnt) -
     +   (schovrh+rchovrh)) / (endtim-startim) * 10,0,0,0)
      if (state .ne. c) then
         call getemsg(packet)
         call fprintf(stdout,'?^kermit:  @s\n',packet,0,0,0)
      endif
      return
      end
*if def,ovcap
          ident  kermsrv
          entry  kermsrv
          lcc    ovcap.
          ldset  noept=unlfile
 kermsrv  title  kermsrv - kermit server-mode processor.
          comment kermit server-mode processor.
 kermsrv  space  4,10
**        kermsrv - kermit server-mode processor.


 kermsrv  subr               entry/exit
          rj     =xserver    call the real workhorse
          eq     kermsrvx    return

          end
*endif
      subroutine server

ccc   server - start kermit server
c
c     the server currently knows about the send and receive packets
c     and also the generic kermit packets logout and finish.  using
c     logout can cause problem due to files not being made permanent
c     before leaving.  i suppose implementing system command packets
c     would allow files to be saved but what other kermit allows
c     system command packets and is there a standard what to
c     checkpoint programs on the cyber?
c
*call kermcom
      character*10 lfn
      logical confirm, cfe
c$    if (nos .eq. 1)
c
c     if running under nos - issue memory status message.
c
      call memstat
c$    endif
c
c     confirm the command
c
      if (.not. confirm(stdin)) return
c
c     initialize msg #, say no tries yet
c
      packnum = 0
      numtry = 0
      call fprintf(stdout,'[^kermit server running on ^cyber host.  ^ple
     +ase type your escape sequence to\n return to your local machine. ^
     +shut down the server by typing the ^kermit ^b^y^e \n command on yo
     +ur local machine.]\n',0,0,0,0)
c$    if (nos .eq. 1)
      call fflush(stdout)
c$    endif
      call stty('binary',on)
      savedpx = gtty('duplex')
      call stty('duplex',halfdup)
    1 ptyp = rdpack(len,num,recpack)
      if (ptyp .eq. s) then
         packnum = num
         call rdparam(recpack)
         i = sndpar(packet)
         call sndpack(y,packnum,i,packet)
         numtry = 0
         packnum = mod(packnum+1,64)
         recstat = receive(f)
         if (debug .ne. 0) then
            if (recstat .eq. error) then
               call fprintf(debugfd,'^receive failed.\n',0,0,0,0)
            else
               call fprintf(debugfd,'^receive completed.\n',0,0,0,0)
            endif
         endif
      else if (ptyp .eq. r) then
            i = 0
            call strcpy(recpack,filestr)
            call as2dpc(filestr,lfn)
            if (xvfn(lfn) .ne. 0) then
               abortyp = invfn
               call getemsg(errmsg(15))
               call sndpack(e,packnum,slen(errmsg),errmsg)
            else if (.not. cfe(lfn)) then
               abortyp = notlcl
               call getemsg(errmsg(15))
               call sndpack(e,packnum,slen(errmsg),errmsg)
            else
               sndstat = send()
               packnum = 0
               if (debug .ne. 0) then
                  if (sndstat .eq. error) then
                     call fprintf(debugfd,'^send failed.\n',0,0,0,0)
                  else
                     call fprintf(debugfd,'^send completed.\n',0,0,0,0)
                  endif
               endif
            endif
      else if (ptyp .eq. g) then
            if (recpack(1) .eq. l) then
               call sndpack(y,num,0,0)
               call logout
            else if (recpack(1) .eq. f) then
                  call sndpack(y,num,0,0)
                  normal = .true.
                  call exitpgm
            else
               abortyp = srvcmd
               call getemsg(errmsg(15))
               call sndpack(e,packnum,slen(errmsg),errmsg)
            endif
      else
         if (debug .ne. 0) call fprintf
     +     (debugfd,'server: invalid packet type: @d\n',ptyp,0,0,0)
         abortyp = invalid.or.reading.or.srvcmd
         call getemsg(errmsg(15))
         call sndpack(e,packnum,slen(errmsg),errmsg)
      endif
      go to 1
      end
*if def,ovcap
*cweor
*endif
*deck kermlib
      subroutine dmodcmd

ccc   dmodcmd - perform a set data-mode xxxx command.
c
*call kermcom
      logical confirm
c$    if (ut2d .eq. 1)
      parameter (tsize=4)
c$    endif
c$    if (ut2d .ne. 1)
      parameter (tsize=3)
c$    endif
      character*15 datatyp(tsize)
c$    if (ut2d .eq. 1)
      data datatyp /'ascii', 'display-code', 'image-ascii', 'nos-ascii'/
c$    endif
c$    if (ut2d .ne. 1)
      data datatyp / 'ascii', 'display-code', 'image-ascii' /
c$    endif
c
c     match the parameter.
c
      indx = match(datatyp,tsize,.false.)
      if (indx .le. 0) return
      if (.not. confirm(stdin)) return
c
c     take the appropriate action.
c
c$    if (ut2d .eq. 1)
      go to (10, 20, 30, 40), indx
c$    endif
c$    if (ut2d .ne. 1)
      go to (10, 20, 30), indx
c$    endif
c
c     set ascii character set.
c
c$    if (ut2d .eq. 1)
10    dskcset = dskut8
c$    endif
c$    if (ut2d .ne. 1)
10    dskcset = dsknos8
c$    endif
      return
c
c     set display character set.
c
20    dskcset = dskdpc
      return
c
c     set image data mode.
c
30    dskcset = dskimag
      return

c$    if (ut2d .eq. 1)
c
c     set nos 812 ascii
c
40    dskcset = dsknos8
      return
c$    endif
      end
      subroutine dbugcmd

ccc   dbugcmd - set the debugging modes.
c
*call kermcom
      character*10 fn
      logical confirm
      parameter (tsize=5)
      character*10 dbgtyp(tsize)
      data dbgtyp / 'all', 'log-file', 'off', 'packets', 'states' /

      indx = match(dbgtyp,tsize,.false.)
      if (indx .le. 0) return
      go to (10, 20, 30, 40, 50), indx
c
c     set all debug modes
c
10    if (.not. confirm(stdin)) return
      debug = dbgall
      go to 100
c
c     set debug logfile
c
20    call setval(debugfn,'s',iret,7,0,0,hlpdbfn,.true.)
      if (iret .eq. ok) then
         if (debugfd .ne. 0) then
            call fclose(debugfd)
            debugfd = 0
         endif
         go to 100
      endif
      return
c
c     turn off all debugging
c
30    if (.not. confirm(stdin)) return
      debug = dbgoff
      if (debugfd .ne. 0) then
         call fclose(debugfd)
         debugfd = 0
      endif
      return
c
c     toggle debug packets
c
40    if (.not. confirm(stdin)) return
      debug = debug .xor. dbgpack
      go to 100
c
c     toggle debug states
c
50    if (.not. confirm(stdin)) return
      debug = debug .xor. dbgstat
      go to 100
c
c     open the debug file if not done already
c
100   if (debugfd .eq. 0) then
         call as2dpc(debugfn,fn)
         debugfd = fopen(fn,wr)
      endif
      return
      end
      subroutine setpack(attr)

ccc   set packet send or receive attributes.
c
c     setpack will wet the attributes of the passed attribute
c     list.  this subroutine will set the appropriate packet
c     parameter.  the parameter to set is passed in an array
c     and is very order dependent.  see common block /packet/
c     for the ordering.  note that send and receive parameter
c     ordering and storage size in the common block are
c     identical.  keep it that way!
c
*call kermcom
      integer attr(12)
      parameter (tsize=7)
      character*15 attrtyp(tsize)
      data attrtyp / 'end-of-line', 'packet-length', 'pad-character',
     +               'pad-length', 'quote-character', 'sync-character',
     +               'time-out' /

      indx = match(attrtyp,tsize,.false.)
      if (indx .le. 0) return
      go to (10, 20, 30, 40, 50, 60, 70), indx
c
c     set eol character
c
10    call setval(attr(5),'i',1,31,127,127,hlpasch,.true.)
      return
c
c     set maximum packet length
c
20    call setval(attr(1),'i',20,94,20,94,hlpplen,.true.)
      return
c
c     set pad character
c
30    call setval(attr(4),'i',0,31,127,127,hlpasch,.true.)
      return
c
c     set pad length
c
40    call setval(attr(3),'i',0,94,0,94,hlppadl,.true.)
      return
c
c     set quote character
c
50    call setval(attr(6),'i',33,62,96,126,hlpasch,.true.)
      return
c
c     set sync character
c
60    call setval(attr(12),'i',0,127,0,127,hlpasch,.true.)
      return
c
c     set timeout value
c
70    call setval(attr(2),'i',0,94,0,94,hlptimo,.true.)
      return
      end
      subroutine dplxcmd

ccc   dplxcmd - perform a set duplex xxxx command
c
*call kermcom
      logical confirm
      parameter (tsize=2)
      character*10 duptyp(tsize)
      data duptyp / 'full', 'half' /
c
c     match the parameter
c
      indx = match(duptyp,tsize,.false.)
      if (indx .le. 0) return
      if (.not. confirm(stdin)) return
c
c     take the appropriate action
c
      go to (10, 20), indx
c
c     set full duplex
c
10    call stty('duplex',fulldup)
      return
c
c     set half duplex
c
20    call stty('duplex',halfdup)
      return
      end
      subroutine parcmd

ccc   parcmd - set the parity for terminal i/o.
c
*call kermcom
      logical confirm
      parameter (tsize=5)
      character*10 partyp(tsize)
      data partyp / 'even', 'mark', 'none', 'odd', 'space' /
c
c     match the parameter
c
      indx = match(partyp,tsize,.false.)
      if (indx .le. 0) return
      if (.not. confirm(stdin)) return
c
c     set the proper parity
c
      go to (10, 20, 30, 40, 50), indx
10    call stty('parity',even)
      return
20    call stty('parity',mark)
      return
30    call stty('parity',none)
      return
40    call stty('parity',odd)
      return
50    call stty('parity',space)
      return
      end
      integer function match(table,tablen,nelok)

ccc   match - match input with a table of possibilities.
c
c     table should be an array of character strings defining what
c     is reasonable input.  match will read input and return the
c     index of the table entry that matches or "error" if a proper
c     match couldn't be made.  matchs will fail if the input match
c     is ambiguous or doesn't match at all.  a question mark in the
c     input will output the possible matches according to the input
c     previously read and then return as if no match was made.
c
*call kermcom
      character*(*) table(tablen)
      logical nelok
      character*40 word
      integer astr(41)
c
c     get the word to match
c
      len = getword(stdin,astr,40)
      if (len .eq. 0 .or. len .eq. eof) then
         match = len
         if (len .eq. 0 .and. .not. nelok) then
            match = error
            call fprintf(stdout,'?^null switch or keyword given\n',0,0,
     +         0,0)
         endif
         call fflush(stdin)
         return
      endif
      call as2dpc(astr,word)
c
c     begin the matching here; tables must be in alphabetical order
c
      t1 = 1
      t2 = tablen
      chp = 1
10    if (chp .le. len) then
c
c        if we find a "?", then give the possibilities
c
         if (word(chp:chp) .eq. '?') then
            call fprintf(stdout,follow,0,0,0,0)
            call outtbl(table,t1,t2)
            call fflush(stdin)
            match = error
            return
         endif
c
c        while word is less than lower table entry
c
20       if (word(chp:chp) .gt. table(t1)(chp:chp) .and.
     +       t1 .le. t2) then
            t1 = t1 + 1
            go to 20
         endif
c
c        while word is greater than upper table entry
c
30       if (word(chp:chp) .lt. table(t2)(chp:chp) .and.
     +       t2 .ge. t1) then
            t2 = t2 - 1
            go to 30
         endif
c
c        if we know we have a mismatch
c
         if (t2 .lt. t1) then
            call fprintf(stdout,nomatch,0,0,0,0)
            call putstr(stdout,astr)
            call fprintf(stdout,'"\n',0,0,0,0)
            call fflush(stdin)
            match = error
            return
         endif
         chp = chp + 1
         go to 10
      endif
c
c     after looking at the whole word, is it still ambiguous?
c
      if (t1 .ne. t2) then
         call fprintf(stdout,ambig,0,0,0,0)
         call putstr(stdout,astr)
         call fprintf(stdout,'"\n',0,0,0,0)
         call fflush(stdin)
         match = error
      else
         match = t1
      endif
      return
      end
      subroutine outtbl(table,start,fin)

ccc   outtbl - output a string array in tabular format.
c
*call kermcom
      character*(*) table(fin)
      integer start, fin

      character*80 line
      integer astr(81)
      integer colwid, ncols

      colwid = len(table(1)) + 2
      ncols = 80 / colwid
      line = ' '
      icol = 1
      do 100 i = start,fin
         ipos = (icol-1)*colwid + 1
         line(ipos:) = table(i)
         icol = icol + 1
         if (icol .gt. ncols .or. i .eq. fin) then
            call dpc2as(line,astr,len(line))
c
c           delete trailing blanks
c
            j = len(line)
10          if (line(j:j) .eq. ' ') then
               astr(j) = 0
               j = j - 1
               go to 10
            endif
            call putstr(stdout,astr)
            call putc(nel,stdout)
            line = ' '
            icol = 1
         endif
100   continue
      return
      end
      subroutine setval(var,vtyp,mn1,mx1,mn2,mx2,hlpmsg,confrm)

ccc   setval - set a variable value.
c
c     setval will read a token from input and set a variable to
c     that value.  if the token is a question mark then the
c     help message will be displayed and setval will return
c     without setting a value.
c
c     entry:   (vtyp) = character 's' for string variable.
c                     = character 'i' for integer variable.
c              (mn1-mx1) = range #1 for var to fit in if integer.
c                        = mn1 is return code for error and mx1 is
c                          max size of string if string var.
c              (mn2-mx2) = secondary range for var to fit in if
c                          integer var.
c                        = unused for string var.
c              (hlpmsg) = fprintf message format to display if
c                       a question mark is read.
c
c     exit:    (var) = int value read if integer var. or string
c                      value read if string var.
c
*call kermcom
      character*(*) vtyp, hlpmsg
      integer var(41), str(41)
      logical confrm, confirm
c
c     check var type
c
      if (vtyp .ne. 's' .and. vtyp .ne. 'i') then
         call fprintf(stdout,'setval - invalid var type @c\n',asc(vtyp),
     +      0,0,0)
         return
      endif
      if (vtyp .eq. 's' .and. mx1 .gt. 40) then
         call fprintf(stdout,'setval - string max of @d is too large\n',
     +      mx1,0,0,0)
         return
      endif
      len = getword(stdin,str,mx1)
      if (len .eq. 0 .or. len .eq. eof) then
         if (vtyp .eq. 'i') then
            call fprintf(stdout,nodigit,0,0,0,0)
         else
            call fprintf(stdout,missing,0,0,0,0)
            mn1 = error
         endif
         return
      endif
      if (str(1) .eq. qmark) then
         call fprintf(stdout,hlpmsg,0,0,0,0)
         call fflush(stdin)
         if (vtyp .eq. 's') mn1 = error
         return
      endif
c
c     confirm the request if necessary
c
      if (confrm) then
         if (.not. confirm(stdin)) then
            if (vtyp .eq. 's') mn1 = error
            return
         endif
      endif
c
c     go ahead and set the variable
c
      if (vtyp .eq. 'i') then
         i = ctoi(str)
         if (i .ge. mn1 .and. i .le. mx1) then
            var(1) = i
         else if (i .ge. mn2 .and. i .le. mx2) then
            var(2) = i
         else
            call fprintf(stdout,
     +         '?^value is not within range of @d - @d',
     +         mn1,mx1,0,0)
            if (mn1 .ne. mn2 .or. mx1 .ne. mx2) call fprintf(stdout,
     +         ' or @d - @d',mn2,mx2,0,0)
            call putc(nel,stdout)
         endif
      else
         do 100 i = 1,len
            var(i) = str(i)
100      continue
         var(len+1) = 0
         mn1 = ok
      endif
      return
      end
      logical function confirm(fd)

ccc   confirm - look for a newline.
c
c     confirm will expect that the next token of input be a
c     newline for confirmation to be true.  if the next token
c     is a question mark, then confirmation is false and
c     a "confirm with a carriage return" message will be displayed.
c     any other text will cause a 'not confirmed "text"' message
c     to be displayed and confirm will return false.
c
*call kermcom
c
c     get leading blanks til a token is found
c
      confirm = .false.
10    if (getc(fd,ch) .eq. nel) then
         confirm = .true.
      else if (ch .eq. eof) then
         return
      else if (ch .eq. blank .or. ch .eq. tab) then
         go to 10
      else if (ch .eq. qmark) then
         call fprintf(stdout,confmsg,0,0,0,0)
      else
         call fprintf(stdout,notconf,0,0,0,0)
20       call putc(ch,stdout)
         ch = getc(fd,ch)
         if (ch .ne. nel .and. ch .ne. eof) go to 20
         call fprintf(stdout,'"\n',0,0,0,0)
      endif
      return
      end
      subroutine logout

ccc   logout - log out the job
c
c     this is site dependent.
*call kermcom
      iret = error
c$    if (ut2d .eq. 1)
      call bellc(l"logout",0,iret)
c$    endif
c$    if(nosbe .eq. 1)
      if(savedpx .ne. halfdup) call stty('duplex',fulldup)
      call excst('logout.')
c$    endif
c$    if(nos .eq. 1)
c$    if(noslvl .ge. 596)
      if(savedpx .ne. halfdup) call stty('duplex',fulldup)
      call excst('logout.')
c$    endif
c$    endif
      if (iret .ne. 0) call displa('logout error',iret)
      return
      end
      integer function receive(istate)

ccc   receive - receive file state switching routine.
c
*call kermcom
c
c     initialize statistics variables
c
      call getnow(mm,dd,yy,hr,min,sec)
      startim = hr * 3600 + min * 60 + sec
      schcnt = 0
      rchcnt = 0
      schovrh = 0
      rchovrh = 0
c
c     set packet retry count & current state
c
      numtry = 0
      state = istate
c
c     take appropriate action for the current state
c
10    if (state .eq. d) then
         state = rdata()
      else if (state .eq. f) then
         state = rfile()
      else if (state .eq. r) then
         state = rinit()
      else if (state .eq. c) then
         call getnow(mm,dd,yy,hr,min,sec)
         endtim = hr * 3600 + min * 60 + sec
         receive = ok
         return
      else if (state .eq. e) then
         receive = error
         if (ffd .ne. closed) then
            call fclose(ffd)
            call remove(filestr)
         endif
         return
      else if (state .eq. a) then
         call getnow(mm,dd,yy,hr,min,sec)
         endtim = hr * 3600 + min * 60 + sec
         receive = error
         if (ffd .ne. closed) then
            call fclose(ffd)
            call remove(filestr)
         endif
         call getemsg(errmsg(15))
         call sndpack(e,packnum,slen(errmsg),errmsg)
         return
      else
         call displa(' receive - state error = ',state)
         if (ffd .ne. closed) call fclose(ffd)
         receive = error
         return
      endif
      if ((debug.and.dbgstat).ne.0) then
         call fprintf(debugfd,'@c@2d ',state,packnum,0,0)
         if (mod(packnum+1,16) .eq. 0) call putc(nel,debugfd)
      endif
      go to 10
      end
      integer function rinit()

ccc   rinit - receive a send-init packet.
c
*call kermcom
c
c     clean out filestr array so remove does not do dire things
c     to the previously received file if we die before we get
c     the new file specification.
c
      do 10 i = 1, maxpack
          filestr(i) = 0
10    continue
c
c     check retry count
c
      if (numtry .gt. maxrini) then
         rinit = a
         abortyp = toomany.or.reading.or.initerr
         return
      endif
      numtry = numtry + 1
c
c     read a packet and hope for the best
c
      ptyp = rdpack(len,num,packet)
c
c     is it a valid packet type?
c
      if (ptyp .eq. s) then
         packnum = num
         call rdparam(packet)
         len = sndpar(packet)
         call sndpack(y,num,len,packet)
         numtry = 0
         packnum = mod(packnum+1,64)
         rinit = f
c
c     did we get a checksum error
c
      else if (ptyp .eq. error) then
         rinit = state
         call sndpack(n,num,0,0)
      else
         rinit = a
         abortyp = invalid.or.reading.or.initerr
      endif
      return
      end
      integer function rfile()

ccc   rfile  read a filename packet.
c
c     rfile expects to see a filename (type f) packet.  however, it may
c     find a send-init retry, end-of-file retry or break packet.
c
*call kermcom
      if (numtry .gt. maxrtry) then
         rfile = a
         abortyp = toomany.or.reading.or.filerr
         return
      endif
      numtry = numtry + 1
c
c     read a packet
c
      ptyp = rdpack(len,num,packet)
c
c     is it a filename packet?
c
      if (ptyp .eq. f) then
         if (num .ne. packnum) then
            rfile = a
            abortyp = seqerr.or.reading.or.filerr
            return
         endif
         ffd = creat(packet)
         if (ffd .eq. error) then
            ffd = closed
            rfile = a
            abortyp = lclfile.or.reading.or.filerr
         else
            if (debug .ne. 0) call fprintf(debugfd,
     +         '^receiving file @s\n',packet,0,0,0)
            call strcpy(packet,filestr)
            call sndpack(y,num,0,0)
            numtry = 0
            packnum = mod(packnum+1,64)
            rfile = d
         endif
c
c     is it an old send-init packet
c
      else if (ptyp .eq. s) then
         if (mod(num+1,64) .eq. packnum) then
            len = sndpar(packet)
            call sndpack(y,num,len,packet)
            numtry = 0
            rfile = state
         else
            rfile = a
            abortyp = seqerr.or.reading.or.initerr
         endif
c
c     is it an old eof packet?
c
      else if (ptyp .eq. z) then
         if (mod(num+1,64) .eq. packnum) then
            call sndpack(y,num,0,0)
            numtry = 0
            rfile = state
         else
            rfile = a
            abortyp = seqerr.or.reading.or.eoferr
         endif
c
c     is it a break packet?
c
      else if (ptyp .eq. b) then
         if (num .ne. packnum) then
            rfile = a
            abortyp = seqerr.or.reading.or.brkerr
         else
            call sndpack(y,packnum,0,0)
            rfile = c
         endif
c
c     did we get an error packet?
c
      else if (ptyp .eq. e) then
         rfile = e
         return
c
c     did we get a checksum error?
c
      else if (ptyp .eq. error) then
         rfile = state
         call sndpack(n,num,0,0)
c
c     invalid packet type, so abort
c
      else
         rfile = a
         abortyp = invalid.or.reading.or.filerr
      endif
      return
      end
      integer function rdata()

ccc   rdata - read a data packet.
c
*call kermcom
c
c     check retry count
c
      if (numtry .gt. maxrtry) then
         rdata = a
         abortyp = toomany.or.reading.or.dataerr
         return
      endif
      numtry = numtry + 1
c
c     read a packet
c
      ptyp = rdpack(len,num,packet)
c
c     did we get a data packet?
c
      if (ptyp .eq. d) then
         if (num .ne. packnum) then
            if (mod(num+1,64) .eq. packnum) then
               call sndpack(y,num,0,0)
               rdata = state
            else
               rdata = a
               abortyp = seqerr.or.reading.or.dataerr
            endif
         else
            call bufemp(packet,ffd,len)
            call sndpack(y,packnum,0,0)
            numtry = 0
            packnum = mod(packnum+1,64)
            rdata = state
         endif
c
c     is it an old filename packet?
c
      else if (ptyp .eq. f) then
         if (mod(num+1,64) .eq. packnum) then
            call sndpack(y,num,0,0)
            numtry = 0
            rdata = state
         else
            rdata = a
            abortyp = seqerr.or.reading.or.filerr
         endif
c
c     is it an eof packet?
c
      else if (ptyp .eq. z) then
         if (num .ne. packnum) then
            rdata = a
            abortyp = seqerr.or.reading.or.eoferr
         else
            call sndpack(y,packnum,0,0)
            call fclose(ffd)
            ffd = 0
            packnum = mod(packnum+1,64)
            rdata = f
         endif
c
c     did we get an error packet?
c
      else if (ptyp .eq. e) then
         rdata = e
         return
      else if (ptyp .eq. error) then
         rdata = state
         call sndpack(n,num,0,0)
      else
         rdata = a
         abortyp = invalid.or.reading.or.dataerr
      endif
      return
      end
      integer function send()

ccc   send - send file state switching routine
c
c     the filename to send is assumed to have already been
c     obtained and set in ascii string buffer filestr.
c
*call kermcom
c
c     initialize statics variables
c
      call getnow(mm,dd,yy,hr,min,sec)
      startim = hr * 3600 + min * 60 + sec
      schcnt = 0
      rchcnt = 0
      schovrh = 0
      rchovrh = 0
      state = s
      numtry = 0
c
c     take appropriate action for the current state
c
10    if (state .eq. d) then
         state = sdata()
      else if (state .eq. f) then
         state = sfile()
      else if (state .eq. z) then
         state = seof()
      else if (state .eq. s) then
         state = sinit()
      else if (state .eq. b) then
         state = sbreak()
      else if (state .eq. c) then
         call getnow(mm,dd,yy,hr,min,sec)
         endtim = hr * 3600 + min * 60 + sec
         send = ok
         return
      else if (state .eq. e) then
         call getnow(mm,dd,yy,hr,min,sec)
         endtim = hr * 3600 + min * 60 + sec
         send = error
         if (ffd .ne. closed) call fclose(ffd)
         return
      else if (state .eq. a) then
         call getnow(mm,dd,yy,hr,min,sec)
         endtim = hr * 3600 + min * 60 + sec
         send = error
         if (ffd .ne. closed) call fclose(ffd)
         call getemsg(errmsg(15))
         call sndpack(e,packnum,slen(errmsg),errmsg)
         return
      else
         call displa(' send - state error = ',state)
         send = error
         if (ffd .ne. closed) call fclose(ffd)
         return
      endif
      if ((debug.and.dbgstat).ne.0) then
         call fprintf(debugfd,'@c@2d ',state,packnum,0,0)
         if (mod(packnum+1,16) .eq. 0) call putc(nel,debugfd)
      endif
      go to 10
      end
      integer function sinit()

ccc   sinit - send the send-init packet and wait for reply.
c
c     assumes filestr has already been checked for legal filename
c     and being local.
c
*call kermcom
      character*10 filenam
c
c     check number of retries
c
      if (numtry .gt. maxrini) then
         sinit = a
         abortyp = toomany.or.sending.or.initerr
         return
      endif
      numtry = numtry + 1
c
c     send the send-init packet with the right info
c
      len = sndpar(packet)
      call sndpack(s,packnum,len,packet)
c
c     pick up and process the reply
c
      ptyp = rdpack(len,num,recpack)
      if (ptyp .eq. n) then
         sinit = state
         return
      else if (ptyp .eq. y) then
         if (packnum .ne. num) then
            sinit = state
            return
         endif
         call rdparam(recpack)
         numtry = 0
         packnum = mod(packnum+1,64)
         call as2dpc(filestr,filenam)
         ffd = fopen(filenam,rd)
         if (ffd .eq. error) then
            sinit = a
            ffd = closed
         else
            sinit = f
         endif
c
c     did we get an error packet?
c
      else if (ptyp .eq. e) then
         sinit = e
         return
      else if (ptyp .eq. error) then
         sinit = state
      else
         sinit = a
         abortyp = invalid.or.sending.or.initerr
      endif
      return
      end
      integer function sfile()

ccc   sfile - send a filename packet and wait for reply.
c
c     the filename is assumed to have been previously obtained
c     and stored in the ascii string buffer filestr in upper case.
c
*call kermcom
c
c     have we tried this too many times?
c
      if (numtry .gt. maxrtry) then
         sfile = a
         abortyp = toomany.or.sending.or.filerr
         return
      endif
      numtry = numtry + 1
c
c     send the filename packet
c
      call sndpack(f,packnum,slen(filestr),filestr)
c
c     check on the reply
c
      ptyp = rdpack(len,num,recpack)
      if (ptyp .eq. n) then
         if (mod(packnum+1,64) .ne. num) then
            sfile = state
            return
         else
            ptyp = y
            num = num - 1
         endif
      endif
      if (ptyp .eq. y) then
         if (packnum .ne. num) then
            sfile = state
            return
         endif
         numtry = 0
         packnum = mod(packnum+1,64)
c
c        get first packet of data from the file
c
         psize = buffill(ffd,packet)
         sfile = d
c
c     did we get an error packet?
c
      else if (ptyp .eq. e) then
         sfile = e
         return
      else if (ptyp .eq. error) then
         sfile = state
      else
         sfile = a
         abortyp = invalid.or.sending.or.filerr
      endif
      return
      end
      integer function sdata()

ccc   sdata - send a data packet and wait for reply.
c
*call kermcom
c
c     have we tried this too many times?
c
      if (numtry .gt. maxrtry) then
         sdata = a
         abortyp = toomany.or.sending.or.dataerr
         return
      endif
      numtry = numtry + 1
c
c     send the current data buffer
c
      if (psize .eq. eof) then
         sdata = z
         return
      endif
      call sndpack(d,packnum,psize,packet)
c
c     check on the reply
c
      ptyp = rdpack(len,num,recpack)
      if (ptyp .eq. n) then
         if (mod(packnum+1,64) .ne. num) then
            sdata = state
            return
         else
            ptyp = y
            num = num - 1
         endif
      endif
      if (ptyp .eq. y) then
         if (packnum .ne. num) then
            sdata = state
            return
         endif
         numtry = 0
         packnum = mod(packnum+1,64)
         psize = buffill(ffd,packet)
         if (psize .eq. eof) then
            sdata = z
         else
            sdata = state
         endif
c
c     did we get an error packet?
c
      else if (ptyp .eq. e) then
         sdata = e
         return
      else if (ptyp .eq. error) then
         sdata = state
      else
         sdata = a
         abortyp = invalid.or.sending.or.dataerr
      endif
      return
      end
      integer function seof()

ccc   seof - send an eof packet and wait for the reply.
c
*call kermcom
c
c     have we tried this too many times?
c
      if (numtry .gt. maxrtry) then
         seof = a
         abortyp = toomany.or.sending.or.eoferr
         return
      endif
      numtry = numtry + 1
c
c     send the eof packet
c
      call sndpack(z,packnum,0,0)
c
c     check the reply
c
      ptyp = rdpack(len,num,recpack)
      if (ptyp .eq. n) then
         if (mod(packnum+1,64) .ne. num) then
            seof = state
            return
         else
            ptyp = y
            num = num - 1
         endif
      endif
      if (ptyp .eq. y) then
         if (packnum .ne. num) then
            seof = state
            return
         endif
         numtry = 0
         packnum = mod(packnum+1,64)
         call fclose(ffd)
         seof = b
c
c     did we get an error packet?
c
      else if (ptyp .eq. e) then
         seof = e
         return
      else if (ptyp .eq. error) then
         seof = state
      else
         seof = a
         abortyp = invalid.or.sending.or.eoferr
      endif
      return
      end
      integer function sbreak()

ccc   sbreak - send the break packet and wait for reply.
c
*call kermcom
c
c     have we tried this too many times?
c
      if (numtry .gt. maxrtry) then
         sbreak = a
         abortyp = toomany.or.sending.or.brkerr
         return
      endif
      numtry = numtry + 1
c
c     send the break packet
c
      call sndpack(b,packnum,0,0)
c
c     check on the reply
c
      ptyp = rdpack(len,num,recpack)
      if (ptyp .eq. n) then
         if (mod(packnum+1,64) .ne. num) then
            sbreak = state
            return
         else
            ptyp = y
            num = num - 1
         endif
      endif
      if (ptyp .eq. y) then
         if (packnum .ne. num) then
            sbreak = state
            return
         endif
         numtry = 0
         packnum = mod(packnum+1,64)
         sbreak = c
c
c     did we get an error packet?
c
      else if (ptyp .eq. e) then
         sbreak = e
         return
      else if (ptyp .eq. error) then
         sbreak = state
      else
         sbreak = a
         abortyp = invalid.or.sending.or.brkerr
      endif
      return
      end
      subroutine sndpack(type,num,len,data)

ccc   sndpack - send a packet down an output stream
c
c     sndpack will send a packet of information and log it
c     if debug is turned on.  this subroutine could be made
c     more efficient by not calling a subroutine for each
c     character, but that might cause portability problems.
c
*call kermcom
      integer data(200)
c
c     define the tochar statement function
c
      tochar(ascch) = ascch + blank

      if ((debug.and.dbgpack).ne.0) call fprintf(debugfd,'^sending...',
     +   0,0,0,0)
c
c     put out pad chars
c
      do 100 i = 1,spad
         call putc(spadch,ofd)
         if ((debug.and.dbgpack).ne.0) then
            call putc(spadch,debugfd)
         endif
100   continue
      call putc(sndsync,ofd)
c
c     packet len assumes one character checksums
c
      chksum = tochar(len+3)
      call putc(chksum,ofd)
      tmp = tochar(num)
      chksum = chksum + tmp
      call putc(tmp,ofd)
      chksum = chksum + type
      call putc(type,ofd)
      do 110 i = 1,len
         chksum = chksum + (data(i) .and. o"377")
         call putc(data(i),ofd)
110   continue
      chksum = (chksum + (chksum.and.o"300") / o"100") .and. o"77"
      call putc(tochar(chksum),ofd)
      call putc(speol,ofd)
      if ((debug.and.dbgpack).ne.0) then
         call putc(sndsync,debugfd)
         call putc(tochar(len+3),debugfd)
         call putc(tochar(num),debugfd)
         call putc(type,debugfd)
         if (len .gt. 0) call putstr(debugfd,data)
         call putc(tochar(chksum),debugfd)
         call putc(speol,debugfd)
         call putc(nel,debugfd)
      endif

c     force buffer flush since desired eol char won't.  under nos/be,
c     scope, and (i suspect) nos, we need 12 bits of zero in the
c     low order 12 bits of a word to be the eol, or the data gets left
c     in an intercom small buffer till the eol (or a writer) comes
c     along.  the conditional code adds a 60 bit eol in the case
c     where the data is a multiple of 5 characters.  in all other
c     cases the eol is present, as the word was zeroed before any
c     data was put in it.

      if(fwshft(ofd) .eq. 0) then
          fwshft(ofd) = 48
          fnwds(ofd) = fnwds(ofd) + 1
          fchbuf(fnwds(ofd),ofd) = 0
      endif
      call fflush(ofd)
c
c     update the statistics
c
      nch = spad + 5 + len + 1
      schcnt = schcnt + nch
      schovrh = schovrh + nch - len
      return
      end
      integer function rdpack(len,num,data)

ccc   rdpack - read a packet of information.
c
c     rdpack will read a packet of data and return the packet type
c     as a result.  if the packet contains an error (checksum) then
c     error will be returned.  len, num, and data will be set according
c     to the fields of the packet.
c
*call kermcom
      integer data(*)
c
c     define the unchar statement function
c
      unchar(ascch) = ascch - blank
c
c     is debug packets turned on?
c
      if ((debug.and.dbgpack).ne.0) then
         call fprintf(debugfd,'^reading...',0,0,0,0)
      endif
      nch = 0
c
c     hunt for the start of packet
c
10    if(getc(ifd,ch) .eq. eof) then
          call remark(' rdpack - found unexpected eof.')
          call abtp("nd")
      endif
      nch = nch + 1
      if ((debug.and.dbgpack).ne.0) call putc(ch,debugfd)
      if (ch .ne. sync) go to 10
      chksum = 0
      len = 0
c
c     parse each field of the packet
c
c     for (field=1; field <= 5; field++)
      field = 1
20    if (field .le. 5) then
c
c        a character read in field 4 here is the first char of the
c        data field or the checksum character if the data field is empty
c
         if (field .ne. 5 .or. len .gt. 0) then
            if(getc(ifd,ch) .eq. eof) then
               call remark(' rdpack - found unexpected eof.')
               call abtp("nd")
            endif
            if (ch .eq. sync) field = 0
            nch = nch + 1
            if ((debug.and.dbgpack).ne.0) call putc(ch,debugfd)
         endif
         if (field .le. 3) chksum = chksum + ch
c
c        if resync
         if (field .eq. 0) then
            chksum = 0
            if ((debug.and.dbgpack).ne.0) then
               call fprintf(debugfd,'\n^reading...@c',sync,0,0,0)
            endif
c
c        if data length
         else if (field .eq. 1) then
            len = unchar(ch-3)
c
c        if packet number
         else if (field .eq. 2) then
            num = unchar(ch)
c
c        if packet type
         else if (field .eq. 3) then
            type = ch
c
c        if data field is not empty
         else if (field .eq. 4 .and. len .gt. 0) then
c
c           read 2nd-len chars of data & checksum char
c
            do 100 i = 1,len
               if (i .gt. 1) then
                  ch = getc(ifd,ch)
                  if(ch .eq. eof) then
                     call remark(' rdpack - found unexpected eof.')
                     call abtp("nd")
                  endif
                  nch = nch + 1
                  if (ch .eq. sync) then
                     field = 0
                     go to 20
                  endif
                  if ((debug.and.dbgpack).ne.0) call putc(ch,debugfd)
               endif
               chksum = chksum + ch
               data(i) = ch
100         continue
c
c        if chksum char
         else if (field .eq. 5) then
            data(len+1) = 0
            chksum = (chksum + ((chksum .and. o"300") / o"100"))
     +               .and. o"77"
         endif
c
c     process next packet field
c
         field = field + 1
         go to 20
      endif
      if ((debug.and.dbgpack).ne.0) call putc(nel,debugfd)
c
c     does the checksum match?
c
      if (chksum .ne. unchar(ch)) then
         rdpack = error
         rchovrh = rchovrh + nch
         if (debug .ne. 0) then
            call fprintf(debugfd,'chksum error, found @d needed @d\n',
     +                   unchar(ch),chksum,0,0)
         endif
      else
         rdpack = type
         rchovrh = rchovrh + nch - len
      endif
      rchcnt = rchcnt + nch
c
c     flush any end-of-line characters and other garbage
c
      call fflush(ifd)
      return
      end
      integer function buffill(fd,buffer)

ccc   buffill - get some data to send.
c
c     buffill reads from the file to send and performs all
c     the proper escaping of control characters and mapping
c     newlines into crlf sequences.  if it ever gets smart
c     enough, it will also do the 8 bit quoting and repeat
c     counts.
c
c *** note: this algorithm assumes 5 overhead characters for the
c     packet and leaves 3 characters in case the last character
c     to buffer is a nel (expands to 4 characters).
c
*call kermcom
      boolean buffer(*)
c
c     define ctl statement function
c
      ctl(ascch) = ascch .xor. o"100"
c
c     get a packet worth of data
c
      i = 0
10    if (getc(fd,ch) .ne. eof) then
         if(ch .eq. null) ch = 0
         tch = ch .and. o"177"
         if (tch.lt.blank .or. tch.eq.del .or. tch.eq.spquote) then
            if (ch .eq. nel .and. dskcset .ne. dskimag) then
               buffer(i+1) = spquote
               buffer(i+2) = ctl(cr)
               i = i + 2
               ch = lf
            endif
            i = i + 1
            buffer(i) = spquote
            if (tch.lt.blank .or. tch.eq.del) ch = ctl(ch)
         endif
         i = i + 1
         buffer(i) = ch
         if (i .ge. spksiz-8) then
            buffill = i
            go to 99
         endif
         go to 10
      endif
      if (i .eq. 0) then
         buffill = eof
      else
         buffill = i
      endif
99    buffer(i+1) = 0
      return
      end
      subroutine bufemp(buffer,fd,len)

ccc   bufemp - dump a buffer to a file.
c
*call kermcom
      boolean buffer(*), ch, prevch
      save prevch
      data prevch / -1 /
c
c     define ctl statement function
c
      ctl(ascch) = ascch .xor. o"100"
c
c     write the packet data to the file
c
      i = 1
10    if (i .le. len) then
         ch = buffer(i)
         if (ch .eq. quotech) then
            i = i + 1
            ch = buffer(i)
            tch = ch .and. o"177"
            if ((ctl(tch).lt.blank).or.(ctl(tch).eq.del)) ch = ctl(ch)
            if(ch .eq. 0) ch = null
         endif
c
c     if image transfer, do not convert things.
c
         if(dskcset .eq. dskimag) then
            call putc(ch,fd)
         else
c
c     convert cr/lf pair to nel (205b)
c
            if (ch .eq. lf .and. prevch .eq. cr) then
               ch = nel
c
c     just a lone cr
c
            else if (prevch .eq. cr) then
               call putc(prevch,fd)
            endif
            if (ch .ne. cr) call putc(ch,fd)
            prevch = ch
         endif
         i = i + 1
         go to 10
      endif
      return
      end
      integer function fopen(fn,mode)

ccc   fopen - pretend to open a file for i/o.
c
c     fopen just assigns a file desciptor (integer index) to
c     a file name.  no opening of the file is really performed
c     since this is done automatically by iop.
c
*call kermcom
      character*10 fn
      logical cfe
c
c     check for valid parameters
c
      if (mode .lt. rd .or. mode .gt. create) then
         call displa(' fopen - invalid mode ',mode)
         call abtp("nd")
      endif
c
c     find the next unused entry
c
      do 100 i = 1, maxfile
c
c        if unused table entry is found
c
         if (fmode(i) .eq. closed) then
            fname(i) = fn
            fwptr(i) = 1
            fnwds(i) = 0
            if (mode .eq. rd) then
               fwshft(i) = 12
            else
               fwshft(i) = 0
            endif
            if (mode .eq. create) then
               if (cfe(fname(i))) then
                  fmode(i) = closed
                  fopen = error
                  return
               endif
               fmode(i) = wr
            else
               fmode(i) = mode
            endif
            feof(i) = .false.
            ctdev(i) = .false.
            fopen = i
            call makefet(fname(i),fets(0,i),fetl,ciobuff(1,i),ciobufl)
c$    if (nos .eq. 1)
            call nosetlf(fets(0,i), i)
c$    endif
c
c           if standard i/o files, connect them to the terminal.
c
            if (fn .eq. 'stdin' .or. fn .eq. 'stdout') then
c$          if (nos .eq. 1)
               call return (fets(0,i))
               fets(1,i) = l"tt" .or. (compl(mask(12)) .and. fets(1,i))
               call mtr (l"lfmp" .or. shift(13, 24) .or. shift(1, 19)
     +            .or. locf (fets(0,i)))
c$          else
               call xcon(fets(0,i),1)
c$          endif
               ctdev(i) = .true.
            endif
c
c        set the ascii flag and rewind the file.
c
            if(fmode(i) .eq. rd) then
                call open(fets(0,i),"read")
            else
                call open(fets(0,i),"write")
            endif
            call recall(fets(0,i))
            fets(0,i) = and(fets(0,i),shift(mask(44),2))
            if(fmode(i) .eq. wr) fets(0,i) = or(fets(0,i),ciowt)
            if(fmode(i) .eq. rd) fets(0,i) = or(fets(0,i),ciord)
            return
c
c        if table entry file name matches fn
c
         else if (fname(i) .eq. fn) then
            call remark(' fopen - file ' // fn // ' already open.')
            call abtp("nd")
         endif
100   continue
      call remark(' fopen - too many files open.')
      call abtp("nd")
      return
      end
      subroutine fclose(fd)

ccc   fclose - remove an fd from the active list.
c
c     fclose will remove the fd from the active list for
c     allocation at a later date.
c
*call kermcom

      if (fd .lt. 1 .or. fd .gt. maxfile) then
         call displa(' fclose - invalid fd ',fd)
         call abtp("nd")
      endif
      if (fmode(fd) .eq. 0) then
         call displa(' fclose - fd not open.',fd)
         return
      endif
c
c     force emptying of the buffer
c
      call fflush(fd)
c
c     write a file mark
c
      if(fmode(fd) .eq. wr) then
          call writer(fets(0,fd))
          call recall(fets(0,fd))
      endif
      fmode(fd) = closed
      if(ctdev(fd)) then
          call close(fets(0,fd),"unload")
          call recall(fets(0,fd))
      else
          call close(fets(0,fd),"rewind")
          call recall(fets(0,fd))
      endif
      return
      end
      subroutine fflush(fd)

ccc   fflush - flush an i/o buffer.
c
c     fflush will flush the ascii string buffer for a particular
c     file descriptor.
c
*call kermcom

      parameter (nosibit = 36, intrcom = 42, asc128 = 22, asc256 = 23)
      parameter (first = 1, in = 2, out = 3, limit = 4, intwd = 5)
c$    if (nos .eq. 1)
      boolean bpatx
c$    endif
c
c     is the fd valid?
c
      if (fd .lt. 1 .or. fd .gt. maxfile) then
         call displa(' fflush - invalid file descriptor',fd)
         call abtp("nd")
      endif
      if (fmode(fd) .eq. 0) then
         call displa(' fflush - file descriptor not open',fd)
         call abtp("nd")
      endif
c
c     if fd was opened as write, then flush to the file
c
      if (fmode(fd) .eq. wr) then
         if(ctdev(fd)) then
c$    if (ut2d .eq. 1) then
            fets(first,fd) = or(fets(first,fd),shift(1,asciiio))
c$    else
            fets(first,fd) = or(fets(first,fd),shift(1,intrcom))
            fets(intwd,fd) = shift(1,asc256)
c$    if (nos .eq. 1)
            fets(first,fd) = or(fets(first,fd),shift(1,nosibit))
            if (fnwds(fd) .eq. 1) then
               bpatx = o"00004000400040004000"
            else
               bpatx = o"40004000400040004000"
            endif
            fchbuf(fnwds(fd),fd) = fchbuf(fnwds(fd),fd) .or. bpatx
            fnwds(fd) = fnwds(fd) + 1
            fchbuf(fnwds(fd),fd) = 0
c$    endif
c$    endif
         elseif(fd .ne. debugfd  .and.  dskcset .eq. dskdpc) then
            temp = dpctbl(0)
            dpctbl(0) = 0
            call xtxs(fchbuf(1,fd),fnwds(fd),fchbuf(1,fd),dpctbl)
            if(mod(fnwds(fd),2) .eq. 0)
     +        fchbuf(fnwds(fd) / 2 + 1,fd) = 0
            dpctbl(0) = temp
            fnwds(fd) = findeol(fchbuf(1,fd),fnwds(fd),.false.)
         endif
         call writew(fets(0,fd),fchbuf(1,fd),fnwds(fd))
c$    if (nos .eq. 1)
         if ((binmode .or. rawmode) .and. ctdev(fd)) then
            call writer(fets(0,fd))
         endif
c$    endif
      else if (fmode(fd) .eq. rd) then
         call recall(fets(0,fd))
         fets(in,fd) = and(fets(first,fd),o"777777")
         fets(out,fd) = fets(in,fd)
      endif
c
c     reset buffer character count
c
      fwptr(fd) = 1
      fnwds(fd) = 0
      if (fmode(fd) .eq. rd) then
         fwshft(fd) = 12
      else
         fwshft(fd) = 0
      endif
      return
      end
      integer function getc(fd,ch)

ccc   getc - return next character from the input stream.
c
c     getc will return the next ascii character that was
c     read from the file descriptor fd.  reads are buffered
c     with 5 characters packed to a word.  o"0000" bytes
c     are ignored.  nuls are o"4000" bytes.  eof (-1) is
c     returned when eof is read.
c
*call kermcom
c
c     is the fd valid?
c
      if (fd .lt. 1 .or. fd .gt. maxfile) then
         call displa(' getc - invalid file descriptor',fd)
         call abtp("nd")
      endif
      if (fmode(fd) .eq. closed) then
         call displa(' getc - file descriptor not open',fd)
         call abtp("nd")
      endif
c
c     check if ok to read
c
      if ((fmode(fd).and.rd) .ne. rd) then
         call displa(' getc - read on write-only file ',fd)
         call abtp("nd")
      endif
c
c     check if more data needed
c
10    if (fwptr(fd) .gt. fnwds(fd)) then
         if (feof(fd)) then
            getc = eof
            return
         endif
c
c        get a buffer worth of data
c
         nread = getrec(fd,fchbuf(1,fd),maxwd,feof(fd))
         fwptr(fd) = 1
         fnwds(fd) = nread
         fwshft(fd) = 12
         go to 10
      endif
c
c     pickup char to return and check for ignored o"0000" byte
c
      ch = shift(fchbuf(fwptr(fd),fd),fwshft(fd)) .and. o"7777"
      fwshft(fd) = fwshft(fd) + 12
      if (fwshft(fd) .gt. 60) then
         fwshft(fd) = 12
         fwptr(fd) = fwptr(fd) + 1
      endif
c
c     if the front-end isn't stripping parity and we aren't using
c     the eigth bit for data, then strip the parity bit.  also, convert
c     carriage returns and linefeeds which come from the keyboard into
c     regular end-of-lines (this only happens in binmode).
c
      if (binmode .and. .not. rawmode) then
         if (parity .ne. nopar .and. ctdev(fd)) ch = ch .and. o"177"
         if(ctdev(fd)  .and.  (ch .eq. cr .or. ch .eq. lf)) ch = nel
      endif
      if (ch .eq. 0) go to 10
      getc = ch
      return
      end
      subroutine ungetc(fd,ch)

ccc   ungetc - try to put a character back into the input stream.
c
c     ungetc can only put back characters as far as the beginning
c     of the buffer.  hopefully, this is ok, since only getword
c     does this with an nel which should be well into the buffer.
*call kermcom
c
c     is it ok to back up the pointer?
c
      if (fwshft(fd) .eq. 12 .and. fwptr(fd) .eq. 1) then
         call displa('ungetc - cannot push character ',ch)
         return
      endif
c
c     back up the pointer
c
      if (fwshft(fd) .eq. 12) then
         fwshft(fd) = 60
         fwptr(fd) = fwptr(fd) - 1
      else
         fwshft(fd) = fwshft(fd) - 12
      endif
      fchbuf(fwptr(fd),fd) = (fchbuf(fwptr(fd),fd) .and. shift(
     +   o"7777",60-fwshft(fd))) .or. shift(ch,60-fwshft(fd))
      feof(fd) = .false.
      return
      end
      integer function getword(fd,str,maxlen)

ccc   getword - get a word from an input stream.
c
c     getword considers a word to be delimited by blanks.
c     it will return the length of the word as its value.
c
*call kermcom
      integer str(maxlen)

      len = 0
c
c     skip leading white spaces
c
10    if (getc(fd,ch) .eq. eof) then
         getword = eof
         return
      else if (ch .eq. nel) then
         getword = 0
         return
      endif
      if (ch .eq. blank .or. ch .eq. tab) go to 10
c
c     found the first character, so keep going
c
20    if (len .lt. maxlen) then
         len = len + 1
         str(len) = ch
      endif
      ch = getc(fd,ch)
      if (ch .ne. eof .and. ch .ne. blank .and. ch .ne. tab .and.
     +    ch .ne. nel) go to 20
c
c     save eols for next getword
c
      if (ch .eq. nel) call ungetc(fd,ch)
      str(len+1) = 0
      getword = len
      return
      end
      subroutine putc(tch,fd)

ccc   putc - put a character into an output stream
c
c     putc outputs a character with the parity bit set to the
c     proper parity if the output file is conversational.
c     the five types of parity are defined for each character
c     in a table.
c
*call kermcom
      integer chparty(128)
      data (chparty(i),i=1,38) /
     +               o"40000200020040004000", o"02010001020100010001",
c                            nul                      soh
     +               o"02020002020200020002", o"00030203020300030003",
c                            stx                      etx
     +               o"02040004020400040004", o"00050205020500050005",
c                            eot                      enq
     +               o"00060206020600060006", o"02070007020700070007",
c                            ack                      bel
     +               o"02100010021000100010", o"00110211021100110011",
c                            bs                       ht
     +               o"00120212021200120012", o"02130013021300130013",
c                            lf                       vt
     +               o"00140214021400140014", o"02150015021500150015",
c                            ff                       cr
     +               o"02160016021600160016", o"00170217021700170017",
c                            so                       si
     +               o"02200020022000200020", o"00210221022100210021",
c                            dle                      dc1
     +               o"00220222022200220022", o"02230023022300230023",
c                            dc2                      dc3
     +               o"00240224022400240024", o"02250025022500250025",
c                            dc4                      nak
     +               o"02260026022600260026", o"00270227022700270027",
c                            syn                      etb
     +               o"00300230023000300030", o"02310031023100310031",
c                            can                      em
     +               o"02320032023200320032", o"00330233023300330033",
c                            sub                      esc
     +               o"02340034023400340034", o"00350235023500350035",
c                            fs                       gs
     +               o"00360236023600360036", o"02370037023700370037",
c                            rs                       us
     +               o"02400040024000400040", o"00410241024100410041",
c                                                     !
     +               o"00420242024200420042", o"02430043024300430043",
c                            "                        pound
     +               o"00440244024400440044", o"02450045024500450045" /
c                            $                        percent
      data (chparty(i),i=39,76) /
     +               o"02460046024600460046", o"00470247024700470047",
c                            &                        '
     +               o"00500250025000500050", o"02510051025100510051",
c                            (                        )
     +               o"02520052025200520052", o"00530253025300530053",
c                            *                        +
     +               o"02540054025400540054", o"00550255025500550055",
c                            ,                        -
     +               o"00560256025600560056", o"02570057025700570057",
c                            .                        /
     +               o"00600260026000600060", o"02610061026100610061",
c                            0                        1
     +               o"02620062026200620062", o"00630263026300630063",
c                            2                        3
     +               o"02640064026400640064", o"00650265026500650065",
c                            4                        5
     +               o"00660266026600660066", o"02670067026700670067",
c                            6                        7
     +               o"02700070027000700070", o"00710271027100710071",
c                            8                        9
     +               o"00720272027200720072", o"02730073027300730073",
c                            :                        ;
     +               o"00740274027400740074", o"02750075027500750075",
c                            <                        =
     +               o"02760076027600760076", o"00770277027700770077",
c                            >                        ?
     +               o"03000100030001000100", o"01010301030101010101",
c                            @                        a
     +               o"01020302030201020102", o"03030103030301030103",
c                            b                        c
     +               o"01040304030401040104", o"03050105030501050105",
c                            d                        e
     +               o"03060106030601060106", o"01070307030701070107",
c                            f                        g
     +               o"01100310031001100110", o"03110111031101110111",
c                            h                        i
     +               o"03120112031201120112", o"01130313031301130113" /
c                            j                        k
      data (chparty(i),i=77,114) /
     +               o"03140114031401140114", o"01150315031501150115",
c                            l                        m
     +               o"01160316031601160116", o"03170117031701170117",
c                            n                        o
     +               o"01200320032001200120", o"03210121032101210121",
c                            p                        q
     +               o"03220122032201220122", o"01230323032301230123",
c                            r                        s
     +               o"03240124032401240124", o"01250325032501250125",
c                            t                        u
     +               o"01260326032601260126", o"03270127032701270127",
c                            v                        w
     +               o"03300130033001300130", o"01310331033101310131",
c                            x                        y
     +               o"01320332033201320132", o"03330133033301330133",
c                            z                        [
     +               o"01340334033401340134", o"03350135033501350135",
c                            \                        ]
     +               o"03360136033601360136", o"01370337033701370137",
c                            ^                        underscore
     +               o"01400340034001400140", o"03410141034101410141",
c                            grave accent             a
     +               o"03420142034201420142", o"01430343034301430143",
c                            b                        c
     +               o"03440144034401440144", o"01450345034501450145",
c                            d                        e
     +               o"01460346034601460146", o"03470147034701470147",
c                            f                        g
     +               o"03500150035001500150", o"01510351035101510151",
c                            h                        i
     +               o"01520352035201520152", o"03530153035301530153",
c                            j                        k
     +               o"01540354035401540154", o"03550155035501550155",
c                            l                        m
     +               o"03560156035601560156", o"01570357035701570157",
c                            n                        o
     +               o"03600160036001600160", o"01610361036101610161" /
      data (chparty(i),i=115,128) /
c                            p                        q
     +               o"01620362036201620162", o"03630163036301630163",
c                            r                        s
     +               o"01640364036401640164", o"03650165036501650165",
c                            t                        u
     +               o"03660166036601660166", o"01670367036701670167",
c                            v                        w
     +               o"01700370037001700170", o"03710171037101710171",
c                            x                        y
     +               o"03720172037201720172", o"01730373037301730173",
c                            z                        left brace
     +               o"03740174037401740174", o"01750375037501750175",
c                            bar                      right brace
     +               o"01760376037601760176", o"03770177037701770177" /
c                            tilde                    del
c
c     is the fd valid?
c
      if (fd .lt. 1 .or. fd .gt. maxfile) then
         call displa(' putc - invalid file descriptor',fd)
         call abtp("nd")
      endif
      if (fmode(fd) .eq. closed) then
         call displa(' putc - file descriptor not open',fd)
         call abtp("nd")
      endif
c
c     is it ok to write on this stream?
c
      if ((fmode(fd).and.wr) .ne. wr) then
         call displa(' putc - write on read-only file ',fd)
         call abtp("nd")
      endif
c
c     add another character to the output buffer
c
      ch = tch
10    if (ctdev(fd)) then
         if (ch .eq. nel .and. .not. rawmode) ch = cr
         if (ch .ge. 0 .and. ch .lt. 128)
     +      ch = shift(chparty(ch+1),parity*12) .and. o"7777"
      endif
      if (fwshft(fd) .eq. 0) then
         if (fnwds(fd) .eq. maxwd) then
            call fflush(fd)
         endif
         fwshft(fd) = 48
         fnwds(fd) = fnwds(fd) + 1
         fchbuf(fnwds(fd),fd) = 0
      else
         fwshft(fd) = fwshft(fd) - 12
      endif
c
c     if this is an mass storage device (disk), and we have a nel
c     character, flush the line into the cio buffer.  the standard cdc
c     line terminator is already present thanks to the above code
c     pre-zeroing the target word before anything is put in it.
c     however, don't flush if we need the nel character in the
c     line (e.g. ut 812 ascii and disk image format).
c
      if(.not.ctdev(fd) .and. tch.eq.nel .and. dskcset.ne.dskut8 .and.
     +   dskcset.ne.dskimag) then
          call fflush(fd)
          return
      endif

c$    if (nos .eq. 1)
c
c     preset transparent output for the terminal if first word of buffer
c
      if (fnwds(fd) .eq. 1 .and. fwshft(fd) .eq. 48) then
         if (fmode(fd) .eq. wr .and. ctdev(fd)) then
            fchbuf(fnwds(fd),fd) = shift(o"0007",48)
            fwshft(fd) = 36
         endif
      endif

      if (ctdev(fd)) ch = ch .or. o"4000"
c$    endif

      fchbuf(fnwds(fd),fd) = fchbuf(fnwds(fd),fd) .or.
     +   shift(and(ch,o"7777"),fwshft(fd))
      if (tch .eq. nel .and. (ch.and.o"0177") .eq. cr) then
         ch = lf
         go to 10
      endif
      if (tch .eq. nel .and. ctdev(fd)) call fflush(fd)
      return
      end
      subroutine fread(fd,buf,nwd)

ccc   fread - read some words from a file.
c
*call kermcom
      integer buf(nwd)
c
c     is the fd valid?
c
      if (fd .lt. 1 .or. fd .gt. maxfile) then
         call displa(' fread - invalid file descriptor',fd)
         call abtp("nd")
      endif
      if (fmode(fd) .eq. closed) then
         call displa(' fread - file descriptor not open',fd)
         call abtp("nd")
      endif
c
c     check if ok to read
c
      if ((fmode(fd).and.rd) .ne. rd) then
         call displa(' fread - read on write-only file ',fd)
         call abtp("nd")
      endif
c
c     transfer a cio buffer full at a time until done
c
      istart = 1
      nleft = nwd
10    nrd = nleft
      if (nrd .gt. ciobufl-1) then
         nrd = ciobufl-1
      endif
      call readw(fets(0,fd),buf(istart),nrd)
      istart = istart + nrd
      nleft = nleft - nrd
      if (nleft .gt. 0) goto 10
      return
      end
      subroutine fwrite(fd,buf,nwd)

ccc   fwrite - write some words to a file.
c
*call kermcom
c
c     is the fd valid?
c
      if (fd .lt. 1 .or. fd .gt. maxfile) then
         call displa(' fwrite - invalid fd ',fd)
         call abtp("nd")
      endif
      if (fmode(fd) .eq. closed) then
         call displa(' fwrite - fd not open.',fd)
         return
      endif
c
c     is it ok to write on this stream?
c
      if ((fmode(fd).and.wr) .ne. wr) then
         call displa(' fwrite - write on read-only file ',fd)
         call abtp("nd")
      endif
c
c     write the words to the file
c
      call writew(fets(0,fd),buf,nwd)
      return
      end
      subroutine putstr(fd,str)

ccc   putstr - output a string to an output stream.
c
c     putstr will add characters from the null terminated character
c     buffer str to the specified output stream.
c
*call kermcom
      integer str(*)
c
c     is the fd valid?
c
      if (fd .lt. 1 .or. fd .gt. maxfile) then
         call displa(' putc - invalid fd ',fd)
         call abtp("nd")
      endif
      if (fmode(fd) .eq. 0) then
         call displa(' putc - fd not open.',fd)
         return
      endif
c
c     is it ok to write on this stream?
c
      if ((fmode(fd).and.wr) .ne. wr) then
         call displa(' putc - write on read-only file ',fd)
         call abtp("nd")
      endif
c
c     put chars in the output buffer
c
      i = 1
10    if (str(i) .ne. 0) then
c
c        is it a valid character?
c
c        if ((str(i).and.mask(48)) .ne. 0) then
c           call displa(' putstr - invalid ascii byte ',str(i))
c           call abort
c        endif
         call putc(str(i),fd)
         i = i + 1
         go to 10
      endif
      return
      end
      subroutine putint(fd,int,minwid)

ccc   putint - output an integer.
c
*call kermcom
      integer string(21)

      width = 0
      if (int .lt. 0) then
         call putc(asc('-'),fd)
         width = 1
      endif
      val = iabs(int)
      ascii0 = asc('0')
      nch = 0
10    nch = nch + 1
      string(nch) = mod(val,10) + ascii0
      val = val / 10
      if (val .ne. 0 .and. nch .lt. 20) go to 10
      width = width + nch
c
c     now output the digits
c
20    call putc(string(nch),fd)
      nch = nch - 1
      if (nch .gt. 0) go to 20
30    if (width .lt. minwid) then
         call putc(blank,fd)
         width = width + 1
         go to 30
      endif
      return
      end
      subroutine putday(fd,mm,dd,yy)

ccc   output day of week.
c
*call kermcom
      izlr(iyr,m,idy)=mod((13*(m+10-(m+10)/13*12)-1)/5+idy+77
     1 +5*(iyr+(m-14)/12-(iyr+(m-14)/12)/100*100)/4
     2 +(iyr+(m-14)/12)/400-(iyr+(m-14)/12)/100*2,7)+1
      wkday = izlr(yy,mm,dd)
      if (wkday .eq. 1) then
         call fprintf(fd,'^sunday')
      else if (wkday .eq. 2) then
         call fprintf(fd,'^monday')
      else if (wkday .eq. 3) then
         call fprintf(fd,'^tuesday')
      else if (wkday .eq. 4) then
         call fprintf(fd,'^wednesday')
      else if (wkday .eq. 5) then
         call fprintf(fd,'^thursday')
      else if (wkday .eq. 6) then
         call fprintf(fd,'^friday')
      else
         call fprintf(fd,'^saturday')
      endif
      return
      end
      subroutine putmnth(fd,mm)

ccc   putmnth - output the month name.
c
*call kermcom
      if (mm .eq. 1) then
         call fprintf(fd,'^january',0)
      else if (mm .eq. 2) then
         call fprintf(fd,'^february',0)
      else if (mm .eq. 3) then
         call fprintf(fd,'^march',0)
      else if (mm .eq. 4) then
         call fprintf(fd,'^april',0)
      else if (mm .eq. 5) then
         call fprintf(fd,'^may',0)
      else if (mm .eq. 6) then
         call fprintf(fd,'^june',0)
      else if (mm .eq. 7) then
         call fprintf(fd,'^july',0)
      else if (mm .eq. 8) then
         call fprintf(fd,'^august',0)
      else if (mm .eq. 9) then
         call fprintf(fd,'^september',0)
      else if (mm .eq. 10) then
         call fprintf(fd,'^october',0)
      else if (mm .eq. 11) then
         call fprintf(fd,'^november',0)
      else if (mm .eq. 12) then
         call fprintf(fd,'^december',0)
      else
         call fprintf(fd,'putmnth - no such month as @d\n',mm)
      endif
      return
      end
      subroutine fprintf(fd,fmt,i1,i2,i3,i4)

ccc   fprintf - poor attempt at formatted ascii output.
c
c     conversion is similar to fprintf used in c.  supported
c     conversions are @d (integer), @c (ascii character), @s (ascii
c     string buffer).  a \n will map to a newline, a \t will
c     will map to a tab, a \0 will terminate the format scanning.
c     a \ followed by any other character will cause that character
c     to be output.  the default output case will be lowercase.
c     a ^ followed by a letter will cause that character to be output
c     as uppercase.  a @d conversion may now specify a minimum field
c     width as @<n>d (i.e. @10d) in which the number will be blank
c     padded to the right to use up <n> characters.
c
*call kermcom
      character*(*) fmt
c
c     is the fd valid?
c
      if (fd .lt. 1 .or. fd .gt. maxfile) then
         call displa(' fprintf - invalid fd ',fd)
         call abtp("nd")
      endif
      if (fmode(fd) .eq. closed) then
         call displa(' fprintf - fd not open.',fd)
         return
      endif
c
c     is it ok to write on this stream?
c
      if ((fmode(fd).and.wr) .ne. wr) then
         call displa(' fprintf - write on read-only file ',fd)
         call abtp("nd")
      endif
c
c     now call the real fprintf workhorse
c
      call doprnt(fd,0,1,fmt,i1,i2,i3,i4)
      return
      end
      subroutine sprintf(str,fmt,i1,i2,i3,i4)

ccc   sprintf - poor attempt at doing internal formatted i/o.
c
c     sprintf is the same as fprintf except that it writes to
c     and ascii string buffer instead.
c
*call kermcom
      character*(*) fmt
      boolean str(*)
c
c     call the real sprintf workhorse
c
      call doprnt(0,str,2,fmt,i1,i2,i3,i4)
      return
      end
      subroutine doprnt(fd,strng,ptyp,fmt,i1,i2,i3,i4)

ccc   doprnt - workhorse for formatted ascii i/o.
c
c     conversion is similar to fprintf used in c.  supported
c     conversions are @d (integer), @c (ascii character), @s (ascii
c     string buffer).  a \n will map to a newline, a \t will
c     will map to a tab, a \0 will terminate the format scanning.
c     a \ followed by any other character will cause that character
c     to be output.  the default output case will be lowercase.
c     a ^ followed by a letter will cause that character to be output
c     as uppercase.  a @d conversion may now specify a minimum field
c     width as @<n>d (i.e. @10d) in which the number will be blank
c     padded to the right to use up <n> characters.
c
*call kermcom
      character*(*) fmt
      boolean str(21), strng(*)
      character*1 ch
c
c     check for file or string write
c
      if (ptyp .ne. 1 .and. ptyp .ne. 2) then
         call displa(' doprnt - invalid write function',ptyp)
         call abtp("nd")
      endif
c
c     output the formatted string
c
      iptr = 1
      optr = 1
      fptr = 1
      fmtlen = len(fmt)
10    if (fptr .le. fmtlen) then
         ch = fmt(fptr:fptr)
         if (ch .ne. '\' .and. ch .ne. '@' .and. ch .ne. '^') then
            if (ptyp .eq. 1) then
               call putc(asc(ch),fd)
            else
               strng(optr) = asc(ch)
               optr = optr + 1
            endif
c
c        is it a quote or special sequence character?
c
         else if (ch .eq. '\') then
            fptr = fptr+1
            ch = fmt(fptr:fptr)
            if (ch .eq. 'n' .and. ptyp .eq. 1) then
               call putc(nel,fd)
            else if (ch .eq. 't' .and. ptyp .eq. 1) then
               call putc(tab,fd)
            else if (ch .eq. '0') then
               if (ptyp .eq. 2) strng(optr) = 0
               return
            else if (ch .eq. 'n') then
               strng(optr) = nel
               optr = optr + 1
            else if (ch .eq. 't') then
               strng(optr) = tab
               optr = optr + 1
            else
               if (ptyp .eq. 1) then
                  call putc(asc(ch),fd)
               else
                  strng(optr) = asc(ch)
                  optr = optr + 1
               endif
            endif
c
c     is it an uppercase mapping?
c
         else if (ch .eq. '^') then
            fptr = fptr + 1
            ch = fmt(fptr:fptr)
            if (ch .ge. 'a' .and. ch .le. 'z') then
               ach = asc(ch)-32
            else
               ach = asc(ch)
            endif
            if (ptyp .eq. 1) then
               call putc(ach,fd)
            else
               strng(optr) = ach
               optr = optr + 1
            endif
c
c        must be a conversion (@)
c
         else
            intwdth = 1
            fptr = fptr + 1
            ch = fmt(fptr:fptr)
c
c           is it an integer value format spec?
c
20          if (ch .eq. 'd') then
               if (iptr .eq. 1) then
                  ach = i1
               else if (iptr .eq. 2) then
                  ach = i2
               else if (iptr .eq. 3) then
                  ach = i3
               else
                  ach = i4
               endif
               if (ptyp .eq. 1) then
                  call putint(fd,ach,intwdth)
               else
                  tlen = itos(ach,strng(optr),intwdth)
                  optr = optr + tlen
               endif
               iptr = iptr + 1
c
c           is it a character value output spec?
c
            else if (ch .eq. 'c') then
               if (iptr .eq. 1) then
                  ach = i1
               else if (iptr .eq. 2) then
                  ach = i2
               else if (iptr .eq. 3) then
                  ach = i3
               else
                  ach = i4
               endif
               if (ptyp .eq. 1) then
                  call putc(ach,fd)
               else
                  strng(optr) = ach
                  optr = optr + 1
               endif
               iptr = iptr + 1
c
c           is it a string value output spec?
c
            else if (ch .eq. 's') then
               if (iptr .eq. 1) then
                  if (ptyp .eq. 1) then
                     call putstr(fd,i1)
                  else
                     call strcpy(i1,strng(optr))
                     optr = optr + slen(i1)
                  endif
               else if (iptr .eq. 2) then
                  if (ptyp .eq. 1) then
                     call putstr(fd,i2)
                  else
                     call strcpy(i2,strng(optr))
                     optr = optr + slen(i2)
                  endif
               else if (iptr .eq. 3) then
                  if (ptyp .eq. 1) then
                     call putstr(fd,i3)
                  else
                     call strcpy(i3,strng(optr))
                     optr = optr + slen(i3)
                  endif
               else
                  if (ptyp .eq. 1) then
                     call putstr(fd,i4)
                  else
                     call strcpy(i4,strng(optr))
                     optr = optr + slen(i4)
                  endif
               endif
               iptr = iptr + 1
c
c           is it a field width specifier?
c
            else if (ch .ge. '0' .and. ch .le. '9') then
               sptr = 0
30             sptr = sptr + 1
               str(sptr) = asc(ch)
               fptr = fptr + 1
               ch = fmt(fptr:fptr)
               if (ch .ge. '0' .and. ch .le. '9') go to 30
               str(sptr+1) = 0
               intwdth = ctoi(str)
               go to 20
c
c           unknown conversion so output the @ and conversion char
c
            else
               if (ptyp .eq. 1) then
                  call putc(asc('@'),fd)
                  call putc(asc(ch),fd)
               else
                  strng(optr) = asc('@')
                  strng(optr+1) = asc(ch)
                  optr = optr + 2
               endif
         endif
         endif
         fptr = fptr + 1
         go to 10
      endif
      if (ptyp .eq. 2) strng(optr) = 0
      return
      end
      subroutine stty(mode,value)

ccc   stty - set a terminal mode.
c
*call kermcom
      character*(*) mode
      integer value
c$    if (nos .eq. 1)
      integer  nositm(5), nosttm(2), nosfull, noshalf,
     +   noszero, nosodd, noseven, nosnone
c
c        for nos (initiate *rawmode*):
c          set pw=0,ci=0,li=0,pg=n,ubl=15,ubz=200,eb=cr,fa=y,cp=0,lk=y
c
      data  nositm / o"00164043400040544000", o"40554000404540004030",
     +               o"40174031400241014001", o"40674001410740004040",
     +               o"40010000000000000000" /
c
c        for nos (terminate *rawmode*):
c           set fa=n,cp=1,lk=n
c
      data  nosttm / o"00164067400041074001", o"40404000000000000000" /
c
c        for nos (full/half duplex):
c
      data  nosfull / o"00164061400100000000" /
      data  noshalf / o"00164061400000000000" /
c
c        for nos (parity: zero, odd, even, none)
c
      data  noszero / o"00164062400000000000" /
      data  nosodd  / o"00164062400100000000" /
      data  noseven / o"00164062400200000000" /
      data  nosnone / o"00164062400300000000" /
c
c$    endif
c
c     is it setting duplex?
c
      if (mode .eq. 'duplex') then
         if (value .eq. fulldup) then
c$          if (ut2d .eq. 1)
            call bellc(l"full",0,0)
c$          endif
c$          if(uariz .eq. 1)
            call echoplx('on')
c$          endif
c$          if(nos .eq. 1)
            call writew(fets(0,stdout),nosfull,1)
            call writer(fets(0,stdout))
            if (debug .ne. 0) then
               call fprintf(debugfd, '^stty - full duplex.\n')
            endif
c$          endif
            duplex = fulldup
         else if (value .eq. halfdup) then
c$          if (ut2d .eq. 1)
            call bellc(l"half",0,0)
c$          endif
c$          if(uariz .eq. 1)
            call echoplx('off')
c$          endif
c$          if(nos .eq. 1)
            call writew(fets(0,stdout),noshalf,1)
            call writer(fets(0,stdout))
            if (debug .ne. 0) then
               call fprintf(debugfd, '^stty - half duplex.\n')
            endif
c$          endif
            duplex = halfdup
         else
            call displa(' stty - invalid duplex ',value)
            call abtp("nd")
         endif
c
c     is it setting parity?
c
      else if (mode .eq. 'parity') then
         if (value .eq. nopar .or. value .eq. evepar .or.
     +       value .eq. oddpar .or. value .eq. mrkpar .or.
     +       value .eq. spcpar) then
            parity = value
c$          if (nos .eq. 1)
            if (debug .ne. 0) then
               call fprintf(debugfd, '^stty - parity switch.\n')
            endif
            if (parity .eq. nopar) then
               call writew(fets(0,stdout),nosnone,1)
               call writer(fets(0,stdout))
            else if (parity .eq. evepar) then
               call writew(fets(0,stdout),noseven,1)
               call writer(fets(0,stdout))
            else if (parity .eq. oddpar) then
               call writew(fets(0,stdout),nosodd,1)
               call writer(fets(0,stdout))
            else if (parity .eq. mrkpar) then
               call writew(fets(0,stdout),noszero,1)
               call writer(fets(0,stdout))
            else if (parity .eq. spcpar) then
               call writew(fets(0,stdout),noszero,1)
               call writer(fets(0,stdout))
            endif
c$          endif
         else
            call displa(' stty - invalid parity ',value)
            call abtp("nd")
         endif
c
c     is it setting binary (no translation) i/o?
c
      else if (mode .eq. 'binary') then
         binmode = (value .eq. on)
         do 100 i = 1,maxfile
            if (fmode(i) .ne. closed) then
               if (ctdev(i)) then
                  if (binmode) then
                     fets(0,i) = or(fets(0,i),cioodd)
                  else
                     fets(0,i) = and(fets(0,i),.not.cioodd)
                  endif
               endif
            endif
100      continue
c$       if(nos .eq. 1)
         if (binmode) then
            call writew(fets(0,stdout),nositm, 5)
            call writer(fets(0,stdout))
            if (debug .ne. 0) then
               call fprintf(debugfd, '^stty - binary.\n')
            endif
         else
            call writew(fets(0,stdout),nosttm, 2)
            call writer(fets(0,stdout))
            if (debug .ne. 0) then
               call fprintf(debugfd, '^stty - normal.\n')
            endif
         endif
c$       endif
c
c     is it setting transparent (raw) i/o?
c
      else if (mode .eq. 'raw') then
         if (value .eq. 0) then
            rawmode = .false.
         else
            rawmode = .true.
         endif
      else
         call displa(' stty - invalid mode ',bool(mode))
         call abtp("nd")
      endif
      return
      end
      integer function gtty(mode)

ccc   gtty - get a tty mode.
c
*call kermcom
      character*(*) mode
c
c     is it duplex they're looking for?
c
      if (mode .eq. 'duplex') then
         gtty = duplex
c
c     is it parity they're looking for?
c
      else if (mode .eq. 'parity') then
         gtty = parity
      else
         call displa(' gtty - invalid mode ',bool(mode))
         call abtp("nd")
      endif
      return
      end
      subroutine as2dpc(astr,dstr)

ccc   as2dpc - translate an ascii string buffer to dpc char string.
c
c     ascii string is terminated by a zero byte.
c
c
*call kermcom
      boolean astr(*)
      character dstr*(*)
      integer clen
c
c
      i = 1
      clen = len(dstr)
      dstr = ' '
10    if (astr(i) .ne. 0 .and. i .le. clen) then
         if (astr(i) .gt. 127) then
            call movech(dpctbl(blank),9,dstr,i - 1,1)
         else
            call movech(dpctbl(astr(i)),9,dstr,i - 1,1)
         endif
         i = i + 1
         go to 10
      endif
c
      return
      end
      integer function asc(dpch)

ccc   asc - convert a dpc character to lower case ascii.
c
c
*call kermcom
      character*1 dpch
c
c
      asc = lascii(ichar(dpch))
c
      return
      end
      subroutine dpc2as(dstr,astr,nwords)
c
c  translate string of display code characters to uppercase ascii.
c  string is nwords characters (words) long.
c
c
*call kermcom

      character*(*) dstr
      boolean astr(nwords)
c
c
      do 1 i=1,nwords
         astr(i) = uascii((ichar(dstr(i:i))))
    1    continue
c
c     set ascii end-of-string-buffer
c
      astr(nwords+1) = 0
c
      return
      end
      integer function ctoi(astr)

ccc   ctoi - convert character buffer to integer.
c
c     ctoi converts the number using base 10 as a default.
c     a suffix of h will convert using base 16 and a suffix
c     of o will convert using base 8.  default suffix is
c     d.
c
*call kermcom
      parameter (dig0=48, dig7=55, dig9=57, biga=65, bigb=66, bigd=68)
      parameter (bigf=70, bigh=72, bigo=79, leta=97, letb=98, letd=100)
      parameter (letf=102, leth=104, leto=111)
      integer astr(*)

      base = 0
      ptr = 0
c
c     find last valid digit
c
10    ptr = ptr + 1
      if (astr(ptr) .ne. 0) go to 10
      ptr = ptr - 1
      if (astr(ptr) .eq. leto .or. astr(ptr) .eq. bigo .or.
     +    astr(ptr) .eq. letb .or. astr(ptr) .eq. bigb .or.
     +    astr(ptr) .eq. leth .or. astr(ptr) .eq. bigh) then
         eod = ptr - 1
      else
         eod = ptr
         ptr = ptr + 1
      endif
c
c     try to figure out the base
c
      if (astr(ptr) .eq. 0) then
         base = 10
      else if (astr(ptr) .eq. leto .or. astr(ptr) .eq. bigo .or.
     +         astr(ptr) .eq. letb .or. astr(ptr) .eq. bigb) then
         base = 8
      else if (astr(ptr) .eq. leth .or. astr(ptr) .eq. bigh) then
         base = 16
      endif
c
c     if didn't find a base
c
      if (base .eq. 0) then
         call fprintf(stdout,'ctoi - invalid base @c\n',astr(ptr),0,0,0)
         ctoi = 0
         return
      endif
c
c     add up the digits
c
      total = 0
      isneg = 1
      do 100 i = 1,eod
         ch = astr(i)
         if (ch .eq. minus) then
            isneg = -1
            go to 100
         endif
         if (base .eq. 10) then
            if (ch .lt. dig0 .or. ch .gt. dig9) then
               call fprintf(stdout,'ctoi - invalid decimal digit @c\n',
     +                      ch,0,0,0)
               ctoi = 0
               return
            else
               ch = ch - dig0
            endif
         else if (base .eq. 8) then
            if (ch .lt. dig0 .or. ch .gt. dig7) then
               call fprintf(stdout,'ctoi - invalid octal digit @c\n',
     +                      ch,0,0,0)
               ctoi = 0
               return
            else
               ch = ch - dig0
            endif
         else if (base .eq. 16) then
            if (ch .ge. dig0 .and. ch .le. dig9) then
               ch = ch - dig0
            else if (ch .ge. leta .and. ch .le. letf) then
               ch = 10 + ch - leta
            else if (ch .ge. biga .and. ch .le. bigf) then
               ch = 10 + ch - biga
            else
               call fprintf(stdout,'ctoi - invalid hex digit @c\n',
     +                      ch,0,0,0)
               ctoi = 0
               return
            endif
         endif
         total = total*base + ch
100   continue
      ctoi = total * isneg
      return
      end
      integer function itos(int,str,minwid)

ccc   itos - convert an integer to string format.
c
*call kermcom
      integer str(*)

      width = 0
      if (int .lt. 0) then
         width = 1
         str(width) = asc('-')
      endif
      val = iabs(int)
      ascii0 = asc('0')
10    width = width + 1
      str(width) = mod(val,10) + ascii0
      val = val / 10
      if (val .ne. 0) go to 10
      str(width+1) = 0
c
c     now reverse the digits
c
      iptr = 1
      endptr = width
      if (str(iptr) .eq. asc('-')) iptr = iptr + 1
20    if (iptr .lt. endptr) then
         tch = str(iptr)
         str(iptr) = str(endptr)
         str(endptr) = tch
         iptr = iptr + 1
         endptr = endptr - 1
         go to 20
      endif
      itos = width
      return
      end
      subroutine getemsg(strng)

ccc   getemsg - get an error message string for the current error.
c
*call kermcom
      integer direc(8,2)
      integer packnam(9,0:6)
      data direc / 115, 101, 110, 100, 4*0,
c                    s    e    n    d
     +             114, 101,  99, 101, 105, 118, 101, 0 /
c                    r    e    c    e    i    v    e
      data packnam / 85,  78,  75,  78,  79,  87,  78, 2*0,
c                     u    n    k    n    o    w    n
     +               73, 110, 105, 116, 5*0,
c                     i    n    i    t
     +               70, 105, 108, 101, 110,  97, 109, 101, 0,
c                     f    i    l    e    n    a    m    e
     +               68,  97, 116,  97, 5*0,
c                     d    a    t    a
     +               69,  79,  70, 6*0,
c                     e    o    f
     +               66, 114, 101,  97, 107, 4*0,
c                     b    r    e    a    k
     +               83, 101, 114, 118, 101, 114, 3*0 /
c                     s    e    r    v    e    r
      if ((abortyp.and.initerr) .ne. 0) then
         ptyp = 1
      else if ((abortyp.and.filerr) .ne. 0) then
         ptyp = 2
      else if ((abortyp.and.dataerr) .ne. 0) then
         ptyp = 3
      else if ((abortyp.and.eoferr) .ne. 0) then
         ptyp = 4
      else if ((abortyp.and.brkerr) .ne. 0) then
         ptyp = 5
      else if ((abortyp.and.srvcmd) .ne. 0) then
         ptyp = 6
      else
         ptyp = 0
      endif
      dtyp = shift(abortyp.and.o"300",-6)
      if ((abortyp.and.toomany) .ne. 0) then
         call sprintf(strng,'^cannot @s @s packet',direc(1,
     +      dtyp),packnam(1,ptyp),0,0)
      else if ((abortyp.and.invalid) .ne. 0) then
         call sprintf(strng,
     +  '^received an invalid packet while trying to @s @s packet',
     +  direc(1,dtyp),packnam(1,ptyp),0,0)
      else if ((abortyp.and.seqerr) .ne. 0) then
         call sprintf(strng,
     +   '^packet sequence error while trying to @s @s packet',
     +   direc(1,dtyp),packnam(1,ptyp),0,0)
      else if ((abortyp.and.lclfile) .ne. 0) then
         call sprintf(strng,'^file is already local',0,0,0,0)
      else if ((abortyp.and.notlcl) .ne. 0) then
         call sprintf(strng,'^file is not local',0,0,0,0)
      else if ((abortyp.and.invfn) .ne. 0) then
         call sprintf(strng,'^invalid filename',0,0,0,0)
      else if ((abortyp.and.srvcmd) .ne. 0) then
         call sprintf(strng,'^unimplemented server command',0,0,0,0)
      endif
      return
      end
      integer function creat(fn)

ccc   creat - open a file for writing packet data to.
c
c     creat will try to create a file to write to.  if it
c     already exists, then it will fail.
c
*call kermcom
      character*10 filenam
c
c     get the dpc version of the filename
c
      call as2dpc(fn,filenam)
      call filchk(filenam)
      creat = fopen(filenam,create)
      return
      end
      subroutine getnow(mm,dd,yy,hr,min,sec)

ccc   get the current date and time.
c
*call kermcom
      character*10 date, time, string

      string = date()
      offset = ichar('0')
c$    if (ut2d .eq. 1)
      dd = (ichar(string(2:2))-offset)*10 + ichar(string(3:3))-offset
      mm = -1
      if (string(5:7) .eq. 'jan') then
         mm = 1
      else if (string(5:7) .eq. 'feb') then
         mm = 2
      else if (string(5:7) .eq. 'mar') then
         mm = 3
      else if (string(5:7) .eq. 'apr') then
         mm = 4
      else if (string(5:7) .eq. 'may') then
         mm = 5
      else if (string(5:7) .eq. 'jun') then
         mm = 6
      else if (string(5:7) .eq. 'jul') then
         mm = 7
      else if (string(5:7) .eq. 'aug') then
         mm = 8
      else if (string(5:7) .eq. 'sep') then
         mm = 9
      else if (string(5:7) .eq. 'oct') then
         mm = 10
      else if (string(5:7) .eq. 'nov') then
         mm = 11
      else if (string(5:7) .eq. 'dec') then
         mm = 12
      endif
      yy = (ichar(string(9:9))-offset)*10 + ichar(string(10:10))-offset
c$    endif
c$    if (nos .eq. 1)
      yy = (ichar(string(2:2))-offset)*10 + ichar(string(3:3))-offset
      mm = (ichar(string(5:5))-offset)*10 + ichar(string(6:6))-offset
      dd = (ichar(string(8:8))-offset)*10 + ichar(string(9:9))-offset
c$    endif
c$    if (nosbe .eq. 1)
       dd = (ichar(string(5:5))-offset)*10 + ichar(string(6:6))-offset
       mm = (ichar(string(2:2))-offset)*10 + ichar(string(3:3))-offset
       yy = (ichar(string(8:8))-offset)*10 + ichar(string(9:9))-offset
c$    endif
      yy = yy + 1900
      string = time()
      hr  = (ichar(string(2:2))-offset)*10 + ichar(string(3:3))-offset
      min = (ichar(string(5:5))-offset)*10 + ichar(string(6:6))-offset
      sec = (ichar(string(8:8))-offset)*10 + ichar(string(9:9))-offset
      return
      end
      subroutine filchk(fn)

ccc   filchk - check and fix filename validity.
c
c     check validity of filename.  invalid characters are dropped
c     and the filename is truncated at 7 characters.  if there
c     is still not a valid filename (all characters were bad) then
c     use file kermdat.
c
*call kermcom
      boolean ch
      character *(*) fn
      integer ptr,length
c
      ptr = 0
      length = len(fn)
      do 2 i=1,7
    1    ptr = ptr + 1
         if (ptr .gt. length) go to 3
         ch = ichar(fn(ptr:ptr))
         if (ch .lt. 1 .or. ch .gt. 36) go to 1
         fn(i:i)=fn(ptr:ptr)
    2 continue
      i = 8
c
    3 if (length .gt. 7) then
         do 4 j=i,length
            fn(j:j) = ' '
    4    continue
      endif
c
c     use our magic file if no valid characters in the file name.
c     this can happen as some micros allow things like '&' for
c     a file name.  note that nos allows a digit in the first
c     character of an lfn while scope and nos/be do not.
c
c$    if(ut2d .eq. 1 .or. nosbe .eq. 1  .or.  scope .eq. 1)
      if(ichar(fn(1:1)) .lt. 1  .or.  ichar(fn(1:1)) .gt. 26)
     +  fn = 'kermdat'
c$    else
      if(ichar(fn(1:1)) .lt. 1  .or.  ichar(fn(1:1)) .gt. 36)
     +  fn = 'kermdat'
c$    endif
      return
      end
      subroutine rdparam(pdata)

ccc   rdparam - get the packet parameters from the other kermit.
c
*call kermcom
      boolean pdata(*)
      integer params(11)
      equivalence (params,spksiz)
c
c     define ctl and unchar statement functions
c
      ctl(ascch) = ascch .xor. o"100"
      unchar(ascch) = ascch - blank
c
c     cycle through the list of parameters until the end-of-list
c     is found (a 0 byte).
c
      i = 1
10    if (pdata(i) .ne. 0) then
c
c        is it the pad character?
c
         if (i .eq. 4) then
            params(i) = ctl(pdata(i))
            if (params(i) .eq. 0) params(i) = null
c
c        is it the quote character?
c
         else if (i .eq. 6) then
            params(i) = pdata(i)
         else
            if (unchar(pdata(i)) .ne. 0) then
               params(i) = unchar(pdata(i))
            endif
         endif
         i = i + 1
         go to 10
      endif
      return
      end
      subroutine remove(fn)

ccc   remove - remove a file from the local file list.
c
*call kermcom
      boolean fn(*)
      character*10 lfn
c
c     quit if nothing useful in the file name array.
c
      if(fn(1) .eq. 0) return
c
c     convert the file name to display code.
c
      call as2dpc(fn,lfn)
c
c     get rid of the file.
c
      call retfile(lfn)
      return
      end
      subroutine strcpy(s1,s2)

ccc   strcpy - copy one ascii string to another
c
*call kermcom
      boolean s1(*),s2(*)

      i1 = 1
10    s2(i1) = s1(i1)
      if (s1(i1) .ne. 0) then
         i1 = i1 + 1
         go to 10
      endif
      return
      end
      integer function slen(str)

ccc   slen - return the length of a zero terminated ascii string buffer.
c
*call kermcom
      boolean str(*)

      i = 0
10    if (str(i+1) .ne. 0) then
         i = i + 1
         go to 10
      endif
      slen = i
      return
      end
      integer function sndpar(pdata)

ccc   sndpar - set up parameters to send to other kermit.
c
*call kermcom
      boolean pdata(*)
c
c     define ctl and tochar statement functions
c
      ctl(ascch) = ascch .xor. o"100"
      tochar(ascch) = ascch + blank
c
c     send what we want
c
      pdata(1) = tochar(packsiz)
      pdata(2) = tochar(timeout)
      pdata(3) = tochar(npad)
      pdata(4) = ctl(padch)
      pdata(5) = tochar(eolch)
      pdata(6) = quotech
      pdata(7) = 0
c
c     return length of how many things we want to set
c
      sndpar = 6
c
c     other values are set by default to not operate
c
      return
      end
      subroutine sleep(seconds)

cc    sleep - use periodic recall to delay things.
c
c     entry   seconds = integer number of seconds to sleep.
c
c     exit    indicated number of seconds has elapsed.
c
*call kermcom

      do 100 i=1,seconds
         call delay(1000)
100   continue
      return
      end
      subroutine delay(msec)

cc    delay - delay for a few milliseconds.
c
c     entry   msec = delay time in milliseconds.
c
c     exit    time has elapsed.
c
c     notes   works for scope, ut2d, and nos/be systems.  nos users must
c             change the computation to account for the difference
c             in data returned by rtime macro.
c
*call kermcom
c
c    use real time clock to control delay period.
c
      call rtime(rtcl)
      rtcl = and(rtcl,compl(mask(24)))
10    call rtime(rtcl1)
      rtcl1 = and(rtcl1,compl(mask(24)))
c
c     convert from seconds/4096 to milliseconds.
c
      if((rtcl1-rtcl)/4.096 .gt. msec) return
c
c     sleep for 100 milliseconds.
c
      call recall(0)
      go to 10

      end
      subroutine echoplx(ecmode)


***   echoplx - set echoplex mode for 2550 front end.
*
*     depends on u of arizona modifications to cci, plus a u of
*     arizona pp routine 'uui'.  this subroutine is only called
*     from stty if uariz is defined.
*
*     entry   ecmode = 'on' or 'off' to enable or disable echoplex.
*
*     exit    uui called to change echoplex mode.


*call kermcom

c
c     don't compile if not university of arizona
c
c$    if (uariz .eq. 1)
      boolean echofnc, echooff, echoon, uuiwd
      character*(3) ecmode
      parameter (echofnc=o"10",echooff=0,echoon=1)

      if(ecmode .eq. 'on') then
          uuiwd = or(shift(echoon,12),echofnc)
      elseif(ecmode .eq. 'off') then
          uuiwd = or(shift(echooff,12),echofnc)
      else
          call remark(' kermit - invalid echoplex option.')
          call abtp("nd")
      endif
      call mtr(l"uui","rcl",locf(uuiwd))

*     nudge 2550 into processing the reconfiguration message
*     sent by the uui call, so echo gets fully reset, even if
*     next kermit operation is a read, not a write.

      call putc(null,stdout)
      call fflush(stdout)
c$    endif
      return

      end
      integer function getrec(fd,wsa,wsal,eofflag)

cc    getrec - get a record from a file.
c
c     nread = getrec(fd,wsa,wsal,eofflag)
c
c     entry   fd = file descriptor.
c             wsal = length of wsa.
c
c     exit    wsa contains data record.
c             nread = number of words actually placed in wsa
c             eofflag = .true. if eof hit (iff nread .eq. 0).
c
c     notes   performs display to ascii conversion if needed.

*call kermcom

      parameter (intrcom = 42, asc128 = 22, asc256 = 23)
      parameter (first = 1, in = 2, out = 3, limit = 4, intwd = 5)
      boolean status, wsa(wsal)
      logical eofflag

      eofflag = .false.
c
c     start read if possible, and determine disk character set
c     if not in raw data mode.
c
1     if(.not. ctdev(fd)  .and.  and(fets(0,fd),o"1") .eq. o"1") then
          if(fets(in,fd) .eq. fets(out,fd)  .and.
     +      and(fets(0,fd),o"20") .eq. 0) then
              call read(fets(0,fd))
              if(.not. rawmode) then
                  cset = xscs(fets(0,fd))
                  if(cset .eq. 0) go to 1
                  if (cset .eq. -1) then
                     dskcset = dsknos8
c$    if (ut2d .eq. 1)
c     must set nos bit for screwy coded read routines
                     fets(first,fd) = fets(first,fd)
     +                  .or.shift(1,nosbit)
c$    endif
                  elseif(cset .eq. -2) then
                     dskcset = dskut8
c$    if (ut2d .eq. 1)
c     must clear nos bit for screwy coded read routines
                     fets(first,fd) = and(fets(first,fd),
     +                  .not.shift(1,nosbit))
c$    endif
                  endif
                  if(cset .lt. 0) then
c$    if (ut2d .eq. 1)
c     these are needed for strange coded read routines.
                     fets(first,fd) = fets(first,fd).or.shift(1,asciiio)
c$    endif
                  else
                     dskcset = dskdpc
c$    if (ut2d .eq. 1)
                     fets(first,fd) = and(fets(first,fd),
     +                  .not.shift(1,asciiio))
c$    endif
                  endif
              endif
          endif
      endif
c
c     process terminal devices.
c
      if(ctdev(fd)) then
c$    if (ut2d .eq. 1) then
         fets(first,fd) = or(fets(first,fd),shift(1,asciiio))
c$    else
          fets(first,fd) = or(fets(first,fd),shift(1,intrcom))
          fets(intwd,fd) = shift(1,asc128)
          if(binmode .or. rawmode) fets(intwd,fd) = shift(1,asc256)
c$    endif
c$    if (nos .eq. 1)
c$    if (noslvl .ge. 602)
c
c        wait for input checking for timeout on read
c
          if (binmode .or. rawmode) then
             nosdlay = stimout * 1000
          else
             nosdlay = rdelay
          endif
          do 10 irdl = 1, nosdlay, 24
          if (nosctab().ne.0) goto 11
          call noswait
10        continue
          if (binmode .or. rawmode) then
             call remark(' kermit - read timeout....')
          endif
c$    else
          if (rdelay .gt. 0) call delay(rdelay)
c$    endif
11        continue
c$    else
          if (rdelay .gt. 0) call delay(rdelay)
c$    endif
          call readc(fets(0,fd),wsa,wsal,status)
          if(status .eq. 0) then
              nread = wsal
          elseif(status .lt. 0) then
c$    if (nos .eq. 1)
              nread = 0
c
c        give poor user another prompt
c
              if ((.not. rawmode) .and. (.not. binmode)) then
                 call memstat
                 call fprintf(stdout,'^kermit-170>',0,0,0,0)
                 call fflush(stdout)
                 call writer(fets(0,stdout))
                 call read(fets(0,fd))
              endif
              goto 1
c$    else
              nread = 0
              eofflag = .true.
c$    endif
          else
              nread = status - locf(wsa)
              fets(0,fd) = or(and(fets(0,fd),shift(mask(44),2)),ciord)
              if(nread .le. 0) go to 1
          endif
c$    if (nos .eq. 1)
          if (nread .gt. 0) call conbuff(wsa, nread, eofflag, status)
c$    endif
          getrec = nread
          if(nread .gt. 0) getrec = findeol(wsa,nread,.not. binmode)
      else
c
c     process mass storage (disk) files.
c
          if(rawmode) then
              call readw(fets(0,fd),wsa,wsal,status)
          elseif((dskcset.and.dskasci) .ne. 0) then
              call readc(fets(0,fd),wsa,wsal,status)
          else
              call readc(fets(0,fd),wsa(wsal / 2 + 1),wsal / 2, status)
              if(status .ge. 0) then
                  call edl(wsa,wsa(wsal / 2 + 1),wsal / 2,status)
              endif
          endif
c
c     process mass storage (disk) file status return.
c
          if(status .eq. 0) then
              getrec = findeol(wsa,wsal,.not. rawmode)
          elseif(status .gt. 0) then
              getrec = findeol(wsa,status - locf(wsa),.not. rawmode)
              fets(0,fd) = or(and(fets(0,fd),shift(mask(44),2)),ciord)
              if(getrec .le. 0) go to 1
          elseif(status .eq. -1) then
              getrec = 0
              fets(0,fd) = or(and(fets(0,fd),shift(mask(44),2)),ciord)
c$    if (ut2d .eq. 1) then
              eofflag = .true.
c$    else
              go to 1
c$    endif
          else
              getrec = 0
              eofflag = .true.
          endif
      endif
      return
      end
      integer function findeol(wsa,wsal,addnel)

cc    findeol - find eol byte in working buffer.
c
c     len = findeol(wsa,wsal,addnel)
c
c     entry   wsa = line image.
c             wsal = length of wsa.
c             addnel = .true. if a nel should be stuffed in buffer.
c
c     exit    len = length of data line in words.

*call kermcom

      boolean wsa(wsal)
      logical addnel
c
c     if the line length is zero, return zero length.
c
      if(wsal .le. 0) then
          findeol = 0
          return
      endif
c
c     find eol, and stick nel in if needed.
c
      do 10 i = 1, wsal
          if((and(wsa(i),o"7777") .eq. 0) .or.
     +       (and(wsa(i),o"7777") .eq. nel)) then
            if(addnel .and. (dskcset.ne.dskut8)) wsa(i) = or(wsa(i),nel)
            findeol = i
            return
          endif
10    continue
      if(addnel) wsa(wsal) = or(and(wsa(wsal),mask(48)),nel)
      findeol = wsal
      return
      end
      subroutine edl(ascbuf,dpcbuf,dpcbufl,status)

cc    edl - expand display code line.
c
c     call edl(ascbuf,dpcbuf,dpcbufl,status)
c
c     entry   dpcbuf = display code line image.
c             dpcbufl = dimensioned size of dpcbuf.
c             status = readc status.
c
c     exit    ascbuf = ascii line.
c             status = lwa + 1 of data converted, iff status was
c             non-zero on entry to edl.
c
c     notes   edl must not be called with negative status values.

*call kermcom

      boolean ascbuf(*), dpcbuf(dpcbufl), dpcch, status, tempdpc
c
c     determine number of words in buffer (worst case).
c
      wc = dpcbufl
      if(status .gt. 0) wc = status - locf(dpcbuf)
      if(wc .le. 0) then
          status = locf(ascbuf)
          return
      endif
c
c     now scan for zero byte.
c
      do 10 i = 1, wc
          if(and(dpcbuf(i),o"7777") .eq. 0) go to 1
10    continue
c
c     no eol was found, so we force one in the last word.
c
      i = wc
      dpcbuf(i) = and(dpcbuf(i),mask(48))
c
c     at this point, 'i' contains the position of the eol word.
c
1     eolwd = i
      ascbuf(1) = 0
      if(eolwd .eq. 1  .and.  dpcbuf(eolwd) .eq. 0) return
      if(eolwd .gt. 1  .and.  dpcbuf(eolwd) .eq. 0  .and.
     +  and(dpcbuf(eolwd - 1),o"77") .eq. 0) eolwd = eolwd - 1
c
c     now we convert everything up to the eol word, but not the eol word
c     itself, as we do not want to 'convert' the line terminator.
c
      wc = 0
      if(eolwd .gt. 1) then
          call xsxt(dpcbuf,eolwd - 1,ascbuf,uascii)
          wc = 2 * (eolwd - 1)
      endif
c
c     now convert the eol word.  code can handle overlapping buffers.
c
      wc = wc + 1
      tempdpc = dpcbuf(eolwd)
      ascbuf(wc) = 0
      ascbuf(wc + 1) = 0
      do 20 i = 0, 9
          tempdpc = shift(tempdpc,6)
          dpcch = and(tempdpc,o"77")
          tempdpc = and(tempdpc,mask(54))
          if(tempdpc .eq. 0  .and. dpcch .eq. 0) then
              if(status .gt. 0) status = locf(ascbuf(wc + i / 5)) + 1
              return
          endif
          ascbuf(wc + i / 5) = or(ascbuf(wc + i / 5),
     +      shift(uascii(dpcch),60 - 12 * (mod(i,5) + 1)))
20    continue
      if(status .gt. 0) status = locf(ascbuf(wc + 1)) + 1
      return
      end
          ident  makefet
          entry  makefet
          sst
          syscom b1
 makefet  title  makefet - make a file environment table.
          comment make a file environment table.
 makefet  space  4,10
**        makefet - make a file environment table.
*
*         call makefet(lfn,fet,fetl,ciobuf,ciobufl)
*
*         entry  (lfn) = is the character*7 file name.
*                (fet) = an array to receive the fet.
*                (fetl) = length of fet in words (minimum of 5).
*                (ciobuf) = an array to be used as the cio buffer.
*                (ciobufl) = the length of ciobuf.
*
*         exit   fet built.


 makefet  subr               entry/exit
          sb1    1           always
          sa2    a1+b1
          sb6    x2          (b6) = fet address
          sa2    a2+b1
          sa3    x2          (x3) = fet length
          sa2    a2+b1
          sx6    x2          (x6) = fwa of cio buffer
          sa2    a2+b1
          sa2    x2          (x2) = buffer length
          ix7    x6+x2       (x7) = limit pointer
          sa6    b6+2        set in and out
          sa6    a6+b1
          sa7    a6+b1       set limit
          sx7    x3-5        (x7) = fet length - 5
          sb7    x7
          lx7    18
          bx6    x6+x7       add (fet length - 5) to first
          sa6    b6+b1       set first
          mx7    0
 makefet1 gt     b7,b0,makefet2  if no more words to set
          sa7    a7+b1
          sb7    b7-b1
          eq     makefet1    loop till done

 makefet2 sb7    b1          length of transfer
          rj     =xmfs>      move lfn into fet
          sa1    b6-b1
          rj     =xbtz>      convert blanks to 00b
          sx1    b1          add complete bit to lfn
          bx6    x6+x1
          sa6    a1
          eq     makefetx    return

          end
*if def,nosbe
          ident  cfe
          entry  cfe
          syscom b1
 cfe      title  cfe - check files existance.
          comment check files existance.
 cfe      space  4,10
**        cfe - check files existance.
*
*         logical cfe, result
*
*         result =  cfe(lfn)
*
*         entry  (lfn) = is the character*7 file name.
*
*         exit   (result) = .true. if file exists.
*                (result) = .false. otherwise.


 cfe      subr               entry/exit
          sb1    1           always
          sb6    cfea
          sb7    b1
          rj     =xmfs>      move lfn into filinfo block
          sa1    cfea
          rj     =xbtz>      convert blanks to 00b
          sx1    4           block length
          lx1    12
          bx6    x6+x1
          sa6    a1
          mx7    0           clear rest of block
          sa7    a6+b1
          sa7    a7+b1
          sa7    a7+b1
          sa7    a7+b1
          filinfo cfea       check on file
          mx6    0           assume no file (.false.)
          mx7    12
          sa1    cfea+1
          bx7    x7*x1       (x7) = device code if file exists, or 0
          zr     x7,cfex     if no file
          mx6    -1          set file found (.true.)
          eq     cfex        return

 cfea     vfd    42/**,6/4,12/0  filinfo block
          bssz   4

          end
*endif
*if -def,nosbe
          ident  cfe
          entry  cfe
          sst
          syscom b1
 cfe      title  cfe - check files existance.
          comment check files existance.
 cfe      space  4,10
**        cfe - check files existance.
*
*         logical cfe, result
*
*         result =  cfe(lfn)
*
*         entry  (lfn) = is the character*7 file name.
*
*         exit   (result) = .true. if file exists.
*                (result) = .false. otherwise.


 cfe      subr               entry/exit
          sb1    1           always
          sb6    cfea
          sb7    b1
          rj     =xmfs>      move lfn into filinfo block
          sa1    cfea
          rj     =xbtz>      convert blanks to 00b
          sx1    b1          set complete
          bx6    x6+x1
          sa6    a1
          mx7    0           clear rest of block
          sa7    a6+b1
          sa7    a7+b1
          sa7    a7+b1
          sa7    a7+b1
          status cfea        check on file
          mx6    0           assume no file (.false.)
          mx7    11
          lx7    12
          sa1    cfea
          bx7    x7*x1       (x7) = 0 if file doesn't exist
          zr     x7,cfex     if no file
          mx6    -1          set file found (.true.)
          eq     cfex        return

cfea      bssz   1           fake fet

          end
*endif
      subroutine conbuff (buf, wc, eofflag, status)
*call,kermcom
c$    if (nos .eq. 1)
      boolean buf(1), nosbuf(maxwd)
      logical eofflag, conbug
      data  conbug / .false. /

c     check for special *eof* flag.

      if (wc .eq. 1 .and. buf(1) .eq. shift(r"^<",48)) then
         wc = 0
         eofflag = .true.
         return
      endif

c     copy the buffer first

      savewc = wc
      do 1 i = 1, wc
1     nosbuf(i) = buf(i)

      if (debug .ne. 0 .and. conbug) then
         call fprintf(debugfd, 'conbuff called.\n',0,0,0,0)
      endif

      ips = 0
      ipw = 1
      ops = 60
      opw = 1
      buf(opw) = 0
c
c     now scan for zero byte.
c
      do 2 i = 1, wc
          if(and(nosbuf(i),o"7777") .eq. 0) go to 3
2     continue
c
c     no eol was found, so we force one in the last word.
c
      i = wc
      nosbuf(i) = and(nosbuf(i),mask(48))
c
c     at this point, 'i' contains the position of the eol word.
c
3     eolwd = i
      if(eolwd .eq. 1  .and.  nosbuf(eolwd) .eq. 0) return
c
c        check for the famous 66-bit end-of-line!!!
c
      if(eolwd .gt. 1  .and.  nosbuf(eolwd) .eq. 0  .and.
     +  and(nosbuf(eolwd - 1),o"77") .eq. 0) eolwd = eolwd - 1

c     calculate the character position of the last *real* character!

      do 4 j = 6, 54, 6
      if ((compl(mask(60-j)) .and. nosbuf(eolwd)) .ne. 0) then
         lps = 72 - j
         goto 5
      endif
4     continue
      lps = 6
c
c     now convert the characters!
c
5     nose = 0
      lch = 0
      if (debug .ne. 0 .and. conbug) then
         call fprintf(debugfd,' conbuff - wc @d\n', wc,0,0,0)
         call fprintf(debugfd,' conbuff - el @d\n', eolwd,0,0,0)
         call fprintf(debugfd,' conbuff - ls @d\n', lps,0,0,0)
      endif

10    ips = ips + 6
      if (ips .eq. 66) then
         ips = 6
         ipw = ipw + 1
      endif
      if (debug .ne. 0 .and. conbug) then
         call fprintf(debugfd,' conbuff - is @d\n', ips,0,0,0)
         call fprintf(debugfd,' conbuff - iw @d\n', ipw,0,0,0)
      endif
      if (ipw .eq. eolwd .and. ips .ge. lps) then
         if (.not.rawmode) then
            ch = nel
            lch = nel
            goto 40
         else
            goto 50
         endif
      endif

      ich = and(shift(nosbuf(ipw), ips), o"77")
      if (debug .ne. 0 .and. conbug) then
         call fprintf(debugfd,' conbuff - ich @d\n', ich,0,0,0)
      endif

      if (nose .eq. 0) then
         if (ich .eq. r"@") then
            nose = ich
         else if (ich .eq. r"^") then
            nose = ich
         else if (ich .ge. r"a" .and. ich .le. r"z") then
            if (.not.(binmode .or. rawmode)) then
               ch = lascii(ich)
            else
               ch = uascii(ich)
            endif
         else
            ch = uascii(ich)
         endif
      else if (nose .eq. r"^") then
         nose = 0
         if (ich .ge. r"a" .and. ich .le. r"z") then
            ch = lascii(ich)
         else if (ich .ge. r"0" .and. ich .le. r"4") then
            ch = ich + o"140"
         else if (ich .ge. r"5" .and. ich .le. r";") then
            ch = ich - o"40"
            if (ch .eq. 0) ch = nul
         else
            ch = nul
         endif
      else if (nose .eq. r"@") then
         nose = 0
         if (ich .eq. r"a") then
            ch = lascii(r"@")
         else if (ich .eq. r"b") then
            ch = lascii(r"^")
         else if (ich .eq. r"d") then
            ch = lascii(r":")
         else if (ich .eq. r"g") then
            ch = o"140"
         else if (ich .eq. r"h") then
            ch = cr
         else if (ich .eq. r"i") then
            ch = lf
         else
            ch = nul
         endif
      endif
c
c        process this character.
c
      if (nose .ne. 0) then
         goto 10
      else if (ch .lt. 0) then
         goto 10
      else if (ch .eq. lf .and. .not. rawmode) then
         goto 10
      else if (ch .eq. cr .and. .not. rawmode) then
         ch = nel
      else if (ch .eq. nul .and. .not. rawmode) then
         goto 10
      endif
c
c        really process the character.
c
40    if (debug .ne. 0 .and. conbug) then
         call fprintf(debugfd,' conbuff - ich @d\n', ich,0,0,0)
         call fprintf(debugfd,' conbuff -  ch @d\n',  ch,0,0,0)
         call fprintf(debugfd,' conbuff -  ch @c\n',  ch,0,0,0)
      endif
c
c        put it in the buffer
c
      if (ops .eq. 0) then
         ops = 48
         opw = opw + 1
         buf(opw) = 0
      else
         ops = ops - 12
      endif
      buf(opw) = buf(opw) .or. shift(ch,ops)
      if (lch .eq. 0) goto 10

c        we are now done.

50    wc = opw
      if (debug .ne. 0 .and. conbug) then
         call fprintf(debugfd, ' conbuff exited.\n',0,0,0,0)
      endif
c$    endif
      return
      end