include std.def
# initr4 - initialize standard files
   subroutine initr4
   include iocom.rat
   include argcom.rat
   common /rat401/ lastc, buf
   character buf(MAXLINE)
   integer lastc
   integer ier, i
 
   lastc = 1
   buf(lastc) = NEWLINE
   do i = 1,MAXOPEN
      actun(i) = EOS
   mxfile = MAXOPEN
   upflag = .true.				# fold commands to upper case
   noread = .true.				# haven't read command line yet
   call opn(ERROUT, 'TI:', 'W', ier)
   if (ier ~= 0) stop 'can''t open ERROUT'
   call opn(STDIN, 'TI:', 'F', ier)   # open with carriagecontrol=fortran
   if (ier ~= 0) call error('can''t open STDIN.')
   tiin = .true.
   call opn(STDOUT, 'TI:', 'W', ier)
   if (ier ~= 0) call error('can''t open STDOUT.')
   call opn(CMDIN, 'TI:', 'F', ier)
   if (ier ~= 0) call error('can''t open CMDIN.')
   call errset(28,.true.,.false.,.true.,.false.,15)  # close error
   call errset(29,.true.,.false.,.true.,.false.,15)  # no such file
   call errset(30,.true.,.false.,.true.,.false.,15)  # open failure
   call errset(43,.true.,.false.,.false.,.false.,15) # file name specification
   return
   end
# endr4 - close up shop
   subroutine endr4
   call closec(STDOUT, SAVEF)
   call closec(STDIN, SAVEF)
   call closec(ERROUT, SAVEF)
   call exit
   end
# create - open a new file
   integer function create(name, stat)
   character name(ARB)
   integer open
   byte stat
   create = open(name,stat)
   if (create == ERR) {
      call putlin(name, ERROUT)
      call remark(': can''t create.')
      }
   return
   end
# openc - open a file, print can't message if error
   integer function openc(name, stat)
   character name(ARB), stat
   integer open
   openc = open(name, stat)
   if (openc == ERR) {
      call putlin(name, ERROUT)
      call remark(': can''t open.')
      }
   return
   end
# open - open a file
   integer function open(name, stat)
   character name(ARB), stat, buf(FILENAMESIZE)
   integer ier
   include iocom.rat
   call scopy(name, 1, buf, 1)
   if (stat ~= PRINTF) call defnam(buf, 'SY:', EOS, EOS)
   do i = 1, mxfile
    { if (actun(i) ~= EOS) next
      call opn(i+PRINTER,buf,stat,ier)
      if (ier .ne. 0) open = ERR
      else {
         open = i+PRINTER
         actun(i) = stat
         }
      return
      }
   call remark('too many files opened.')
   open = ERR
   return
   end
# closec - close a file, print message if error
   integer function closec(f, stat)
   character stat
   integer f, closel
   closec = closel(f, stat)
   if (closec == ERR)
      call remark('error closing file.')
   return
   end
 
# close - close a file
  subroutine close(f)
  integer f
  call closel(f, SAVEF)
  return
  end
 
# closel - close a file
   integer function closel(iunit,stat)
   include iocom.rat
   integer iunit
   character stat
   closel = ERR
   if (iunit > PRINTER)
      if (actun(iunit-PRINTER) == EOS) {
         closel = YES
         return
         }
   if (stat == SAVEF)
%
      close(unit=iunit,dispose='KEEP',err=99)
%
   else if (stat == DELETEF)
%
      close(unit=iunit,dispose='DELETE',err=999)
%
   else if (stat == PRINTF)
%
      close(unit=iunit,dispose='PRINT',err=999)
%
   else {call remark('illegal command in closel.'); return}
   if (iunit > PRINTER) actun(iunit-PRINTER) = EOS
   closel = YES
99 continue
   return
999 continue
%
      close(unit=iunit, dispose='KEEP', err=99)
%
   if (iunit > PRINTER) actun(iunit-PRINTER) = EOS
   return
   end
# cant - print can't open file message and stop
   subroutine cant(buf)          #<wpw>
   character buf(ARB)
   call putlin(buf, ERROUT)
   call remark(': can''t open.')
   call exit
   end
# defnam - add default device, uic, and extension to filename if not present
   subroutine defnam(file, dev, uic, ext)
   character file(ARB), ext(ARB), dev(ARB), uic(ARB), tfile(FILENAMESIZE)
   integer i, concat, length, index
   if (file(length(file)) == ':') return
   call scopy(file, 1, tfile, 1)
   file(1) = EOS
   if (dev(1) ~= EOS)
      if (index(tfile, ':') == 0)
         i = concat(file, dev, FILENAMESIZE)
   if (uic(1) ~= EOS)
      if (index(tfile, '[') == 0)
         i = concat(file, uic, FILENAMESIZE)
   i = concat(file, tfile, FILENAMESIZE)
   if (index(tfile, '.') == 0) {
      i = concat(file, '.', FILENAMESIZE)
      i = concat(file, ext, FILENAMESIZE)
      }
   return
   end
# error - print fatal error message, then die
   subroutine error(buf)
   byte buf(ARB)
   call remark(buf)
   call exit
   end
# outlin - output a line
   subroutine outlin(buf, f)
   character buf(ARB)
   integer f
   call putlin(buf, f)
   call putch(NEWLINE, f)
   return
   end
