#
#
#
#    RATFIV structured Fortran compiler
#    ==================================
#
#         Authors: Original by B. Kernighan and P. J. Plauger,
#                  with rewrites and enhancements by David Hanson and
#                  friends (U. of Arizona), Joe Sventek and Debbie
#                  Scherrer (Lawrence Berkely Laboratory), and
#                  William Wood (Institute For Cancer Research).
#
#         Address: William Wood
#                  Computer Center
#                  Institute For Cancer Research
#                  7701 Burholme Ave.
#                  Philadelphia, Pa. 19111
#                  (215) 728 2760
#
#         Version: 1.0
#
#         Date:   May 14, 1981
#
#
#
#      *******************************************************
#      *                                                     *
#      *      THIS SOFTWARE WAS DEVELOPED WITH SUPPORT       *
#      *      FROM THE NATIONAL INSTITUTES OF HEALTH:        *
#      *         NIH CA06927                                 *
#      *         NIH CA22780                                 *
#      *                                                     *
#      *      DIRECT INQUIRIES TO:                           *
#      *            COMPUTER CENTER                          *
#      *            THE INSTITUTE FOR CANCER RESEARCH        *
#      *            7701 BURHOLME AVENUE                     *
#      *            PHILADELPHIA, PENNSYLVANIA   19111       *
#      *                                                     *
#      *      NO WARRANTY OR REPRESENTATION, EXPRESS OR      *
#      *      IMPLIED, IS MADE WITH RESPECT TO THE           *
#      *      CORRECTNESS, COMPLETENESS, OR USEFULNESS       *
#      *      OF THIS SOFTWARE, NOR THAT USE OF THIS         *
#      *      SOFTWARE MIGHT NOT INFRINGE PRIVATELY          *
#      *      OWNED RIGHTS.                                  *
#      *                                                     *
#      *      NO LIABILITY IS ASSUMED WITH RESPECT TO        *
#      *      THE USE OF, OR FOR DAMAGES RESULTING FROM      *
#      *      THE USE OF THIS SOFTWARE                       *
#      *                                                     *
#      *******************************************************
#      *                                                     *
#      *      THIS SOFTWARE WAS DESIGNED FOR USE ON A        *
#      *      PDP-11/70 OPERATING UNDER IAS V3.0 USING       *
#      *      THE FORTRAN-IV PLUS COMPILER.                  *
#      *                                                     *
#      *******************************************************
#
# acopy - copy  size  lines from  fdi  to  fdo
   subroutine acopy(fdi, fdo, size)
   integer fdi, fdo, size
   integer*4 ni4, ncop
   ni4 = size
   call copy(fdi, fdo, ni4, ncop)
#$   integer getlin
#$   character buf(MAXLINE)
#$   integer fdi, fdo, i, size
#$   for (i = 1; i <= size; i = i + 1) {
#$      if (getlin(buf, fdi) == EOF)
#$         break
#$      call putlin(buf, fdo)
#$      }
   return
   end
# amove - move  name1  to  name2
   subroutine amove(name1, name2)
   character name1(ARB), name2(ARB)
   integer create, openl
   integer fd1, fd2
   fd1 = openl(name1, READ)
   if (fd1 == ERR)
      call cant(name1)
   fd2 = create(name2, WRITE)
   if (fd2 == ERR)
      call cant(name2)
   call fcopy(fd1, fd2)
   return
   end
# fcopy - copy file  in  to file  out
   subroutine fcopy(in, out)
   integer in, out
   integer*4 ni4, ncop
   data ni4/2 000 000/
   call copy(in, out, ni4, ncop)
#$   character buf(MAXLINE)
#$   integer getlin
#$   integer in, out
#$   while (getlin(buf, in) != EOF)
#$      call putlin(buf, out)
   return
   end
# 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 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 openl
   byte stat
   create = openl(name,stat)
   if (create == ERR) {
      call putlin(name, ERROUT)
      call remark(": can't create.")
      }
   return
   end
# remove - delete a file
   integer function remove(file)
   character file(ARB)
   integer openl, closel
   remove = openl(file,READDELETE)
   if (remove != ERR)
      remove = closel(remove, DELETEF)
   return
   end
# openc - open a file, print can't message if error
   integer function openc(name, stat)
   character name(ARB), stat
   integer openl
   openc = openl(name, stat)
   if (openc == ERR) {
      call putlin(name, ERROUT)
      call remark(": can't open.")
      }
   return
   end
# open - open a file
# openl - open a file
   integer function open(name, stat)
   entry openl(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, EOS, 'SY:', EOS, EOS, '.', .false.)
   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 error(": can't open.")
   end
