#
#
#
#    RATLIB utility routines - miscellaneous support for all programs
#    ================================================================
#
#
#         Author:  William P. Wood, Jr.
#                  Computer Center
#                  Institute For Cancer Research
#                  7701 Burholme Ave.
#                  Philadelphia, Pa. 19111
#                  (215) 728 2760
#
#         Version: 2.0
#
#         Date:   December 18, 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                       *
#      *                                                     *
#      *******************************************************
#

# 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) < DIG0 | str(i) > DIG9)
         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
   string digits "0123456789"

   while (in(i) == BLANK | 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) == BLANK | in(i) == TAB)
      i = i + 1
   j = 1
   while (in(i)!=EOS & in(i)!=BLANK & 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"

   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) = MINUS
      }
   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
   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) = BLANK
   str(size) = EOS
   itocrj = size-1
   return
   end
# length - compute length of string
   integer function length(str)
   character str(ARB)
   for (length = 0; str(length+1) != EOS; length = length + 1)
      ;
   return
   end
# putnum - put integer
   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
   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(BLANK)
   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(256)
 # 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+129)
   if (type == 0) type = c
#$   if( c >= DIG0 & c <= DIG9)
#$      type = DIGIT
#$   else if( c >= LETA & c <= LETZ)
#$      type = LETTER
#$   else if( c >= BIGA & c <= BIGZ)
#$      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) >= BIGA & token(i) <= BIGZ)
       token(i) = token(i) - BIGA + LETA
 return
 end
# clower - change letter to lower case
   character function clower (c)
   character c
   if (c >= BIGA & C <= BIGZ)
      clower = c - BIGA + LETA
   else
      clower = c
   return
   end
# cupper - change letter to upper case
   character function cupper (c)
   character c
   if (c >= LETA & C <= LETZ)
      cupper = c - LETA + BIGA
   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) >= BIGA & token(i) <= BIGZ)
         token(i) = token(i) - BIGA + LETA
   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) >= LETA & token(i) <= LETZ)
         token(i) = token(i) - LETA + BIGA
   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), cupper
   integer i 
 
   if (array(i) != ESCAPE) 
      esc = array(i) 
   else if (array(i+1) == EOS)   # ESCAPE not special at end 
      esc = ESCAPE 
   else { 
      i = i + 1 
      switch (cupper(array(i))) {
	 case BIGB:	esc = BACKSPACE
	 case BIGE:	esc = EOS
	 case BIGF:	esc = FF
	 case BIGG:	esc = BELL
	 case BIGL:	esc = LF
	 case BIGN:	esc = NEWLINE
	 case BIGR:	esc = CR
	 case BIGT:	esc = TAB
	 case BIGV:	esc = VT
	 case DOLLAR:	esc = ESC
	 case DIG0-DIG7:
	   esc = 0
	   for (j=i; j < i+3 & (array(j) >= DIG0 & array(j) <= DIG7); j=j+1)
	     esc = 8*esc + (array(j) - DIG0)
	   i = j - 1
	 default:	esc = array(i)
	 }
      } 
   return 
   end 
# eq - compare str1 to str2; return .true. if equal, .false. if not
   logical function eq(str1, str2)
   character str1(ARB), str2(ARB)
   integer i
   for (i = 1; str1(i) == str2(i); i = i + 1)
      if (str1(i) == EOS)
         return(.true.)
   return(.false.)
   end