#
#
#
#    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.                  *
#      *                                                     *
#      *******************************************************
#
#========== miscellaneous support for all programs ==========
# alldig - return YES if str is all digits
   integer function alldig (str)
   integer i
   character str(ARB)
   alldig = NO
   if (str(1) == EOS)
      return
   for (i=1; str(i) != EOS; i=i+1)
      if (str(i) < '0' | str(i) > '9')
         return
   alldig = YES
   return
   end
# ctoi - convert string at in(i) to integer, increment i
   integer function ctoi(in, i)
   character in(ARB)
   integer index
   integer d, i
   logical neg
   character minus
#   string digits "0123456789"
   character digits(11)
   data minus /'-'/
   data digits(1) /'0'/
   data digits(2) /'1'/
   data digits(3) /'2'/
   data digits(4) /'3'/
   data digits(5) /'4'/
   data digits(6) /'5'/
   data digits(7) /'6'/
   data digits(8) /'7'/
   data digits(9) /'8'/
   data digits(10) /'9'/
   data digits(11) /EOS/

   while (in(i) == ' ' | in(i) == TAB)
      i = i + 1
   if (in(i) == minus) {
     neg = .true.
     i = i + 1
     }
   else
     neg = .false.
   for (ctoi = 0; in(i) != EOS; i = i + 1) {
      d = index(digits, in(i))
      if (d == 0)      # non-digit
         break
      ctoi = 10 * ctoi + d - 1
      }
   if (neg)
      ctoi = -ctoi
   return
   end
# concat - concatenate two strings
   integer function concat(s1,s2,lim)
   character s1(ARB),s2(ARB)
   integer lim, i, length, l
   l = length(s1)
   for (i=l+1; i<lim & s2(i-l) != EOS; i=i+1) s1(i) = s2(i-l)
   s1(i) = EOS
   concat = i-1
   return
   end
# equal - compare str1 to str2; return YES if equal, NO if not
   integer function equal(str1, str2)
   character str1(ARB), str2(ARB)
   integer i
   for (i = 1; str1(i) == str2(i); i = i + 1)
      if (str1(i) == EOS) {
         equal = YES
         return
         }
   equal = NO
   return
   end
# getwrd - get non-blank word from in(i) into  out, increment i
   integer function getwrd(in, i, out)
   character in(ARB), out(ARB)
   integer i, j
   while (in(i) == ' ' | in(i) == TAB)
      i = i + 1
   j = 1
   while (in(i)!=EOS & in(i)!=' ' & in(i)!=TAB & in(i)!=NEWLINE) {
      out(j) = in(i)
      i = i + 1
      j = j + 1
      }
   out(j) = EOS
   getwrd = j - 1
   return
   end
# index - find character  c  in string  str
   integer function index(str, c)
   character c, str(ARB)
   for (index = 1; str(index) != EOS; index = index + 1)
      if (str(index) == c)
         return
   index = 0
   return
   end
# itoc - convert integer  int  to char string in  str
define(abs,iabs)
   integer function itoc(int, str, size)
   integer abs, mod
   integer d, i, int, intval, j, k, size
   character str(ARB)
#   string digits "0123456789"
   character digits(11)
   data digits(1) /'0'/
   data digits(2) /'1'/
   data digits(3) /'2'/
   data digits(4) /'3'/
   data digits(5) /'4'/
   data digits(6) /'5'/
   data digits(7) /'6'/
   data digits(8) /'7'/
   data digits(9) /'8'/
   data digits(10) /'9'/
   data digits(11) /EOS/
   intval = int
   str(1) = EOS
   i = 1
   repeat {            # generate digits
      i = i + 1
      d = mod(intval, 10)
      str(i) = digits(abs(d)+1)
      intval = (intval-d)/10
      } until (intval == 0 | i >= size)
   if (int < 0 & i < size) {      # then sign
      i = i + 1
      str(i) = '-'
      }
   itoc = i - 1
   for (j = 1; j < i; j = j + 1) {   # then reverse
      k = str(i)
      str(i) = str(j)
      str(j) = k
      i = i - 1
      }
   return
   end
# itocrj - convert integer to character in a right-adjusted field
define(MAXCHARS,10)
   integer function itocrj(int, str, size)
   integer int, size, j
   integer itoc
   character str(ARB), tbuf(MAXCHARS)
   j = itoc(int, tbuf, MAXCHARS)
   for (i = size-1; j > 0 & i > 0; i = i-1) {
      str(i) = tbuf(j)
      j = j-1
      }
   for (; i > 0; i = i-1) str(i) = ' '
   str(size) = EOS
   itocrj = size-1
   return
   end
# length - compute length of string
   integer function length(str)
   character str(ARB)  #<wpw>      integer->character
   for (length = 0; str(length+1) != EOS; length = length + 1)
      ;
   return
   end
# putnum - put integer
define(MAXCHARS,10)
   subroutine putnum(int, f)
   integer int, f, i, n
   character chars(MAXCHARS)
   integer itoc
   n = itoc(int, chars, MAXCHARS)
   for (i = 1; i <= n; i = i+1)
      call putch(chars(i), f)
   return
   end
# putdec - put decimal integer  n  in field width >= w
define(MAXCHARS,10)
   subroutine putdec(n, w)
   character chars(MAXCHARS)
   integer itoc
   integer i, n, nd, w
   nd = itoc(n, chars, MAXCHARS)
   for (i = nd + 1; i <= w; i = i + 1)
      call putc(' ')
   for (i = 1; i <= nd; i = i + 1)
      call putc(chars(i))
   return
   end