# defnam - provide defaults for file name, reset new defaults
subroutine defnam(file, node, dev, uic, name, ext, reset)
byte file(FILENAMESIZE)
byte node(NODESIZE), dev(DEVSIZE), uic(UICSIZE), name(NAMESIZE), ext(EXTSIZE)
byte temp(FILENAMESIZE)
logical reset
integer l, j
integer index, bkscan, concat, scan
 
temp(1) = EOS
j = concat(temp, file(scan(file, ' ', 1)), FILENAMESIZE)
file(1) = EOS
 
j = 1
l = 0
call adstr(index(temp(j), ':'), j, l, file, temp, dev, DEVSIZE-1, reset)
call adstr(index(temp(j), ']'), j, l, file, temp, uic, UICSIZE-1, reset)
call adstr(bkscan(temp, ' .;', j) - j, j, l, file, temp, name, NAMESIZE-1,
            reset)
call adstr(bkscan(temp, ' ;', j) - j, j, l, file, temp, ext, EXTSIZE-1, reset)
l = concat(file, temp(j), FILENAMESIZE)		# append possible version
return
end
 
# adstr - support routine for defnam
subroutine adstr(i, j, l, file, tfile, str, mxstr, reset)
integer i, j, l, mxstr, k
integer concat, scan
byte file(1), tfile(1), str(1)
logical reset
 
if (i == 0)
  l = concat(file, str, FILENAMESIZE)
else {
  k = min0(mxstr, i)
  l = concat(file, tfile(j), l+1+k)
  j = scan(tfile, ' ', j+i)
  if (reset)
    call scopy(file, l+1-k, str, 1)
  }
return
end
# error - print fatal error message, then die
   subroutine error(buf)
   byte buf(ARB)
   call xitsta(4)
   if (buf(1) != EOS)
     call remark(buf)
   call endr4
   return
   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
# fskip - skip  n  lines on file  fd
   subroutine fskip(fd, n)
   integer fd, n
   integer*4 i4, ir4
   i4 = n
   call skip(fd, i4, ir4)
   return
#$# fskip - skip  n  lines on file  fd
#$   subroutine fskip(fd, n)
#$   character skplin
#$   integer fd, i, n
#$   for (i = 1; i <= n; i = i + 1)
#$      if (skplin(fd) == EOF)
#$         break
#$   return
#$   end
   end
# fsize - size of file in lines
   integer function fsize(fd)
   integer fd
   integer*4 i4, ir4
   data i4/2 000 000/
   call skip(fd, i4, ir4)
   if (ir4 > 32767) call error('file too big.')
   fsize = ir4
   rewind fd
   return
#$# fsize - size of file in lines
#$   integer function fsize(fd)
#$   character skplin
#$   integer fd
#$   for (fsize = 0; skplin(fd) != EOF; fsize = fsize + 1)
#$         ;
#$   rewind fd
#$   return
   end
#$# skplin - skip a line in a file
#$   character function skplin(f)
#$   integer f
#$   read(f,1,end=99,err=99)
#$      1 format()
#$   skplin = EOS
#$   return
#$99 skplin = EOF
#$   return
#$   end
# prompt - prompt for input from STDIN
   subroutine prompt(buf)
   include iocom.rat
   byte buf(ARB), tchar, tbuf(MAXLINE)
   integer i
   data tchar/1h./, tbuf(1)/'$'/
   if (!tiin) return	# return if STDIN is not pointing at the terminal
   for (i = 1; buf(i) != tchar & i < MAXLINE-1; i = i+1)
      tbuf(i+1) = buf(i)
   tbuf(i+1) = EOS
   call putlin(tbuf, STDIN)
   call putch(NEWLINE, STDIN)
   return
#$# prompt - output a prompt to ERROUT
#$   subroutine prompt(str)
#$   character str(ARB)
#$   integer i, length
#$   write(ERROUT,1) (str(i),i=1,length(str))
#$      1 format('$', MAXCARD a1)
#$   return
#$   end
   end
#$# inmap - convert left-adjusted ascii to right-adjusted ascii #<wpw>
#$   character function inmap(char)
#$   integer char,ichin
#$   byte lch(2)
#$   equivalence (ichin,lch(1))
#$   ichin = char
#$   lch(2) = 0
#$   inmap = ichin
#$   return
#$   end
#$# outmap - convert right-adjusted ascii to left-adjusted ascii  #<wpw>
#$   integer function outmap(char)
#$   character char
#$   outmap = char
#$   return
#$   end
# usrbin - get name of /usr/bin (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