# remark - print message; assure NEWLINE
 subroutine remark (line)
 character line(ARB)
 integer i

 for (i=1; line(i) ~= EOS; i=i+1) {
	if (line(i) == '.'  &  line(i+1) == EOS)
		break
	call putch (line(i), ERROUT)
	}
 if (i == 1)
        call putch (NEWLINE, ERROUT)
 else if (line(i-1) ~= NEWLINE)
	call putch (NEWLINE, ERROUT)
 return
 end
# getrec - read a record and insert NEWLIN and EOS
   integer function getrec(buf, f)
   character buf(ARB), nbuf(MAXCHARS)
   integer f, nc, ier, closel
   include iocom.rat
10 continue
   call get(f, buf, MAXCARD, nc)
   if (nc < 0)
      if (nc == EOF) {
         getrec = EOF
         buf(1) = EOF
         buf(2) = EOS
         if (f == STDIN) {		# close, then reopen STDIN
            if (closel(STDIN, SAVEF) == ERR)
               call error('can''t close STDIN in getrec.')
            call opn(STDIN, 'TI:', FORTRAN, ier)
            if (ier ~= 0) call error('can''t open STDIN in getrec.')
            tiin = .true.
            }
         }
      else {
         call putlin('fcs error code ', ERROUT)
         call itoc(nc, nbuf, MAXCHARS)
         call putlin(nbuf, ERROUT)
         call remark(' returned in getrec.')
         if (.true.) goto 10
         }
   else {
      getrec = nc+1
      buf(getrec) = NEWLINE
      buf(getrec+1) = EOS
      }
   return
   end
# getlin - get a line from a file
   integer function getlin(inbuf, in)
   common /rat401/ lastc, buf
   character buf(MAXLINE)
   integer lastc
   character inbuf(ARB)
   integer in, getrec
   if (buf(lastc) ~= NEWLINE) {  # still some chars in buf
      getlin = 0
      repeat {
         lastc = lastc+1
         getlin = getlin+1
         inbuf(getlin) = buf(lastc)
         } until (buf(lastc) == NEWLINE)
      inbuf(getlin+1) = EOS
      }
   else
      getlin = getrec(inbuf, in)
   return
#$# getlin - get a line from a file
#$   integer function getlin(buf,in)
#$   character buf(MAXLINE)
#$   character c, getch
#$   integer in,i
#$   i = 0
#$   repeat {
#$      i = i+1
#$      buf(i) = getch(c,in)
#$      }
#$      until (buf(i) == NEWLINE  |  buf(i) == EOF)
#$   if (buf(i) == EOF) getlin = EOF
#$   else getlin = i
#$   if (i >= MAXLINE) call error('buffer overflow in getlin.')
#$   else buf(i+1) = EOS
#$   return
#$   end
   end
# getch - get characters from file
   character function getch(c, f)
   common /rat401/ lastc, buf
   character buf(MAXLINE)
   integer lastc
   character c
   integer f, nc, getrec
   if (buf(lastc) == NEWLINE) {
      nc = getrec(buf, f)
      if (nc >= 0)
         lastc = 0
      else {
         c = EOF
         getch = EOF
         buf(3) = NEWLINE
         lastc = 3
         return
         }
      }
   lastc = lastc + 1
   c = buf(lastc)
   getch = c
   return
#$# getch - get characters from file
#$   character function getch(c, f)      #<wpw>     integer->character
#$   character buf(MAXLINE), c, buf2(MAXCARD)
#$   integer f, i, lastc, nc
#$   equivalence (buf, buf2)
#$   data lastc /MAXLINE/, buf(MAXLINE) /NEWLINE/
#$   # note: MAXLINE = MAXCARD + 1
#$   if (buf(lastc) == NEWLINE | lastc >= MAXLINE) {
#$      read(f, 1, end=10) nc, buf2
#$         1 format(q,MAXCARD a1)
#$      buf(nc+1) = NEWLINE
#$      lastc = 0
#$      }
#$   lastc = lastc + 1
#$   c = buf(lastc)
#$   getch = c
#$   return
#$ 10   c = EOF
#$   getch = EOF
#$   return
#$   end
   end
# putch - put characters
   subroutine putch(c, f)
   character buf(MAXLINE), c, nbuf(MAXCHARS)
   integer f, istat, lastc, concat
   data lastc /0/
   if (lastc >= MAXCARD | c == NEWLINE) {
      call put(f, buf, lastc, istat)
      if (istat ~= 0) {
         lastc = itoc(istat, nbuf, MAXCHARS)
         call scopy('fcs error code ', 1, buf, 1)
         lastc = concat(buf, nbuf, MAXLINE)
         lastc = concat(buf, ' returned in putch', MAXLINE)
         call put(ERROUT, buf, lastc, istat)
         stop 'putch'
         }
      lastc = 0
      if (c == NEWLINE) return
      }
   lastc = lastc + 1
   buf(lastc) = c
   return
   end
# putlin - put out line by repeated calls to putch
   subroutine putlin(b, f)
   character b(ARB)
   integer f, i
   for (i = 1; b(i) ~= EOS; i = i + 1)
      call putch(b(i), f)
   return
   end
# usrbin - get name of major tools utility directory
#           CHANGE FOR EACH SYSTEM
 
  subroutine usrbin(name)
  character name(ARB)
 
# Insert the name of the directory where all the tools are kept
 
  call scopy('DP1:[6,110]', 1, name, 1)
  return
  end