# FILE 4 OF SOFTWARE TOOLS FROM LBL
 #####################################################################
 #
 #        Section 1 - General symbol definitions
 #####################################################################
  # General definitions for the software tools
  # Should be put on a file named 'symbols'
  # Used by all the tools; read automatically by the preprocessor

  define(ALPHA,-9)
  define(ASCII,12)           # flag for ascii-type file
  define(AMPER,38)           # ampersand

  define(AND,38)             # same as ampersand
  define(APPEND,4)
  define(ARB,100)
  define(ATSIGN,64)
  define(BACKSLASH,92)
  define(BACKSPACE,8)
  define(BANG,33)            # exclamation mark
  define(BAR,124)
  define(BIGA,65)
  define(BIGB,66)
  define(BIGC,67)
  define(BIGD,68)
  define(BIGE,69)
  define(BIGF,70)
  define(BIGG,71)
  define(BIGH,72)
  define(BIGI,73)
  define(BIGJ,74)
  define(BIGK,75)
  define(BIGL,76)
  define(BIGM,77)
  define(BIGN,78)
  define(BIGO,79)
  define(BIGP,80)
  define(BIGQ,81)
  define(BIGR,82)
  define(BIGS,83)
  define(BIGT,84)
  define(BIGU,85)
  define(BIGV,86)
  define(BIGW,87)
  define(BIGX,88)
  define(BIGY,89)
  define(BIGZ,90)
  define(BINARY,60)          #flag for binary file
  define(BLANK,32)
  define(CARET,94)
  define(COLON,58)
  define(COMMA,44)
  define(DASH,45)           #same as MINUS
  define(DIG0,48)
  define(DIG1,49)
  define(DIG2,50)
  define(DIG3,51)
  define(DIG4,52)
  define(DIG5,53)
  define(DIG6,54)
  define(DIG7,55)
  define(DIG8,56)
  define(DIG9,57)
  define(DIGIT,2)
  define(DOLLAR,36)
  define(DQUOTE,34)
  define(EOF,-1)
  define(EOR,-973)
  define(EOS,0)

  define(EQUALS,61)
  define(ERR,-3)
  define(ERROUT,3)           #standard error file
  define(ESCAPE,ATSIGN)      #escape character for ch, find, tr, ed, and sh
  define(FILENAMESIZE,81)    #max characters in file name (includes EOS)
  define(GREATER,62)
  define(LBRACE,123)
  define(LBRACK,91)
  define(LESS,60)
  define(LETA,97)
  define(LETB,98)
  define(LETC,99)
  define(LETD,100)
  define(LETE,101)
  define(LETF,102)
  define(LETG,103)
  define(LETH,104)
  define(LETI,105)
  define(LETJ,106)
  define(LETK,107)
  define(LETL,108)
  define(LETM,109)
  define(LETN,110)
  define(LETO,111)
  define(LETP,112)
  define(LETQ,113)
  define(LETR,114)
  define(LETS,115)
  define(LETT,116)
  define(LETTER,1)
  define(LETU,117)
  define(LETV,118)
  define(LETW,119)
  define(LETX,120)
  define(LETY,121)
  define(LETZ,122)
  define(LPAREN,40)
  define(LOCAL,6)            # flag for local-type character files
  define(MAXCARD,80)         # card size
                             # different for different systems
  define(MAXLINE,81)         # must be 1 more than MAXCARD
                             # different for different systems
  define(MINUS,45)
  define(NCHARS,33)          # number of special characters
  define(NEWLINE,10)
  define(NO,0)
  define(NOT,BANG)           # exclamation mark for now; change for ebcdic
  define(OK,0)               # success flag
  define(OR,BAR)
  define(PERCENT,37)
  define(PERIOD,46)
  define(PLUS,43)
  define(QMARK,63)
  define(RBRACE,125)
  define(RBRACK,93)
  define(READ,1)             # flag to open file at read access

  define(READWRITE,3)        #flag to open file at read/write access
  define(RPAREN,41)
  define(SEMICOL,59)
  define(SHARP,35)
  define(SLASH,47)
  define(STDIN,1)            #standard input file
  define(STDOUT,2)           #standard output file
  define(SQUOTE,39)
  define(STAR,42)
  define(TAB,9)
  define(TILDE,126)
  define(UNDERLINE,95)
  define(WRITE,2)            # flag to open file at write access
  define(YES,1)



  define(character,integer)  # define character data type
  define(andif,if)
  define(abs,iabs)
  define(max,max0)
  define(min,min0)

