*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:  russell@nyu.arpa 
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 