# scopy - copy string at from(i) to to(j)
   subroutine scopy(from, i, to, j)
   character from(ARB), to(ARB)
   integer i, j, k1, k2
   k2 = j
   for (k1 = i; from(k1) != EOS; k1 = k1 + 1) {
      to(k2) = from(k1)
      k2 = k2 + 1
      }
   to(k2) = EOS
   return
   end
# type - determine type of character
   character function type(c)
   character c
   character ctype(-128:127)
 # A-Z and a-z are alphabetic;
 # 0-9 are digits;
   data ctype/128*0,48*0,10*DIGIT,7*0,26*LETTER,
              6*0,26*LETTER,5*0/
   type = ctype(c)
   if (type == 0) type = c
#$   if( c >= '0' & c <= '9' )
#$      type = DIGIT
#$   else if( c >= 'a' & c <= 'z' )
#$      type = LETTER
#$   else if( c >= 'A' & c <= 'Z' )
#$      type = LETTER
#$   else
#$      type = c
   return
   end
# fold - fold all letters to lower case
 subroutine fold (token)
 character token(ARB)
 integer i
 
 for (i=1; token(i) != EOS; i=i+1)
    if (token(i) >= 'A' & token(i) <= 'Z')
       token(i) = token(i) - 'A' + 'a'
 return
 end
# clower - change letter to lower case
   character function clower (c)
   character c
   if (c >= 'A' & C <= 'Z')
      clower = c - 'A' + 'a'
   else
      clower = c
   return
   end
# cupper - change letter to upper case
   character function cupper (c)
   character c
   if (c >= 'a' & C <= 'z')
      cupper = c - 'a' + 'A'
   else
      cupper = c
   return
   end
# lower - fold all alphas to lower case
   subroutine lower (token)
   character token(ARB)
   integer i
   for (i=1; token(i) != EOS; i=i+1)
      if (token(i) >= 'A' & token(i) <= 'Z')
         token(i) = token(i) - 'A' + 'a'
   return
   end
# upper - fold all alphas to upper case
   subroutine upper (token)
   character token(ARB)
   integer i
   for (i=1; token(i) != EOS; i=i+1)
      if (token(i) >= 'a' & token(i) <= 'z')
         token(i) = token(i) - 'a' + 'A'
   return
   end
# uniqm - find command string which matches input string uniquely
   subroutine uniqm(in,cmdstr,code,result)
   character in(ARB), cmdstr(ARB)
   integer code, result, i
   if (in(1) == EOS & cmdstr(1) != EOS) return #null string must match exactly
   for (i = 1; in(i) != EOS; i = i+1)
      if (in(i) != cmdstr(i)) return
   if (result != 0) result = ERR
   else if (code >= 0) result = code
   else if (cmdstr(i) == EOS) result = -code # if code neg., must match exactly
   return
   end
# pmatch - return YES if str1 is a partial match to str2
   integer function pmatch(str1, str2)
   character str1(ARB), str2(ARB)
   integer c
   c = 0
   call uniqm(str1, str2, 1, c)
   if (c == 0) pmatch = NO
   else pmatch = YES
   return
   end
# search - find a pattern in a line
   integer function search(text, pattrn)
   character text(ARB), pattrn(ARB)
   integer n, m, j, length, i
   search = 0
   m = length(pattrn)
   if (m == 0) return
   n = length(text)
   j = m
   while (j <= n) {
      do i = m,1,-1
         if (text(j-m+i) != pattrn(i)) {
            j = j+1
            next 2
            }
      search = j-m+1
      return
      }
   return
   end
#-h- conc           191 asc  3-oct-80 11:28:26
 subroutine conc(first, second, out)

 character first(ARB), second(ARB), out(ARB)
 integer i

 i = 1
 call stcopy(first, 1, out, i)
 call scopy(second, 1, out, i)

 return
 end
#-h- stcopy           201 asc  3-oct-80 11:28:26
 subroutine stcopy(in, i, out, j)

 character in(ARB), out(ARB)
 integer i, j, k

 for (k=i; in(k) != EOS; k=k+1)
    {
    out(j) = in(k)
    j = j + 1
    }
 out(j) = EOS

 return
 end
#-h- skipbl           186 asc  3-oct-80 11:28:23
 ## skipbl - skip blanks and tabs at lin(i)
   subroutine skipbl(lin, i)
   character lin(ARB)
   integer i
 
   while (lin(i) == BLANK | lin(i) == TAB)
      i = i + 1
   return
   end
# bkscan - return index of first break char in str
  integer function bkscan(str, brk, i)
  character str(ARB), brk(ARB)
  integer index, i
  for (bkscan = i; str(bkscan) != EOS; bkscan = bkscan+1)
    if (index(brk, str(bkscan)) != 0) break
  return
  end
# scan - return index of first char in str which isn't in scstr
  integer function scan(str, scstr, i)
  character str(ARB), scstr(ARB)
  integer index, i
  for (scan = i; str(scan) != EOS; scan = scan+1)
    if (index(scstr, str(scan)) == 0) break
  return
  end
## esc - map  array(i)  into escaped character if appropriate 
   character function esc(array, i) 
   character array(ARB) 
   integer i 
 
   if (array(i) != ESCAPE) 
      esc = array(i) 
   else if (array(i+1) == EOS)   # |*a not special at end 
      esc = ESCAPE 
   else { 
      i = i + 1 
      if (array(i) == LETN | array(i) == BIGN)
         esc = NEWLINE 
      else if (array(i) == LETT | array(i) == BIGT)
         esc = TAB 
      else if (array(i) == LETB | array(i) == BIGB)
         esc = BLANK
      else 
         esc = array(i) 
      } 
   return 
   end