# definitions for process creation and control
 define(BACKGR,LETB)            # spawning a background process
 define(WAIT,LETW)              # wait for subprocess to complete
 define(NOWAIT,LETN)            # control returns as soon as subprocess starts
 define(ARGBUFSIZE,512)         # size of buffer for arguments to spawn
 define(PIDSIZE,9)              # size for descr field in spawn call
 define(TERMSGSIZE,21)          # size of integer array for pwait return
 define(ORWAIT,50)              # values for andflag in pwait call
 define(ANDWAIT,51)             #    "    "     "     "   "     "

 # Special definitions for DEC VMS and IAS operating systems
 # define(MAXCARD,399)
 # define(MAXLINE,400)
 # define(character,logical*1)
 # define(index,indexx) #avoid conflict with system library utility
 # define(INDEX,INDEXX)   # ditto

 # Special definitins for CDC 6400/6600 (BKY operating system)
 #  define(EOS,-2)
 #  define(FILENAMESIZE,8)
 #  define(CDC,LOCAL)
 #  define(MAXCARD,144)
 #  define(MAXLINE,145)
 #####################################################################
 #
 #       Section 2 - General purpose library routines
 #
 #####################################################################
#-h- DEFNS 200 13-JAN-79 20:52:05
 #---------------------------------------------------------------------
 # include symbol definitions
 #        include symbols
 #---------------------------------------------------------------------

#-h- ACOPY 236 15-JAN-79 01:41:34
 ## acopy - copy size characters from fdi to fdo
 subroutine acopy (fdi, fdo, size)
 character getch
 character c
 integer fdi, fdo, i, size

 for (i=1; i<=size; i=i+1)
        {
        if (getch(c,fdi) ^= EOF)
        call putch (c, fdo)
        }
 return
 end
#-h- ADDSET 242 30-OCT-78 15:28:46
 ## addset - put c in string(j) if it fits, increment j
 integer function addset (c, str, j, maxsiz)

 integer j, maxsiz
 character c, str(maxsiz)

 if (j > maxsiz)
        addset = NO
 else
        {
        str(j) = c
        j = j + 1
        addset = YES
        }
 return
 end
#-h- ALLDIG 255 30-OCT-78 15:28:47
 ## alldig - return YES if str is all digits
 integer function alldig (str)

 integer type, i
 character str(ARB)

 alldig = NO
 if (str(1) == EOS)
        return
 for (i=1; str(i) ^= EOS; i=i+1)
        if (type(str(i)) ^= DIGIT)
                return
 alldig = YES
 return
 end
#-h- AMOVE 390 15-JAN-79 01:42:04
 ## amove - move name1 to name2
 subroutine amove (name1, name2)
 character name1(ARB), name2(ARB), buf(MAXLINE)
 integer create, open, getlin
 integer fd1, fd2

 fd1 = open(name1,READ)
 if (fd1 == ERR)

        call cant (name1)
 fd2 = create(name2, WRITE)
 if (fd2 == ERR)
        call cant (name2)
 while (getlin(buf,fd1) ^= EOF)
        call putlin(buf,fd2)
 call close (fd1)
 call close (fd2)
 return
 end
#-h- BUBBLE 262 asc 15-JAN-79 22:56:24
 ## bubble - bubble sort v(1)...v(n) increasing
 subroutine bubble(v, n)
 integer i, j, k, n, v(ARB)

 for (i=n; i>1; i=i-1)
        for (j = 1; j<i; j=j+1)
        if (v(j) > v(j+1))              #compare
                        {
                        k = v(j)        #exchange
                        v(j) = v(j+1)   #
                        v(j+1) = k      #
                        }
 return
 end
#-h- CANT 456 31-OCT-78 15:15:32
 ## cant - print "file:  can't open" and terminate execution
 subroutine cant (file)

 character file (ARB)
 character buf(15)
 data buf(1), buf(2), buf(3), buf(4), buf(5), buf(6), buf(7),
      buf(8), buf(9), buf(10), buf(11), buf(12), buf(13), buf(14),
      buf(15) /COLON, BLANK, BLANK,
      LETC, LETA, LETN, SQUOTE, LETT, BLANK,
      LETO, LETP, LETE, LETN, NEWLINE, EOS/

 call putlin (file, ERROUT)
 call putlin (buf, ERROUT)
 call endr4
 end
#-h- CLOWER 238 13-JAN-79 15:35:30
 ## clower - change letter to lower case
        character function clower(c)

        character c, k

        if (c >= BIGA & c <= BIGZ)
                {               #avoid integer overflow in byte machines
                k = LETA - BIGA
                clower = c + k
                }
        else
            clower = c

        return

        end
#-h- CTOI 744 30-OCT-78 15:28:52
 ## ctoi - convert string at in(i) to integer, increment i
    integer function ctoi(in, i)
    character in(ARB)
    integer index
    integer d, i
 #   string digits "0123456789"
    character digits(11)
    data digits(1) /DIG0/
    data digits(2) /DIG1/
    data digits(3) /DIG2/
    data digits(4) /DIG3/
    data digits(5) /DIG4/
    data digits(6) /DIG5/
    data digits(7) /DIG6/
    data digits(8) /DIG7/
    data digits(9) /DIG8/
    data digits(10) /DIG9/
    data digits(11) /EOS/

    while (in(i) == BLANK | in(i) == TAB)
       i = i + 1
    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
       }
    return
    end
#-h- CUPPER 241 13-JAN-79 15:31:43
 ## cupper - change letter to upper case
        character function cupper(c)

        character c, k

        if (c >= LETA & c <= LETZ)
                {               #avoid overflow with byte-oriented machines
                k = BIGA - LETA
                cupper = c + k
                }
        else
            cupper = c

        return
        end
#-h- EQUAL 263 30-OCT-78 15:29:53
 ## 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
#-h- ERROR 137 30-OCT-78 15:29:55
 ## error - print message and terminate execution
 subroutine error (line)

 character line(ARB)

 call remark (line)
 call endr4
 end
#-h- FCOPY 175 30-OCT-78 15:29:56
 ## fcopy - copy file in to file out
 subroutine fcopy (in, out)
 character c
 character getch
 integer in, out

 while (getch(c,in) ^= EOF)
        call putch(c, out)
 return
 end
#-h- FOLD 187 30-OCT-78 15:29:57
 ## fold - fold all letters to lower case
 subroutine fold (token)
 character token(ARB), clower
 integer i

 for (i=1; token(i) ^= EOS; i=i+1)
        token(i) = clower(token(i))
 return
 end
#-h- FSIZE 300 14-JAN-79 02:28:08
 ## fsize - determine size of file in characters
 integer function fsize (name)

 character getch
 character c, name(ARB)
 integer open
 integer fd

 fd = open (name, READ)
 if (fd == ERR)
        fsize = ERR
 else
        {
        for (fsize=0; getch(c,fd) ^= EOF; fsize=fsize+1)
                ;
        call close (fd)
        }
 return
 end

#-h- FSKIP 189 15-JAN-79 01:41:52
 ## fskip - skip n characters on file fd
 subroutine fskip (fd, n)

 character getch
 character c
 integer fd, i, n

 for (i=1; i<=n; i=i+1)
        if (getch(c,fd) == EOF)
                break
 return
 end
#-h- GETC 133 30-OCT-78 15:29:58
 ## getc - get character from STDIN
 character function getc(c)

 character c
 character getch

 getc = getch(c, STDIN)
 return
 end
#-h- GETWRD 373 30-OCT-78 15:30:01
 ## 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
#-h- INDEX 245 30-OCT-78 15:31:04
 ## 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
#-h- ITOC 1027 30-OCT-78 15:31:05
 ## itoc - convert integer  int  to char string in  str

    integer function itoc(int, str, size)
    integer mod
    integer d, i, int, intval, j, k, size
    character str(size)
 #   string digits "0123456789"
    character digits(11)
    data digits(1) /DIG0/
    data digits(2) /DIG1/
    data digits(3) /DIG2/
    data digits(4) /DIG3/
    data digits(5) /DIG4/
    data digits(6) /DIG5/
    data digits(7) /DIG6/
    data digits(8) /DIG7/
    data digits(9) /DIG8/
    data digits(10) /DIG9/
    data digits(11) /EOS/

    intval = abs(int)
    str(1) = EOS
    i = 1
    repeat {            # generate digits
       i = i + 1
       d = mod(intval, 10)
       str(i) = digits(d+1)
       intval = intval / 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
#-h- LENGTH 168 30-OCT-78 15:31:07
 ## length - compute length of string
 integer function length (str)

 character str(ARB)

 for (length=0; str(length+1) ^= EOS; length = length + 1)
        ;
 return
 end
#-h- PUTC 110 30-OCT-78 15:31:08
 ## putc - put character onto STDOUT
 subroutine putc (c)

 character c


 call putch (c, STDOUT)
 return
 end
#-h- PUTDEC 283 30-OCT-78 15:31:09
 ## putdec - put decimal integer n in field width >= w
        subroutine putdec(n,w)
        character chars(MAXLINE)
        integer itoc
        integer i,n,nd,w

        nd = itoc(n,chars,MAXLINE)
        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
#-h- SCOPY 290 30-OCT-78 15:32:02
 ## 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
#-h- SHELL 339 asc 15-JAN-79 22:56:31
 ## shell - Shell sort v(1)...v(n) increasing
 subroutine shell (v, n)
 integer gap, i, j, jg, k, n, v(ARB)

 for (gap=n/2; gap>0; gap=gap/2)
        for (i=gap+1; i<=n; i=i+1)
                for (j=i-gap; j>0; j=j-gap)
                        {
                        jg = j + gap
                        if (v(j) <= v(jg))      #compare
                                break
                        k = v(j)                #exchange
                        v(j) = v(jg)            #
                        v(jg) = k               #
                        }
 return
 end
#-h- SKIPBL 186 30-OCT-78 15:32:03
 ## 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
#-h- TYPE 1810 30-OCT-78 15:32:05
 ## type - determine type of character
 integer function type (c)

 character c
 integer index
 character digits(11), lowalf(27), upalf(27)
 data digits(1) /DIG0/
 data digits(2) /DIG1/
 data digits(3) /DIG2/
 data digits(4) /DIG3/
 data digits(5) /DIG4/
 data digits(6) /DIG5/
 data digits(7) /DIG6/
 data digits(8) /DIG7/
 data digits(9) /DIG8/
 data digits(10) /DIG9/
 data digits(11) /EOS/

 data lowalf(1) /LETA/
 data lowalf(2) /LETB/
 data lowalf(3) /LETC/
 data lowalf(4) /LETD/
 data lowalf(5) /LETE/
 data lowalf(6) /LETF/
 data lowalf(7) /LETG/
 data lowalf(8) /LETH/
 data lowalf(9) /LETI/
 data lowalf(10) /LETJ/
 data lowalf(11) /LETK/
 data lowalf(12) /LETL/
 data lowalf(13) /LETM/
 data lowalf(14) /LETN/
 data lowalf(15) /LETO/
 data lowalf(16) /LETP/
 data lowalf(17) /LETQ/
 data lowalf(18) /LETR/
 data lowalf(19) /LETS/
 data lowalf(20) /LETT/
 data lowalf(21) /LETU/
 data lowalf(22) /LETV/
 data lowalf(23) /LETW/
 data lowalf(24) /LETX/
 data lowalf(25) /LETY/
 data lowalf(26) /LETZ/
 data lowalf(27) /EOS/

 data upalf(1) /BIGA/
 data upalf(2) /BIGB/
 data upalf(3) /BIGC/
 data upalf(4) /BIGD/
 data upalf(5) /BIGE/
 data upalf(6) /BIGF/

 data upalf(7) /BIGG/
 data upalf(8) /BIGH/
 data upalf(9) /BIGI/
 data upalf(10) /BIGJ/
 data upalf(11) /BIGK/
 data upalf(12) /BIGL/
 data upalf(13) /BIGM/
 data upalf(14) /BIGN/
 data upalf(15) /BIGO/
 data upalf(16) /BIGP/
 data upalf(17) /BIGQ/
 data upalf(18) /BIGR/
 data upalf(19) /BIGS/
 data upalf(20) /BIGT/
 data upalf(21) /BIGU/
 data upalf(22) /BIGV/
 data upalf(23) /BIGW/
 data upalf(24) /BIGX/
 data upalf(25) /BIGY/
 data upalf(26) /BIGZ/
 data upalf(27) /EOS/

 if (index(lowalf, c) > 0)
        type = LETTER
 else if (index(upalf,c) >0)
        type = LETTER
 else if (index(digits,c) > 0)
        type = DIGIT
 else
        type = c
 return
 end
#-h- UPPER 190 30-OCT-78 15:32:07
 ## upper - fold all alphas to upper case
 subroutine upper (token)

 character token(ARB), cupper
 integer i

 for (i=1; token(i) ^= EOS; i=i+1)
        token(i) = cupper(token(i))
 return
 end
#-h- STCOPY.Q 173 asc 23-MAY-79 22:43:43
 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
    }

 return

 end
 #######################################################################
 #
 #      Section 3 - Fortran I/O Routines (temporary)
 #
 #######################################################################
 ## getch - get characters from file f
 character function getch (c, f)
 character inmap, buf(MAXLINE), c
 integer f, i, lastc
 data lastc /MAXLINE/
 data buf(MAXLINE) /NEWLINE/
 # note:  MAXLINE = MAXCARD + 1

 if (buf(lastc) == NEWLINE | lastc >= MAXLINE)
        {
        read(f, 1, end=10) (buf(i), i=1,MAXCARD)
        1 format (MAXCARD a1)
        for (i=1; i<= MAXCARD; i=i+1)
                buf(i) = inmap(buf(i))
        for (i=MAXCARD; i>0; i=i-1)
                if (buf(i) ^= BLANK)
                        break
        buf(i+1) = NEWLINE
        lastc = 0
        }
 lastc = lastc + 1
 c = buf(lastc)
 getch = c
 return

 10 c = EOF
 getch = EOF
 return
 end
 ## getlin - get next line from  f  into  line
   integer function getlin(line, f)
   character line(MAXLINE), c, getch
   integer f

   for (getlin = 0; getch(c, f) ^= EOF; )
      {
      if (c == 0)
         break
      if (getlin < MAXLINE - 1)
         {
         getlin = getlin + 1
         line(getlin) = c
         }
      if (c == NEWLINE)
         break
      }
   line(getlin+1) = EOS
   if (getlin == 0 & c == EOF)
      getlin = EOF
   return

   end
 ## putch - put characters onto file f
 subroutine putch (c, f)
 character buf(MAXLINE), c
 character outmap
 integer f, i, lastc
 data lastc /0/

 if (lastc >= MAXLINE | c == NEWLINE)
        {
        if (lastc <= 0)
                {
                write (f,2)
                2 format (/)
                }
        else
                {
                write(f,1) (buf(i), i=1,lastc)
                1 format (MAXCARD a1)
                }
        lastc = 0
        }
 if (c ^= NEWLINE)
        {
        lastc = lastc + 1
        buf(lastc) = outmap(c)
        }
 return
 end
 ## putlin - write string  line  to file  f
   subroutine putlin(line, f)
   character line(MAXLINE)
   integer f, i

   for (i = 1; line(i) ^= EOS; i = i + 1)
      call putch(line(i), f)
   return
   end
 ## initr4 - initialization for software tools
 subroutine initr4

 # open STDIN, STDOUT, ERROUT, performing any file substitution
 # indicated by user

 # perform any other system initialization necessary

 return
 end
 ## endr4 - close all open files and terminate processing
 subroutine endr4

 #close all open files

 rewind STDIN
 rewind STDOUT
 rewind ERROUT

 return
 end
 ## gdate - get current date
 subroutine gdate (str)
 character str(ARB)
 character date(9)

 data date(1), date(2), date(3), date(4), date(5), date(6),
      date(7), date(8), date(9) /LETM, LETM, SLASH,
      LETD, LETD, SLASH, LETY, LETY, EOS /

 call scopy (date, 1, str, 1)
 return
 end
 ## gtime - get current time
 subroutine gtime (str)
 character str(ARB)
 character time(9)
 data time(1), time(2), time(3), time(4), time(5), time(6),
      time(7), time(8), time(9) /LETH, LETH, PERIOD,
      LETM, LETM, PERIOD, LETS, LETS, EOS/

 call scopy (time, 1, str, 1)
 return
 end