#-h-  tools                    164345  local   01/05/81  23:05:25
#-h-  banner                    54887  local   01/05/81  16:47:56
#-h-  banner.doc         1498  local  09/24/80  13:08:23
.he 'BANNER'05/01/80'BANNER'
NAME
.sp
banner - convert text to banner size
.sp 2
SYNOPSIS
.sp
banner { - | -c <char> } <string>
.sp 2
DESCRIPTION
.sp
'Banner' converts the text in the <string> argument into
large characters for printing on a suitable hard copy
printer. The printer should be able to handle 132 characters
per line.
.sp
Output is produced on standard output 1 and may thus be piped
to some other program or redirected to a file.
.sp
The dash argument, if present, causes the banner to be white-on-black;
if absent, the banner is black-on-white.
.sp
The character used for printing the banner is the rubout, which appears
on the line printer as a small rectangle composed of three vertical lines.
This may be changed to any arbitrary ASCII character by using the
"-c <char>" argument sequence.
.sp
The type font produced is Fortune Light, by the Bauer Type Foundry.
.sp
'Banner' is capable of producing all of the printable ASCII characters
except for the following:
.sp
          ~ ^ \ ` { } [ ] _
.sp
Of these characters, three may be used to specify other special
symbols:  the caret ("^") is interpreted as the 'degrees' symbol
(superscript zero), the grave accent ("`") is interpreted as the
'cent' symbol, and the underscore ("_") is interpreted as the
superscript 'th' symbol.
.sp 2
EXAMPLES
.sp
.nf
banner "Happy Birthday!" >saved_banner
banner - "Hi Mom"
banner "School of I. C. S." >/dev/lps
.fi
.sp 2
MESSAGES
.sp
Usage... for improper arguments.
.sp 2
SEE ALSO
.sp
block
#-t-
#-h-  banner.r        13240  local  09/24/80  13:08:25
# banner --- produce banner from arguments on Standard Output

# Original Fortran version:
#  by Joseph J. Greiner, Jr.
#  Department of Civil Engineering
#  Virginia Polytechnic Institute
#  Blacksburg, Virginia
#  July, 1975
# With modifications by:
#  Daniel S. Cox
#  Department of Electrical Engineering
#  Georgia Institute of Technology
#  February, 1978


#  Typeface: Fortune Light by Bauer Type Foundry;
#  nominal size, 8 inches high

#  Most 029 (EBCDIC) keypunch symbols, plus lower-case multi-
#  punching, can be interpreted by this program.



   define(div,/)
   define(MAXKARD,78)
   define(MAXSYM,89)
   define(DEFAULT_CHAR,RUBOUT)
   define(TEN2,100)
   define(TEN3,1000)
   define(TEN4,10000)
   define(TEN5,100000)
   define(TEN6,1000000)
   define(TEN7,10000000)
   define(DB,#)

   include "banner_com.r.i"

   integer col, i, maxl, minl, ncols, ntotal, nspare,
      banner_text (MAXKARD), lmax (MAXSYM), lmin (MAXSYM)
   integer index

   data lmax / _
      80,   57,   80,   73,   80,   57,   80,   57,   80,   74,
      80,   57,   80,   57,   80,   80,   80,   57,   80,   80,
      80,   80,   80,   55,   80,   80,   80,   57,   80,   80,
      80,   57,   80,   74,   80,   80,   80,   57,   80,   57,
      80,   57,   80,   55,   80,   55,   80,   55,   80,   55,
      80,   55,   80,   80,   80,   80,   80,   80,   80,   80,
      80,   80,   70,   48,   80,   55,   80,   80,   80,   64,
      80,   80,   80,   80,   80,   80,   80,   88,   80,   80,
      15,   15,   47,   47,   80,   80,   76,   80,   1/

   data lmin / _
       1,    1,    1,    1,    1,    1,    1,    1,    1,    1,
      -1,    1,    1,    1,    1,    1,    1,    1,    1,    1,
       1,    1,    1,   -1,    1,    1,    1,    1,    1,    1,
       1,  -24,    1,  -24,    1,    1,    1,    1,    1,  -24,
     -11,  -24,    1,    1,    1,    1,    1,    1,    1,  -24,
       1,    1,    1,    1,    1,    1,    1,    1,    1,    1,
       1,    1,   11,   33,    1,   26,    1,    1,   61,   19,
       1,    1,    1,    1,    1,    1,    1,   -7,    1,    1,
      -9,    1,    1,   11,   41,   41,    4,    1,    1/

   call do_args (foreground_sym, background_sym, banner_text)
   maxl = -100    # must be less than anything in lmax array
   minl = 100     # must be greater than anything in lmin array
   ntotal = 0
   for (col = 1; banner_text (col) ~= EOS; col += 1) {
      i = index (syma, banner_text (col))
      if (i == 0)
         i = MAXSYM     # index of ' 'c
      if (lmax (i) > maxl)
         maxl = lmax (i)
      if (lmin (i) < minl)
         minl = lmin (i)
      ntotal += symn (i) / TEN4 + 4
      banner_text (col) = i   # replace character by its index
      }
   ncols = maxl - minl + 1
   move = (132 - ncols) / 2 - minl
   nspare = (int (float (ntotal) / 66. + 1.5) * 66 - ntotal - 6) / 2
   call baxx (nspare, 2)
   for (i = 1; i < col; i += 1)
      call prnt (banner_text (i))

   call baxx (nspare + 50, 2)

   stop
   end


# prnt --- manage the printing of a single character
   subroutine prnt (i)
   integer i

   include "banner_com.r.i"

   integer j, k, jout, na, nb, nc, nd, ne, nf, ng, nh, nchk, nsi, ntemp
   integer nshift (MAXSYM)

   longint nch

   data nshift / _
       0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
       2,    0,    0,    0,    0,    0,    0,    0,    0,    0,
       0,    0,    0,    2,    0,    0,    0,    0,    0,    0,
       0,   25,    0,   25,    0,    0,    0,    0,    0,   25,
      12,   25,    0,    0,    0,    0,    0,    0,    0,   25,
       0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
       0,    0,    0,    0,    9,    0,    0,    0,    0,    0,
       0,    0,    0,    0,    0,    0,    0,    8,    0,    0,
      10,    0,    0,    0,    0,    0,    0,    0,    0/

   call baxx (2, 2)
   if (i == MAXSYM) {   # print a blank
      call baxx (50, 2)
      return
      }
   select (i)
      when (16, 22, 36)
         call legl (25, 0)
      when (40)
         call legl (25, 25)
      when (12, 18, 38)
         call legl (0, 0)
      when (8, 20, 28, 42)
         call ohav (1)
      when (1, 9, 15, 17, 19, 21, 25, 29, 35, 39)
         call legu (7)
      when (11, 37)
         call legu (4)
      when (7, 27, 31, 41)
         call ohaf (1)

   if (i ~= 8 && i ~= 12 && i ~= 16) {
      j = mod (symn (i), TEN4) - 1
      jout = mod (symn (i + 1), TEN4)
      nsi = nshift (i)

      repeat {
         ne = 0
         ng = 0
         call baxx (1, 1)
         j += 1
         if (j >= jout)
            break

         nch = nchar (j)   # split character description into its fields
         na = nch div TEN7
         nb = mod (nch div TEN5, TEN2)
         nc = mod (nch div TEN3, TEN2)
         nd = mod (nch div 10, TEN2)
         nchk = mod (nch, 10)
         if (na > nb || nb > nc || nc > nd) {
            ntemp = na
            na = nd
            nd = ntemp
            ntemp = nb
            nb = nc
            nc = ntemp
            }
         if (nchk == 1) {
            j += 1
            nch = nchar (j)
            ne = nch div TEN7
            nf = mod (nch div TEN5, TEN2)
            ng = mod (nch div TEN3, TEN2)
            nh = mod (nch div 10, TEN2)
            nchk = mod (nch, 10)
            if (ne > nf || nf > ng || ng > nh) {
               ntemp = ne
               ne = nh
               nh = ntemp
               ntemp = nf
               nf = ng
               ng = ntemp
               }
            }
         if (nchk == 0)
            nchk = 1
         if (na == 0 && nb == 0) {
            call baxx (nchk, 2)
            next
            }
         call frnt (na - nsi, nb - nsi)
         if (nc ~= 0) {
            call frnt (nc - nsi, nd - nsi)
            if (ne ~= 0) {
               call frnt (ne - nsi, nf - nsi)
               if (ng ~= 0)
                  call frnt (ng - nsi, nh - nsi)
               }
            }
         do k = 1, nchk
            call output (line)
         }
      }

   select (i)
      when (8, 26, 40)
         call ohav (-1)
      when (12, 16)
         call achn
      when (7, 19)
         call ohaf (-1)

   call baxx (2, 2)

   return
   end


# achn --- print the second part of lower case 'h' and 'n'
   subroutine achn

   include "banner_com.r.i"

   integer k, na, nb, nc, nd

   longint kline (30), klk

   data kline / _
         123849,     94249,     84651,     74753,     64854,     64955,
       50550000,  51560000,  51560000,  51570000,  51570000,  51570000,
          65057,     64957,     74857,     84757,     94656,    124156,
         550000,    530000,    520000,    500000,    480000,    440000,
         120000,     90000,     80000,     70000,     60000,     60000/

DB call print (ERROUT, "call achn*n.")

   do k = 1, 30; {
      call baxx (1, 1)
      klk = kline (k)
      na = klk div TEN6
      nb = mod (klk div TEN4, TEN2)
      nc = mod (klk div TEN2, TEN2)
      nd = mod (klk, TEN2)
      call frnt (na, nb)
      if (nc ~= 0)
         call frnt (nc, nd)
      call output (line)
      }

   return
   end


# ohaf --- print common segment of 'C', 'D', 'G', 'O' and 'Q'
   subroutine ohaf (kstep)
   integer kstep

#  kstep == 1 means print left segment
#  kstep == -1 means print right segment

   include "banner_com.r.i"

   integer i, k, n, na, nb, nc, nd

   longint kline (30), klk

   data kline / _
       32480000,  26540000,  23570000,  20600000,  18620000,  16640000,
       14660000,  12680000,  11334769,   9275371,   8245672,   7206073,
        6186274,   5166475,   4146676,   4136776,   3126877,   2116978,
        2107078,   2097178,   1087279,   1087279,   1077379,     77380,
          67480,     67480,     67480,     67480,     67480,     67480/

DB call print (ERROUT, "call ohaf (*i)*n.", kstep)

   if (kstep == 1) {
      k = 0
      n = 17
      }
   else {
      k = 31
      n = 30
      }

   do i = 1, n; {
      call baxx (1, 1)
      k += kstep
      klk = kline (k)   # extract fields
      na = klk div TEN6
      nb = mod (klk div TEN4, TEN2)
      nc = mod (klk div TEN2, TEN2)
      nd = mod (klk, TEN2)
      call frnt (na, nb)
      if (nc ~= 0)
         call frnt (nc, nd)
      call output (line)
      }

   return
   end


# legl --- print initial part of 'h', 'k', 'l', 'm', 'n', 'p' and 'r'
   subroutine legl (n, nx)
   integer n, nx

#  The parameters n and nx indicate the desired letter as follows:

#       h  k  l  m  n  p  r
#   n: 25 25 25  0  0 25  0
#  nx:  0  0  0  0  0 25  0

   include "banner_com.r.i"

   integer i, k
   integer ks (16)

   data ks /6, 7, 48, 51, 7, 8, 47, 48, 8, 9, 46, 47, 9, 12, 43, 46/

DB call print (ERROUT, "call legl (*i, *i)*n.", n, nx)

   call baxx (1, 1)
   call frnt (-nx, 6 - nx)
   call frnt (49 + n - nx, 55 + n - nx)
   call output (line)
   call output (line)

   do i = 1, 4; {
      k = 4 * (i - 1) + 1
      call frnt (ks (k) - nx, ks (k + 1) - nx)
      call frnt (ks (k + 2) + n - nx, ks (k + 3) + n - nx)
      call output (line)
      }

   call frnt (12 - nx, 43 + n - nx)

   do k =1, 6
      call output (line)

   return
   end


# ohav --- print common segment of 'b', 'c', 'd', 'o', 'p' and 'q'
   subroutine ohav (kstep)

#  kstep == 1 means print left segment
#  kstep == -1 means print right segment

   include "banner_com.r.i"

   integer i, k, na, nb, nc, nd

   longint kline (17), klk

   data kline / _
       20370000,  16410000,  13440000,  11460000,   9480000,   7500000,
        6510000,   5203752,   4164153,   3144354,   2124555,   1104756,
        1094856,   1084956,     75057,     75057,     65157/

DB call print (ERROUT, "call ohav (*i)*n.", kstep)

   if  (kstep == 1)
      k = 0
   else
      k = 18

   do i = 1, 17; {
      call baxx (1, 1)
      k += kstep
      klk = kline (k)
      na = klk div TEN6
      nb = mod (klk div TEN4, TEN2)
      nc = mod (klk div TEN2, TEN2)
      nd = mod (klk, TEN2)
      call frnt (na, nb)
      if (nc ~= 0)
         call frnt (nc, nd)
      call output (line)
      }

   return
   end


# legu --- do first part of 'B', 'D', 'E', 'F', 'H', 'I', 'K', 'L', 'M', 'N', 'P
' and 'R'
   subroutine legu (n)
   integer n

#  For letters 'M' and 'N', the parameter n has value 4
#  For all other letters, the parameter n has value 7

   include "banner_com.r.i"

   integer i, k
   integer ks (16)

   data ks /7, 8, 72, 73, 8, 9, 71, 72, 9, 10, 70, 71, 10, 13, 67, 70/

DB call print (ERROUT, "call legu (*i)*n.", n)

   call baxx (1, 1)
   call frnt (0, 6)
   call frnt (74, 80)

   do i = 1, 3
      call output (line)

   call frnt (6, 7)
   call frnt (73, 74)

   do i = 1, 3
      call output (line)

   do i = 1, 4; {
      k = 4 * (i - 1) + 1
      call frnt (ks (k), ks (k + 1))
      call frnt (ks (k + 2), ks (k + 3))
      call output (line)
      }

   call frnt (13, 67)
   do i = 1, n
      call output (line)

   return
   end


# baxx --- put background symbols in output lines
   subroutine baxx (n, j)
   integer n, j

#  for j ~= 1,  print n lines of background

   include "banner_com.r.i"

   integer i

DB call print (ERROUT, "call baxx (*i, *i)*n.", n, j)

   do i = 1, 132
      line (i) = background_sym
   if (j == 1)
      return
   do i = 1, n
      call output (line)

   return
   end


# frnt --- put foreground symbols in buffer from na+move through nb+move
   subroutine frnt (na, nb)
   integer na, nb

   include "banner_com.r.i"

   integer i, j, k

DB call print (ERROUT, "call frnt (*i, *i)*n.", na, nb)

   i = na + move
   j = nb + move - 1

DB call print (ERROUT, "start = *i, end = *i*n.", i, j)

   do k = i, j
      line (k) = foreground_sym

   return
   end


# do_args --- get banner text and mode from argument list
   subroutine do_args (foreground_sym, background_sym, banner_text)
   character foreground_sym, background_sym, banner_text (MAXKARD)

   integer getarg
   integer i, reverse_video, junk (2)

   character c, last_arg (MAXKARD)

   if (getarg (1, banner_text, 2) == EOF)
      call error ("Usage: banner { - | -c <char> } <string>.")

   reverse_video = NO
   c = DEFAULT_CHAR
   for (i = 1; getarg (i, last_arg, MAXKARD) ~= EOF; i += 1) {
      if (last_arg (1) == '-'c && last_arg (2) == EOS) {
         if (getarg (i + 1, junk, 1) ~= EOF) # see if there's another arg
            reverse_video = YES
         }
      elif (last_arg (1) == '-'c
        && (last_arg (2) == 'c'c | last_arg (2) == 'C'c)
        && (last_arg (3) == EOS)) {
         if (getarg (i + 2, junk, 1) ~= EOF) {
            i += 1
            if (getarg (i, junk, 2) == 1)
               c = junk (1)
            }
         }
      elif (getarg (i + 1, junk, 1) == EOF)
         break
      }

   call scopy (last_arg, 1, banner_text, 1)
   if (reverse_video == YES) {
      foreground_sym = ' 'c
      background_sym = c
      }
   else {
      foreground_sym = c
      background_sym = ' 'c
      }

   return
   end


# output --- print a line on standard output
   subroutine output (line)
   integer line (ARB)

   integer l (134), i

DB call print (ERROUT, "call output (line)*n.")

   do i = 1, 132
      l (i) = line (i)

   l (133) = NEWLINE
   l (134) = EOS
   call putlin  (l, STDOUT)

   return
   end



# block data for banner program

   include "banner_data.r.i"
#-t-
#-h-  banner_com.r.i         1451  local  09/24/80  13:08:27
# bannercom --- common definitions for banner program

   character foreground_sym   # foreground character
   character background_sym   # background character
   character line             # output line buffer
   integer   move             # vertical character offset
   character syma             # sorted list of printable symbols
   longint   symn             # sorted character size descriptions
                              # NOTE: the elements of syma and symn
                              #     correspond one to one.
   longint   nchar            # array of character descriptions

   common /cbaner/ foreground_sym, background_sym, line (132),
      move, syma (MAXSYM), symn (MAXSYM), nchar (3000)

# The following definitions are used only by the Block Data segment:

   longint ia (186), ib (180), ic (181), id (179), ie (174),
      if (184), ig (180), ih (173), ii (179), ij (187), ik (179),
      il (180), im (176), in (171), io (168), ip (163), iq (160)

   equivalence (ia (187), ib (1)), (ib (181), ic (1)),
               (ic (182), id (1)), (id (180), ie (1)),
               (ie (175), if (1)), (if (185), ig (1)),
               (ig (181), ih (1)), (ih (174), ii (1)),
               (ii (180), ij (1)), (ij (188), ik (1)),
               (ik (180), il (1)), (il (181), im (1)),
               (im (177), in (1)), (in (172), io (1)),
               (io (169), ip (1)), (ip (164), iq (1)),
               (nchar (1), ia (1))
#-t-
#-h-  banner_data.r.i       -27093  local  09/24/80  13:08:30
# block data for banner program
   block_data

   include "banner_com.r.i"

   data syma / _
      'E'c, 'e'c, 'T'c, 't'c, 'A'c, 'a'c, 'O'c, 'o'c,
      'I'c, 'i'c, 'N'c, 'n'c, 'S'c, 's'c, 'H'c, 'h'c,
      'R'c, 'r'c, 'D'c, 'd'c, 'L'c, 'l'c, 'U'c, 'u'c,
      'B'c, 'b'c, 'C'c, 'c'c, 'F'c, 'f'c, 'G'c, 'g'c,
      'J'c, 'j'c, 'K'c, 'k'c, 'M'c, 'm'c, 'P'c, 'p'c,
      'Q'c, 'q'c, 'V'c, 'v'c, 'W'c, 'w'c, 'X'c, 'x'c,
      'Y'c, 'y'c, 'Z'c, 'z'c, '0'c, '1'c, '2'c, '3'c,
      '4'c, '5'c, '6'c, '7'c, '8'c, '9'c, '+'c, '-'c,
      '|'c, '='c, '/'c, '%'c, '^'c, '_'c, '<'c, '>'c,
      '('c, ')'c, '*'c, '?'c, '&'c, '$'c, '#'c, '!'c,
      ','c, '.'c, ';'c, ':'c, "'"c, '"'c, '`'c, '@'c,
      EOS /

#     In the above data statement, the symbolic constant, '^'c,
#  stands for the "degrees" symbol (superscript zero); the sym-
#  bolic constant, '`'c, stands for the "cent" symbol.  Both of
#  these are in the EBCDIC character set but not in the ASCII
#  character set.

   data symn / _
      490001, 340024, 510072, 220103, 660123, 380185, 540239, 340245,
      270245, 180251, 670268, 420315, 440315, 290386, 650430, 420463,
      550463, 300502, 570518, 390520, 460542, 180557, 640562, 420609,
      520641, 390669, 480688, 310712, 490726, 300751, 560783, 470822,
      360890, 180921, 620941, 401001, 761033, 641085, 461132, 391159,
      541175, 391227, 701249, 461309, 941350, 671435, 611498, 441572,
      571623, 451683, 461731, 311800, 491842, 251885, 381904, 421963,
      412019, 412063, 432118, 382184, 442215, 432275, 362341, 362347,
      102351, 362353, 282357, 282385, 122425, 342436, 312480, 312511,
      172542, 172559, 442576, 352621, 532664, 402729, 362781, 092833,
      092842, 092851, 092858, 092869, 092876, 182885, 312900, 482938,
      503001 /

#     1 -  186 : 186
   data ia / _
      000638441, 000080745, 000638441, 000080745, 000637451, 000080742,
      000635471, 000080740, 000632501, 000080740, 000626561, 000080740,
      000621611, 000080743, 000674800, 000774802, 000873802, 001072800,
      001170800, 001368800, 001665800, 002359800, 003054804, 000037200,
      000041160, 000044130, 000046110, 000048090, 000050070, 000051060,
      052026331, 000052370, 041626331, 000053410, 031426331, 000054430,
      021226331, 000055450, 011026331, 000056470, 010926331, 000056480,
      010826331, 000056490, 000726331, 000057502, 000626331, 000057512,
      000626331, 000057502, 010726331, 000056490, 010726331, 000056480,
      010826331, 000056470, 020926331, 000055450, 031026331, 000054430,
      041126331, 000053410, 051226331, 000052370, 061426510, 071526500,
      091826480, 111826460, 131826440, 000041260, 000037260, 000080533,
      000080610, 000080660, 000080680, 000080700, 000080710, 000080720,
      000080732, 000673800, 000674802, 000774803, 000874802, 000974800,
      001074800, 001374800, 000080007, 001374800, 001074800, 000974800,
      000874802, 000774803, 000674802, 000673800, 000080732, 000080720,
      000080710, 000080700, 000080680, 000080660, 000080610, 000080533,
      000053490, 000054490, 000055490, 000056490, 000057490, 000059490,
      000062080, 000067050, 000073030, 000073012, 000073000, 001149550,
      000949550, 000849552, 010949550, 011049550, 021449550, 042249550,
      072249550, 122249550, 000006003, 000007002, 000008000, 000009000,
      000011000, 000013000, 000015000, 000017000, 000020000, 000023000,
      000026000, 000029000, 001017320, 000821350, 000725390, 000727420,
      000628450, 000628480, 000628341, 000051360, 000628341, 000054400,
      283443570, 283446600, 283449630, 283452660, 283455690, 283458720,
      283461750, 283463780, 283462800, 283459800, 283456800, 283453780,
      283449740, 283446710, 283443680, 000628341, 000065401, 000628341,
      000062360, 000628590, 000628550, 000727520, 000724490, 000820460,
      001016420, 000039000, 000036000, 000033000, 000030000, 000026000,
      000023000, 000020000, 000017000, 000015000, 000012000, 000010000,
      000009000, 000008000, 000007003, 000006003, 000020080, 000023050 /

#   187 -  366 : 180
   data ib / _
      042541460, 032638500, 022737510, 012836530, 012936540, 001219301,
      000055360, 001021311, 000056370, 000922311, 000056380, 000823321,
      404449570, 000824331, 000057500, 000825331, 000057510, 010825341,
      000057510, 010926341, 000057520, 020927341, 000057520, 031027351,
      000057520, 041128351, 000057520, 051228351, 000057520, 061329361,
      000056510, 071429361, 000056500, 081630371, 000056490, 091931381,
      000055470, 082331401, 000055440, 000054060, 000053040, 000052030,
      000050020, 000048010, 000044000, 000009000, 000008002, 000009010,
      000011020, 000023030, 000023050, 000023070, 021169780, 021070780,
      020971780, 010872792, 010773790, 000773800, 001367800, 001070800,
      000971800, 000872800, 000773803, 000674803, 000649552, 000748550,
      000847550, 000946551, 000070640, 001243551, 000072620, 005561730,
      005560742, 005561730, 005562720, 005564700, 000012000, 000009000,
      000008000, 000007000, 000006002, 021568820, 021267820, 021165820,
      021064810, 020962790, 020960780, 020958760, 020857740, 020855730,
      020853710, 000069520, 000067500, 000066480, 000064460, 000062450,
      000060430, 000059410, 000057400, 000055380, 000054360, 000052340,
      000050330, 000048310, 000047290, 000045270, 000043260, 000042240,
      000040220, 000038210, 193676820, 173576820, 153376820, 143175820,
      123075820, 102875820, 092674820, 072473820, 052372820, 032269820,
      000082020, 000082003, 000082690, 000082720, 000082730, 000082740,
      000082753, 000082763, 022950640, 013047680, 022945700, 052643720,
      062342730, 072041750, 071840561, 000076630, 071639531, 000077660,
      071539521, 000078680, 061438511, 000078690, 051338501, 000079700,
      041238501, 000079710, 041137501, 000079720, 031037491, 000080730,
      030937491, 000080730, 020937491, 000080740, 020836491, 000080740,
      010836491, 000080740, 010736491, 000080742, 000736491, 000080740,
      000736481, 000080740, 000636481, 000080742, 000636481, 000080730,
      000736481, 000079730, 000736481, 000079720, 000735471, 000079720,
      000835471, 000078710, 010835471, 000078710, 010835471, 000077700/

#   367 -  547 : 181
   data ic / _
      010934461, 000076690, 021034461, 000075680, 021133451, 000075670,
      031231451, 000075660, 031429441, 000075630, 041626441, 000076610,
      054357770, 064255790, 084155790, 093955780, 000037110, 000035140,
      000031170, 000045370, 022233480, 022231500, 022229520, 042028530,
      051627540, 051426411, 000055450, 041226391, 000056480, 041125381,
      000056490, 031025371, 000057500, 020924361, 000057510, 010824361,
      000057510, 010824361, 000057520, 000724361, 000057520, 000724351,
      000057520, 000723351, 000057522, 000723351, 000056510, 000723351,
      000056500, 000822341, 000055490, 000922341, 000055480, 011021331,
      000054470, 011220331, 000054450, 023243540, 033139550, 053038550,
      062938550, 082738550, 000024110, 001338441, 000080670, 001038441,
      000080700, 000938441, 000080710, 000838441, 000080720, 000738441,
      000080733, 000638441, 000080743, 000044385, 000044386, 000638441,
      000080743, 000738441, 000080733, 000838441, 000080720, 000938441,
      000080710, 001038441, 000080700, 001338441, 000080670, 000080007,
      001367800, 001070800, 000971800, 000872800, 000773803, 000674803,
      001339451, 000080740, 001039451, 000080740, 000939451, 000080740,
      000839451, 000080740, 000739451, 000080743, 000639451, 000080743,
      394574803, 384574800, 374574800, 364574800, 354673800, 334673800,
      294772800, 154871800, 085069800, 045267790, 033940551, 000079640,
      023840790, 013641780, 003342770, 002644750, 001145740, 000947720,
      000850690, 000854650, 000009000, 000010010, 000012020, 000021030,
      000024040, 000024070, 000024100, 001227460, 000935460, 000839490,
      000743510, 000645520, 000647540, 000055480, 000056502, 414550570,
      394850570, 000057380, 000057372, 000056370, 000055380, 000053390,
      000049410, 000674805, 000674805, 000651570, 000750570, 010750560,
      010849560, 020948551, 000080740, 021047551, 000080740, 031245541,
      000080730, 041443531, 000080720, 061641511, 000080710, 072037501,
      000080680, 000080006, 000012000, 000009000, 000008000, 000007000,
      000006002, 000667800, 000670800, 000671800, 000672800, 000673803,
      00674803/

#   548 -  726 : 179
   data id / _
      000006006, 000007002, 000008002, 000010000, 000011000, 000013000,
      000016000, 000023000, 000030004, 000012000, 000009000, 000008000,
      000007000, 000006002, 000080743, 000080733, 000080720, 000080710,
      000080700, 000080670, 000080230, 000080180, 000080150, 000080130,
      000080110, 000080090, 000080080, 072467800, 062070800, 051771800,
      041572800, 031373800, 021273800, 021173800, 011074800, 010974802,
      000008003, 000007003, 000006007, 000007002, 000008010, 010974800,
      020974800, 021074800, 031173800, 031273800, 041373800, 051472800,
      061671800, 071970800, 092367800, 000080110, 000080130, 000080160,
      000080210, 000080670, 000080700, 000080710, 000080720, 000080733,
      000080743, 000057512, 000057500, 000057490, 000057480, 000057450,
      000057130, 000057090, 000057070, 000057050, 000057040, 000057020,
      000017010, 000013010, 000011000, 000010000, 000009000, 000008000,
      000007003, 000007012, 000008020, 020951570, 031051570, 041150570,
      061349570, 081648570, 082045570, 000057026, 000014020, 000011020,
      000010020, 000009020, 000008022, 000639451, 000080746, 000639451,
      000080746, 000639451, 000080747, 000738461, 000080732, 000837471,
      000080720, 000936481, 000080710, 001035501, 000080690, 011233521,
      000079670, 011431411, 435564790, 021827411, 000079440, 024044780,
      033945770, 053846750, 063748740, 073649720, 093451690, 123254650,
      000029160, 000080742, 000080730, 000080720, 000080710, 000080680,
      000080003, 000080030, 000080060, 000080090, 092037500, 061641510,
      041443530, 031245540, 021047550, 020948550, 010849560, 010750560,
      000750570, 000651570, 021169780, 021070780, 020971780, 010872792,
      010773790, 000674806, 000773800, 010773790, 010872790, 010872780,
      020971780, 021070770, 031169770, 041268760, 051367750, 061466740,
      071664740, 091862740, 102060750, 112356760, 132653780, 162651790,
      192651790, 212651790, 000651572, 000650570, 010750570, 010749570,
      010839441, 000056470, 020937560, 031136550, 041335550, 051535540,
      061635520, 081736510, 111737490, 131639450, 001338441/

#   727 -  900 : 174
   data ie / _
      000080740, 001038441, 000080740, 000938441, 000080740, 000838441,
      000080740, 000738441, 000080743, 000638441, 000080743, 374574802,
      354774800, 325074800, 265674800, 216174803, 000080743, 000080732,
      000080720, 000080700, 000080680, 000080650, 000080590, 000080544,
      000649553, 000749552, 000849550, 001249550, 000062000, 000069000,
      000072000, 000075000, 000077000, 000078000, 001249551, 000079680,
      000949551, 000079710, 000849551, 000080730, 000749551, 000080740,
      000749551, 000080750, 000649551, 000080762, 000649551, 677176800,
      647375800, 000079630, 000079620, 000078620, 000077630, 000075640,
      000073650, 000071670, 021169780, 021070780, 020971780, 010872792,
      010773790, 000773800, 000674804, 000774800, 010774800, 010830361,
      000080730, 010830361, 000079730, 020930361, 000079720, 021030361,
      000078720, 031129361, 000078710, 041229361, 000077700, 051328361,
      000076690, 061527361, 000076680, 071825361, 000075660, 093664760,
      103662760, 093658770, 063653780, 033651790, 023651792, 000036250,
      000036260, 000036270, 000036280, 000036293, 000036303, 000017120,
      082031360, 062226400, 042325430, 034456660, 031217451, 000070520,
      021019361, 000072390, 020920331, 000074420, 010821321, 000076420,
      010821321, 000077430, 010722321, 435666780, 000722321, 435270790,
      000722321, 425072800, 000623321, 424874800, 000623311, 414775810,
      000623311, 414676810, 000623311, 404676820, 000623311, 404577825,
      000623311, 404676820, 000623311, 414676810, 000623311, 414775810,
      000722311, 424874800, 000722311, 425072800, 010722311, 435270790,
      010821311, 445666780, 010821311, 000077450, 020920311, 000076460,
      021019311, 000075480, 031217311, 000075500, 043052750, 053056760,
      062969780, 072872790, 092773800, 112564671, 000080730, 142361701,
      000080730, 000080600, 000079602, 000078600, 000076610, 000073620,
      000069640, 000019120, 000022090, 000023070, 000024050, 000024040,
      000024030, 000024020, 010911230, 010813220, 000715191, 000080740/

#   901 - 1084 : 184
   data if / _
      000674802, 000673800, 000773802, 010872800, 011071800, 021270800,
      021567800, 000080030, 000080040, 000080050, 000080070, 000080080,
      000080110, 000080160, 000080670, 000080700, 000080710, 000080720,
      000080733, 000080743, 000013080, 000015050, 000016030, 000017020,
      000017012, 001674800, 001574800, 000609121, 000080730, 010772800,
      010871801, 000095890, 021168801, 000097870, 038086980, 048085990,
      068085990, 088086980, 108087970, 148089950, 001330381, 000080670,
      001031391, 000080700, 000933401, 000080710, 000834411, 000080720,
      000735421, 000080730, 000736431, 000080730, 000737451, 000080730,
      000638461, 000080740, 000640471, 000080740, 000641481, 000080740,
      000049420, 000051420, 000052410, 000053390, 000054370, 000055350,
      000056330, 000058310, 294751590, 274553601, 000080740, 000625431,
      546174800, 000623411, 556274800, 000621391, 566374800, 000719371,
      576573800, 000717351, 586673800, 000915331, 606871800, 003161800,
      002962800, 002763800, 002564800, 002366800, 002167800, 001968800,
      001769800, 001570800, 001370800, 001270800, 001072800, 000973800,
      000873800, 000774802, 000674800, 000006002, 001221290, 000923300,
      000824320, 000726330, 000627350, 000627361, 000055490, 273849550,
      263949550, 254149550, 224248550, 000619441, 000055470, 000617341,
      000055360, 000614311, 000055380, 000712281, 000055400, 002641550,
      002443550, 002244550, 002045550, 001846550, 001647550, 001448550,
      001248550, 001049550, 000949550, 000749552, 000649550, 000006000,
      001367800, 001066800, 000963800, 000859800, 000756800, 000753800,
      000749770, 000646740, 000643710, 000639670, 000064360, 000061330,
      000058290, 000054260, 000051230, 000048190, 000044160, 000041130,
      000038100, 000034060, 000031030, 000028000, 000024000, 000021000,
      000018000, 000017020, 000020050, 000024080, 000027120, 000031150,
      000034190, 000038220, 000041260, 000045290, 000048330, 000636520,
      000640550, 000643580, 000747620, 000750660, 000754690, 000857720,
      000960760, 001064790, 001366800, 000080007, 001367800, 001070800,
      000971800, 000872800, 000773803, 000674803/

#  1085 - 1264 : 180
   data ig / _
      001237490, 000941500, 000844520, 000746530, 000647540, 000648550,
      000055490, 000056502, 000057500, 000649570, 000648570, 000747570,
      000846570, 000944560, 001240560, 000055000, 000053000, 000052000,
      000050000, 000048000, 000047000, 001237490, 000941500, 000844520,
      000746530, 000647540, 000648550, 000055490, 000056502, 000057500,
      000649570, 000648570, 000747570, 000846570, 000944560, 001240560,
      000055000, 000053000, 000052000, 000050000, 000048000, 000044000,
      000012000, 000009000, 000008000, 000007000, 000006002, 001313451,
      000080740, 001039451, 000080740, 000939451, 000080740, 000839451,
      000080740, 000739451, 000080743, 000639451, 000080743, 394574804,
      394673802, 394772800, 394871800, 395069800, 405267790, 405564790,
      000079400, 000078410, 000077420, 000075440, 000074450, 000072470,
      000069500, 000065540, 001232451, 000075620, 000931411, 000076660,
      000829391, 000078680, 000728371, 000079700, 000627351, 000080720,
      000627341, 000080730, 263374810, 263275810, 253275820, 253176820,
      142481900, 142882900, 143083900, 133284910, 132023331, 000091840,
      131926341, 000091850, 121927341, 000092850, 121827351, 000092862,
      121826351, 000092860, 121825341, 000092860, 121823341, 000092860,
      121820331, 000092860, 123285920, 133185910, 123084910, 092884910,
      072683900, 052482900, 042381900, 032480890, 021516251, 000088790,
      011316261, 000088780, 001117281, 000087760, 000918301, 000086740,
      000819321, 000085720, 000720361, 000084680, 000721391, 000083650,
      000823451, 000081590, 010924800, 021126780, 031628760, 041730740,
      071832720, 101835690, 000066380, 000060440, 253176820, 253275820,
      263275810, 263374810, 000627341, 000080730, 000627351, 000080720,
      000728371, 000079700, 000829391, 000078680, 000931411, 000076660,
      001232451, 000075620, 000080006, 001268800, 000971800, 000872800,
      000773800, 000674802, 000080745, 000080732, 000080720, 000080710,
      000080700, 000080680, 000080660, 000080630, 000080600, 000080570,
      000080540, 000080510, 000080480, 000080450, 000080420, 396770800/

#  1265 - 1437 : 173
   data ih / _
      366272800, 335973800, 305673800, 275374800, 245074800, 214774800,
      184474800, 154174800, 123874800, 000035090, 000032060, 000029030,
      000026000, 000023000, 000020000, 000018000, 000017000, 000018040,
      000021070, 000024100, 000028130, 000031160, 000034200, 233774800,
      264074800, 294374800, 324674800, 354974800, 385273800, 415673800,
      445972800, 476369800, 000080500, 000080530, 000080570, 000080600,
      000080630, 000080660, 000080680, 000080700, 000080710, 000080720,
      000080732, 000080745, 000055493, 000055482, 000055460, 000055450,
      000055420, 000055400, 000055370, 000055340, 000055310, 000055270,
      000055240, 000055210, 184247550, 153948550, 123649550, 093349550,
      063049550, 032749550, 000023000, 000020000, 000017000, 000014010,
      000017040, 000019070, 000022100, 122549550, 152849550, 183149550,
      213448550, 243648550, 273947550, 294345550, 000055320, 000055350,
      000055380, 000055410, 000055440, 000055460, 000055470, 000055480,
      000055493, 000080744, 000080732, 000080720, 000080710, 000080700,
      000080680, 000080670, 000080640, 000080600, 000080570, 000080530,
      000080490, 000080450, 000080410, 000080370, 336470800, 306072800,
      265673800, 225273800, 184874800, 144474800, 104074800, 073774800,
      033374800, 002974800, 000025000, 000021000, 000020000, 000020020,
      000024060, 000028100, 000032140, 000036180, 000040220, 000044260,
      000048300, 000052340, 000056380, 000060420, 000064460, 000068500,
      000072540, 000076580, 000080600, 000080570, 000080540, 000080500,
      000076460, 000073420, 000069390, 000065350, 000061310, 000058280,
      000054240, 000050200, 000047170, 000043130, 000039090, 000036050,
      000032010, 000028000, 000024000, 000021000, 000021030, 000024070,
      112874800, 153274800, 193674800, 234074800, 274474800, 314874800,
      355273800, 385673800, 426071800, 466569800, 000080500, 000080540,
      000080580, 000080620, 000080660, 000080680, 000080700, 000080720,
      000080732, 000080745, 000055492, 000055482, 000055470/

#  1438 - 1616 : 179
   data ii / _
      000055460, 000055440, 000055410, 000055380, 000055350, 000055320,
      000055280, 000055250, 000055220, 184145550, 153847550, 123548550,
      093249550, 052849550, 022549550, 002249550, 000019000, 000016000,
      000015000, 000019020, 000023060, 000027110, 000032150, 000036190,
      000040240, 000044280, 000049320, 000053360, 000055350, 000055320,
      000055290, 000051250, 000048220, 000045180, 000041150, 000037110,
      000034080, 000030040, 000027000, 000023000, 000020000, 000015000,
      000016020, 000019060, 092349550, 122649550, 163048550, 193348550,
      223647550, 254045550, 000055290, 000055320, 000055360, 000055390,
      000055410, 000055440, 000055460, 000055470, 000055482, 000055492,
      000080740, 000674800, 000673800, 000773802, 000772800, 000872800,
      000971800, 001070800, 001169800, 001367800, 001465800, 001664800,
      001862800, 001960800, 002158800, 002357800, 001013251, 000080550,
      000816261, 000080530, 000719281, 000080510, 000721301, 506771800,
      000722311, 486573800, 000624331, 466373800, 000626351, 456174800,
      283743591, 000080740, 293941581, 000080740, 000056310, 000054330,
      000053340, 000051340, 000050330, 000050310, 000051290, 000052270,
      000054260, 000624411, 000056470, 000622391, 485774800, 000621381,
      505974800, 000619361, 526173800, 000717341, 546273800, 000815321,
      556472800, 001012311, 576870800, 002959800, 002760800, 002562800,
      002464800, 002266800, 002067800, 001968800, 001769800, 001570800,
      001471800, 001272800, 001172800, 001073800, 000973800, 000873800,
      000774802, 000006002, 000649552, 000648550, 000747550, 000746550,
      000845550, 000944550, 001143550, 001242550, 001340550, 001539550,
      001637550, 001836550, 001934550, 000911211, 000055330, 000714221,
      000055310, 000615241, 304348550, 000617251, 284249550, 000618401,
      000055490, 203949550, 000037210, 000036230, 000034210, 000034200,
      000618360, 000617371, 000055490, 000715281, 303949550, 000714271,
      324049550, 000812251, 334348550, 002435550, 002236550, 002138550,
      001939550, 001841550, 001642550, 001543550, 001345550/

#  1617 - 1803 : 187
   data ij / _
      001246550, 001147550, 000948550, 000848550, 000749550, 000649552,
      000080743, 000080733, 000080720, 000080710, 000080700, 000080680,
      000080660, 000080640, 000080620, 000659800, 000657800, 000655800,
      000753800, 000750800, 000748800, 000846661, 000080720, 000844631,
      000080730, 000941611, 000080730, 001039591, 000080740, 001337571,
      000080740, 005474800, 005274800, 000050000, 000048000, 000045000,
      000043002, 001335450, 001037470, 000939490, 000842511, 000080740,
      000844541, 000080740, 000746561, 000080740, 000748581, 000080740,
      000751601, 000080730, 000653631, 000080720, 000655661, 000080690,
      000657800, 000080590, 000080620, 000080640, 000080660, 000080670,
      000080690, 000080700, 000080710, 000080720, 000080732, 000080744,
      000080742, 081673800, 051872800, 031971800, 021969800, 021966800,
      011963800, 011860800, 000609161, 000080570, 000654800, 000651800,
      000748800, 010844800, 010941651, 000080700, 031138601, 000080720,
      041435571, 000080730, 051732541, 000080740, 072028511, 000080740,
      104874800, 134574800, 000041160, 000038190, 000037220, 000038250,
      000041280, 000044310, 354774800, 385074800, 415474800, 445773800,
      476073800, 506372800, 536770800, 000080560, 000080590, 000080620,
      000080650, 000080680, 000080710, 000080720, 000080730, 000080743,
      000008000, 001054800, 001154800, 001354800, 001559800, 001765800,
      001968800, 002170800, 002372800, 002573800, 002773800, 000610281,
      000080740, 000612301, 000080740, 000614321, 000080740, 000616341,
      000080740, 000618361, 000080740, 000620381, 000080740, 000622401,
      000080740, 000623421, 000080740, 000625441, 000080740, 000627461,
      000080740, 000629471, 000080740, 000631491, 000080740, 000633511,
      000080740, 000635531, 000080740, 000637551, 000080740, 000639571,
      000080740, 000641591, 000080740, 000643611, 000080740, 000644631,
      000080740, 000646651, 000080740, 000648661, 000080740, 000650681,
      000080740, 000652701, 000080740, 000754800, 000756800, 000858800,
      000860800, 001062800, 001164800, 001365800, 001667800, 002369800,
      002971800, 002973800, 002975800, 000733550, 000933550, 001133550,
      001337550/

#  1804 - 1982 : 179
   data ik / _
      001544550, 001746550, 001947550, 002148550, 002349550, 002549550,
      000608271, 000055490, 000610291, 000055490, 000612311, 000055490,
      000614331, 000055490, 000616351, 000055490, 000618371, 000055490,
      000620391, 000055490, 000622411, 000055490, 000624431, 000055490,
      000626451, 000055490, 000628471, 000055490, 000630550, 000632550,
      000734550, 000836550, 000938550, 001140550, 001842550, 002244550,
      002246550, 002248550, 000047330, 000053270, 000058220, 000061190,
      000064160, 000066140, 000068120, 000070100, 000071090, 083248720,
      072654730, 062258740, 052060750, 041763760, 031565770, 021466780,
      021268780, 011169790, 011070790, 000971800, 000872802, 000773805,
      000872802, 000971800, 011070790, 011169790, 021268780, 021466780,
      031565770, 041763760, 052060750, 062258740, 072654730, 083248720,
      000071090, 000070100, 000068120, 000066140, 000064160, 000061190,
      000058220, 000053270, 000047330, 000071650, 000765710, 000764720,
      000864722, 000964720, 000963730, 001062730, 001260740, 000074000,
      000075000, 000076000, 000077000, 000080000, 000080003, 000012000,
      000010000, 000009002, 000008002, 000007002, 001052590, 001449630,
      001747650, 001946690, 002145710, 002244730, 002444740, 002544611,
      000075630, 001215261, 446166760, 001217271, 456068770, 001219281,
      465969780, 001220291, 475770790, 001221301, 505571790, 001222301,
      000080720, 001223311, 000080720, 001224321, 000080720, 001224331,
      000080720, 001225341, 000080722, 001226351, 000080720, 001226361,
      000080720, 001227371, 000080710, 001227381, 000080710, 001228391,
      000079700, 001229401, 000079690, 001229411, 000079680, 001230431,
      000078670, 001231441, 000078650, 001231471, 000078620, 001332511,
      000077570, 001333760, 001534750, 001835740, 002336730, 002337720,
      002339700, 002342680, 000064470, 000023140, 000026110, 092758630,
      082756670, 062854700, 052853720, 042853730, 032753740, 031114261,
      000075530, 021015241, 000076530, 010955661, 000077690, 010857651,
      000078700, 000871780, 000872780, 000839451, 000079720/

#  1983 - 2162 : 180
   data il / _
      000739451, 000079720, 000639451, 000079730, 000639451, 000080735,
      000739451, 000080730, 000738451, 000080730, 000838451, 000080720,
      000938461, 000080720, 011037461, 000080710, 011136471, 000080700,
      011235481, 000080690, 011334501, 000079680, 021433511, 000079660,
      021730541, 000078640, 032026780, 034042770, 043943760, 053944750,
      063845740, 073746730, 083547710, 103449700, 123252660, 000029150,
      000032220, 000034220, 000035220, 000037220, 000038220, 000040220,
      000042220, 000043220, 223033450, 223035460, 223036480, 223038490,
      2230405 1, 223041530, 223043540, 223044560, 223046570, 000722301,
      000059470, 000722301, 000060490, 000822301, 000062500, 000822301,
      000064520, 000922301, 000065540, 000922301, 000067550, 001022301,
      000068570, 001222301, 000070580, 000072000, 000073000, 000075000,
      000076000, 000078000, 000080003, 001222300, 001022300, 000922302,
      000822302, 000722302, 000025160, 000029130, 000030110, 000031090,
      083241800, 073241800, 053241800, 043141800, 041316311, 000080420,
      031218291, 435268800, 021120271, 455368800, 021046531, 000080680,
      010947541, 000080680, 010948551, 000080680, 010848551, 000080680,
      000848551, 000080680, 000849561, 000080684, 000949561, 000080682,
      001048561, 000080682, 001147561, 000080680, 011246561, 000080680,
      011345561, 000080680, 021444551, 000080680, 021542551, 000080680,
      031740541, 000080680, 032037541, 000080680, 042431531, 000080680,
      055268800, 065168800, 075068800, 084968800, 000047090, 000045110,
      000043130, 000041160, 000037220, 000049270, 000055220, 000058190,
      000061160, 000064140, 000066120, 000068100, 000070090, 000071080,
      062630461, 000072540, 052035471, 000074590, 041738481, 000075620,
      031539491, 000076640, 031341501, 000076660, 021242511, 000077670,
      011143521, 000078680, 011044521, 000078690, 000945531, 000079700,
      000946531, 000079710, 000846541, 000079720, 000846541, 000080720,
      000846551, 000080720, 000747551, 000080733, 000846551, 000080730,
      000946551, 000080720, 000945551, 000080720, 011045551, 000080720/

#  2163 - 2338 : 176
   data im / _
      011144541, 000080710, 021343541, 000079700, 021442531, 616769790,
      031640531, 000079590, 041938521, 000078570, 052235511, 000078570,
      062730501, 000076570, 074957750, 094857740, 104658720, 124460690,
      000042140, 000039160, 000034190, 000080585, 000080630, 000080670,
      000080680, 000080695, 071769800, 032369800, 012869800, 003169800,
      003569800, 003869800, 004169800, 004469800, 014769800, 025069800,
      041823531, 000080690, 335569800, 385769800, 436069800, 476369800,
      516569800, 546769800, 000080570, 000080590, 000080620, 000080640,
      000080660, 000080680, 000080700, 000080720, 000027170, 000031140,
      113353640, 093549680, 083647700, 073746720, 053845730, 043944740,
      033943750, 031728401, 000076420, 021430541, 000077610, 021331511,
      000077650, 011133491, 000078670, 011034481, 000078680, 010935471,
      000079690, 000935461, 000079700, 000836461, 000079710, 000836451,
      000080710, 000837451, 000080720, 000737451, 000080726, 000837451,
      000080720, 000836451, 000080710, 000836461, 000079710, 000935461,
      000079700, 010935471, 000079690, 011034481, 000078680, 011133491,
      000078670, 021331511, 000077650, 021430541, 000077610, 031728401,
      000076420, 033943750, 043944740, 053845730, 073746720, 083647700,
      093549680, 113353640, 000031140, 000027170, 000061460, 000064410,
      000066380, 112036680, 082234700, 062332710, 052331730, 042330501,
      000074530, 032329451, 000075580, 022328421, 000076610, 012127401,
      000077640, 011113191, 273866780, 011026371, 000078670, 000926361,
      000079690, 000825351, 000079700, 000825351, 000080710, 000825341,
      000080710, 000725341, 000080720, 000725331, 000080733, 000825341,
      000080720, 000826341, 000080720, 010826341, 000080720, 010927341,
      000080710, 011027351, 000080710, 021128361, 000079700, 021228371,
      000079690, 031329381, 000078680, 041430391, 000077670, 041631411,
      000077650, 051832421, 000076630, 062133451, 000075600, 082634501,
      000074540, 000072090, 000071100, 000070120, 000068140, 000066160,
      000064190, 000061220/

#  2339 - 2509 : 171
   data in / _
      000058250, 000053310, 000048326, 000048327, 000070105, 000070105,
      000048327, 000048326, 000048329, 000048329, 000048329, 000048329,
      000098005, 000098005, 253545559, 253545559, 253545559, 253545559,
      000012000, 000015000, 000018000, 000021000, 000024000, 000027020,
      000030050, 000033080, 000036110, 000039140, 000042170, 000045200,
      000048230, 000051260, 000054290, 000057320, 000060350, 000063380,
      000066410, 000069440, 000072470, 000075500, 000078530, 000080560,
      000080590, 000080620, 000080650, 000080680, 001266740, 001563770,
      001862780, 002161681, 000079720, 002460661, 000080740, 022760651,
      000080750, 053060651, 000080750, 083360661, 000080740, 113661681,
      000079720, 143962780, 174263770, 204566740, 000048230, 000051260,
      000054290, 000057320, 061435600, 031738630, 021841660, 010812191,
      000069440, 000614201, 000072470, 000515201, 000075500, 000515201,
      000078530, 000614201, 000080560, 010812191, 000080590, 021862800,
      031765800, 061468800, 000074660, 000077630, 000078620, 616872790,
      606674800, 606575802, 606674800, 616872790, 000078620, 000077630,
      000074660, 182248510, 182248520, 182248540, 182227570, 182225610,
      182224610, 182224291, 000052480, 182224281, 000052480, 182224291,
      000052480, 182226351, 000052480, 182228351, 000052480, 000022182,
      182224271, 000064610, 182224281, 000064600, 182224301, 000064580,
      182224643, 182224301, 000049440, 182224281, 000050460, 182224271,
      000051480, 182248520, 182249532, 182224271, 000053480, 182224281,
      000053470, 182224301, 000052450, 182224510, 182224500, 182224470,
      182224300, 182224280, 182224270, 000041390, 000042380, 000044360,
      000045350, 000047330, 000048320, 000050300, 000051290, 000053270,
      000054260, 243941560, 233842570, 213644590, 203545600, 183347620,
      173248630, 153050650, 142951660, 122753680, 112654690, 092456710,
      082357720, 062159740, 052060750, 031862770, 021763780, 001565800,
      001466800, 001268800, 001169800/

#  2510 - 2677 : 168
   data io / _
      000971800, 000971800, 001169800, 001268800, 001466800, 001565800,
      021763780, 031862770, 052060750, 062159740, 082357720, 092456710,
      112654690, 122753680, 142951660, 153050650, 173248630, 183347620,
      203545600, 213644590, 233842570, 243941560, 000054260, 000053270,
      000051290, 000050300, 000048320, 000047330, 000045350, 000044360,
      000042380, 000041390, 000049310, 000054260, 000058220, 000061190,
      000064160, 000067130, 000069110, 093248710, 082456720, 061961740,
      051664750, 041367760, 031070770, 010773790, 010476790, 000278800,
      000179800, 000179800, 000278800, 010476790, 010773790, 031070770,
      041367760, 051664750, 061961740, 082456720, 093248710, 000069110,
      000067130, 000064160, 000061190, 000058220, 000054260, 000049310,
      212951590, 183248620, 173347630, 163446640, 153446650, 153545650,
      153644652, 163743640, 173842630, 183842620, 203941600, 213941590,
      000057230, 000056240, 000055250, 061527531, 000074650, 032128521,
      000077590, 000078020, 013842790, 003644800, 003545802, 003644800,
      013842790, 000078020, 032128521, 000077590, 061527531, 000074650,
      000055250, 000056240, 000057230, 213941590, 203941600, 183842620,
      173842630, 163743640, 153644650, 153545650, 153446650, 163446640,
      173347630, 183248620, 212951590, 000066560, 000069540, 000072520,
      000073510, 000075510, 000076510, 000077520, 000078520, 546468780,
      576069790, 000079710, 000079720, 000080720, 000080730, 041173800,
      021323291, 000080730, 011421341, 000080730, 001520381, 000080730,
      001521401, 000080730, 001524421, 000080720, 011429441, 000080720,
      021332451, 000080710, 041134471, 000080700, 354968800, 365166800,
      375562790, 000079380, 000078400, 000077410, 000076420, 000075440,
      000074450, 000072470, 000070490, 000067520, 000026180, 000030130,
      000033110, 000035090, 000037070, 000039060, 000040050, 000041040,
      000042030, 021730430, 021533450, 011434461, 000068520, 011336720/

#  2678 - 2840 : 163
   data ip / _
      011237740, 001138760, 001036770, 001033581, 000078660, 001031541,
      000079690, 000929531, 000079700, 000927541, 000080710, 000925551,
      000080720, 000923441, 465672800, 010922421, 475871800, 011020401,
      486069790, 011018381, 496366790, 021116351, 000078510, 021215331,
      000077520, 033154750, 032956730, 042860700, 000026050, 062439470,
      062239470, 052339470, 042538470, 032738470, 023037470, 000047020,
      011518470, 011421470, 001324470, 001227470, 001230470, 001133470,
      001135470, 001137470, 001238470, 011339470, 021839470, 032539470,
      052539470, 000025080, 000025130, 114057720, 114053750, 114051780,
      133650800, 143149810, 152948830, 152747840, 152546641, 000085730,
      142346621, 000085750, 142245601, 000086770, 132145591, 000086780,
      132045591, 000087790, 121944591, 000087790, 111944591, 000087800,
      000096004, 091743581, 000088810, 081643571, 000088810, 081643571,
      000088800, 081643571, 000087800, 000096004, 081741551, 000085760,
      091841551, 000084750, 091940541, 000083740, 102039541, 000083720,
      112238531, 000083700, 122436531, 000083680, 132734521, 000084650,
      145161850, 155061860, 164861850, 184761840, 000044200, 000042220,
      000037260, 000326341, 000054460, 000826341, 000054460, 001326341,
      000054460, 001926341, 000054460, 002426341, 000054460, 003446540,
      033546540, 084046540, 000054130, 000054190, 000056240, 000061260,
      000067260, 263440720, 263445770, 000326341, 000080460, 000826341,
      465456800, 001326341, 465461800, 001926341, 465467800, 002426341,
      465472800, 003446541, 000080770, 033546540, 084046540, 000054130,
      000054190, 000056240, 000061260, 000067260, 263440720, 263445770,
      263446800, 263446541, 000080560, 263446541, 000080610, 263446541,
      000080670, 263446541, 000080720, 263446541, 000080770, 041166760,
      021349780, 011432790, 001521800, 001520800, 001521800, 011432790,
      021349780/

#  2841 - 3000 : 160
   data iq / _
      041166760, 000021140, 000023120, 000411240, 000609250, 000025000,
      000025010, 000024030, 000023040, 000021070, 000011040, 000013020,
      000014010, 000015003, 000014010, 000013020, 000011040, 142136430,
      122334450, 000411241, 000046330, 000609251, 000047320, 002532470,
      012532470, 032433460, 042334450, 072136430, 142136430, 122334450,
      112433460, 102532473, 112433460, 122334450, 142136430, 000076670,
      000078510, 000079420, 000080410, 000080400, 000080410, 000079420,
      000078510, 000076670, 000077680, 000079510, 000080410, 000080400,
      000080410, 000079510, 000077680, 000000004, 000077680, 000079510,
      000080410, 000080400, 000080410, 000079510, 000077680, 000048310,
      000052270, 000055240, 000057220, 000059200, 000061180, 030717620,
      031216311, 000063480, 032752640, 032554650, 072756660, 123258670,
      123759670, 121922421, 000067600, 111827471, 000068610, 111832521,
      000068610, 111737571, 000068620, 111742680, 111747680, 111752720,
      121857760, 121860760, 121950551, 000076580, 132048671, 000076720,
      142247660, 152446660, 162646650, 172746630, 192847620, 222848600,
      242750560, 000047330, 000053270, 000056240, 000060200, 173149630,
      152654650, 132357670, 112036441, 000069600, 101830501, 000070620,
      091626541, 000071640, 071424561, 000073660, 061321331, 475967740,
      051219291, 516168750, 041118271, 536269760, 031017251, 556370770,
      030916231, 576471770, 020815221, 586572780, 020814211, 596672780,
      010714201, 606673790, 010713191, 616773792, 000612181, 626874806,
      010713191, 616773792, 010714201, 606673790, 020814211, 596672780,
      020815221, 586572780, 030916231, 576471770, 031017661, 000077700,
      040915661, 000076690, 050713661, 000075680, 136567740, 121966730,
      121864710, 121962700, 132060690, 132357670, 152654650, 173149630,
      000060200, 000056240, 000053270, 000047330/

   end
#-t-
#-t-  banner                    54887  local   01/05/81  16:47:56
#-h-  cmp                        2897  local   01/05/81  17:08:09
#-h-  cmp.doc                     892  local   01/05/81  17:05:12
.bp 1
.in 0 
.he 'CMP'03/06/78'CMP 
.fo ''-#- 
.fi 
.in 7 
.ti -7 
NAME 
.br 
cmp - compare two files 
.sp 1 
.ti -7 
SYNOPSIS 
.br 
cmp file1 [file2]
.sp 1 
.ti -7 
DESCRIPTION 
.br 
File1 is compared line-by-line with file2.
If any lines differ, cmp announces the line number and prints 
each file's offending line. 
.sp
If only 1 filename is given, the standard input is used as
file2.
.sp 1 
.ti -7 
FILES 
.br 
None
.sp 1 
.ti -7 
SEE ALSO 
.br 
diff, comm
.br
.sp 1 
.ti -7 
DIAGNOSTICS 
.br 
If the end of one file is reached before the end of the other, a 
message is printed. 
.sp 1 
.ti -7 
AUTHORS 
.br 
Original by Kernighan and Plauger, with
minor modifications made by Debbie Scherrer (Lawrence Berkeley Laboratory). 
.sp 1 
.ti -7 
BUGS/DEFICIENCIES
.br 
.sp 1
Cmp cannot handle offset lines: line n of file1 
is simply compared to line n of file2. 
  
Blanks are significant.
#-t-  cmp.doc                     892  local   01/05/81  17:05:12
#-h-  cmp.r                      1741  local   01/05/81  17:05:12
#-h- main             567 asc 07-may-80 12:10:07
 ## cmp - compare two files for equality 
  
 DRIVER(cmp)
  
    character arg1(MAXLINE), arg2(MAXLINE) , stdin(2)
    character line1(MAXLINE), line2(MAXLINE) 
    integer equal, getarg, getlin, open 
    integer infil1, infil2, lineno, m1, m2 
  
    data stdin/MINUS, EOS/

    call query ("usage:   cmp file1 [file2].")
    if (getarg(1, arg1, MAXLINE) == EOF)
                call error ('usage:  cmp file1 [file2].')
    if (getarg(2, arg2, MAXLINE) == EOF)        # read STDIN if arg 2
        call scopy(stdin, 1, args, 1)
    infil1 = open(arg1, READ) 
    if (infil1 == ERR) 
       call cant(arg1) 
    if (equal(args, stdin) == YES)
        infil2 = STDIN
    else
        {
        infil2 = open(arg2, READ)
        if (infil2 == ERR)
            call cant(arg2)
        }
    lineno = 0 
    repeat { 
       m1 = getlin(line1, infil1) 
       m2 = getlin(line2, infil2) 
       if (m1 == EOF | m2 == EOF) 
          break 
       lineno = lineno + 1 
       if (equal(line1, line2) == NO) 
          call difmsg(lineno, line1, line2) 
       } 
    if (m1 == EOF & m2 != EOF) 
       call remark('eof on file 1.') 
    else if (m2 == EOF & m1 != EOF) 
       call remark('eof on file 2.') 
 DRETURN
  end 
#-t- main             567 asc 07-may-80 12:10:07
#-h- difmsg           387 asc 07-may-80 12:10:10
 #---------------------------------------------------------- 
 ## difmsg - print line number and differing lines of file1 and file2 
  
    subroutine difmsg(lineno, line1, line2) 
    character line1(MAXLINE), line2(MAXLINE) 
    integer lineno 
  
    call putdec(lineno, 5) 
    call putc(NEWLINE) 
    call putlin(line1, STDOUT) 
    call putlin(line2, STDOUT) 
    return 
    end 
#-t- difmsg           387 asc 07-may-80 12:10:10
#-t-  cmp.r                      1741  local   01/05/81  17:05:12
#-t-  cmp                        2897  local   01/05/81  17:08:09
#-h-  darken                      548  local   01/05/81  16:53:30
# from the University of Arizona
define(DEFAULT,2)
define(LIMIT,10)

# darken - copies input to output, striking each character n times
    character c, getc, arg(MAXLINE)
    integer i, n
    integer getarg, ctoi

    n = DEFAULT
    if (getarg(1, arg, MAXLINE) ^= EOF)
       n = min(ctoi(arg, 1) - 1, LIMIT)
    while (getc(c) ^= EOF) {
       call putc(c)
       if (c > BLANK)  # overstrike black characters
          for (i = 1; i <= n; i = i + 1) {
             call putc(BACKSPACE)
             call putc(c)
             }
       }
    end
#-t-  darken                      548  local   01/05/81  16:53:30
#-h-  dprint                    19132  local   01/05/81  16:48:14
#-h-  dprint.doc         4135  local  09/24/80  13:23:22
.he 'DPRINT'03/23/80'DPRINT'
NAME
.sp
dprint - print a file on a Diablo 1620 or 1620, quickly
.sp 2
SYNOPSIS
.sp
dprint [-s] [-j] [-<page_length>] [<file name>]
.sp 2
DESCRIPTION
.sp
'Dprint' prints the contents of <file name> (or standard input one,
if <file name> is omitted) on the user's terminal, making
the assumption that the terminal is a Diablo model 1610 or 1620
using the ETX/NAK data transfer protocol.
Printing is done bi-directionally, optimizing motion of the
print head and platen as much as possible.
.sp
The "-s" option will cause 'dprint' to sound the alarm on the
Diablo and pause at the beginning of each page, so that paper
without pinfeeds can be used.  When 'dprint' sounds the alarm,
a new sheet of paper should be inserted and positioned at
the very top of the page.  Typing control-f will cause
'dprint' to continue printing.
.sp
<Page_length>, if specified, informs 'dprint' of the length of
the paper being used. If omitted, the standard value of 66
lines per page is assumed.
.sp
It is assumed that the paper has been mounted so that a form
feed will advance to the first line on the next page. This may be
done by pressing the 'set tof' switch (in the upper right
corner of the keyboard) after the paper has been positioned to
line one. 'Dprint' causes a page eject before printing, and,
if the "-j" option is specified, after printing as well.
.sp
A special feature is available to extend the character set
that may be printed beyond standard ASCII.
If 'dprint' sees any of the following characters in its input stream
.ul
with their parity bits turned off,
it will map them into a special character as noted:
.sp
.nf
.ul
Character      'Fmt' Function       Extended Character
.in +4
.sp
a              alpha            lower-case alpha
b              beta             lower-case beta
d              delta            lower-case delta
D              DELTA            upper-case delta
e              epsilon          lower-case epsilon
n              eta              lower-case eta
g              gamma            lower-case gamma
G              GAMMA            upper-case gamma
8              infinity         "infinity" symbol
+              integral         integration sign
l              lambda           lower-case lambda
L              LAMBDA           upper-case lambda
u              mu               lower-case mu
^              nabla            inverted delta (del)
~              not              EBCDIC-style "not"
v              nu               lower-case nu
w              omega            lower-case omega
W              OMEGA            upper-case omega
-              partial          partial differential sign
p              phi              lower-case phi
P              PHI              upper-case phi
y              psi              lower-case psi
Y              PSI              upper-case psi
3              pi               lower-case pi
4              PI               upper-case pi
r              rho              lower-case rho
s              sigma            lower-case sigma
S              SIGMA            upper-case sigma
t              tau              lower-case tau
h              theta            lower-case theta
H              THETA            upper-case theta
x              xi               lower-case xi
z              zeta             lower-case zeta
.in -4
.sp
.fi
(The column headed "'Fmt' Function" gives the name of a
text formatter in-line function that may be used to produce
the desired character.
See the
.ul
Software Tools Text Formatter User's Guide
and the Reference Manual entry for 'fmt' for further information.)
Special characters are printed by careful positioning of the print
element and overstriking of standard ASCII characters.
.sp 2
EXAMPLES
.sp
.nf
help -p dprint | dprint
dprint junk
dprint -s -80 journal_article
.fi
.sp 2
MESSAGES
.sp
.in +5
.ti -5
"<filename>: can't open" if given file could not be opened for
reading.
.br
.in -5
.sp 2
BUGS
.sp
If interrupted by the BREAK key while printing,
'dprint' may hang, waiting for a signal from the Diablo.  Typing
a control-f will clear this condition.
.sp 2
SEE ALSO
.sp
cat, pr, format
#-t-
#-h-  dprint.r        12145  local  09/24/80  13:23:23
include "dprint_def.r.i"

# dprint --- optimize printing on the Diablo

   include "dprint_com.r.i"

   integer ap, i, j, k, start, size, len, save_lword, junk
   integer ctoi, duplx$, inbuf, getarg
   file_des open
   character arg (MAXLINE), buf (BUFLENGTH)
   character t1in
   external quit_unit
   shortcall mkonu$ (18)

   define (quit,1)

   Page_length = 66
   Letter_opt = FALSE
   Eject_opt = FALSE
   Fd = STDIN

   for (ap = 1; getarg (ap, arg, MAXLINE) ~= EOF; ap += 1) {
      if (arg (1) ~= '-'c)
         break
      if (arg (2) == 's'c || arg (2) == 'S'c)
         Letter_opt = TRUE
      elif (arg (2) == 'j'c || arg (2) == 'J'c)
         Eject_opt = TRUE
      else {
         i = 2
         Page_length = ctoi (arg, i)
         }
      }

   if (getarg (ap, arg, MAXLINE) ~= EOF) {
      Fd = open (arg, READ)
      if (Fd == ERR)
         call cant (arg)
      }

   save_lword = duplx$ (-1)

   call mklb$f ($ quit, Quit_label)
   call mkonu$ ("QUIT$"v, loc (quit_unit))
   call duplx$ (or (save_lword, :140000)) # turn off echo and auto-lf
   call set_delay (0, 0, 1)

   Pos = 1
   Line = 1
   Chunk = 0
   Direction = FORWARD
   Outstanding_poll = FALSE

   OUTCON (FF)  # throw a page
   TOP_OF_FORM

   while (inbuf (buf, len, start, size) ~= EOF) {
      if (size == 0)
         call outch (NEWLINE)  # linefeed
      elif (Pos - start > size - Pos) {   # print in reverse Direction
         call t1ou (ESC)   # start backward print
         call t1ou ('6'c)
         Chunk += 2
         Direction = REVERSE
         if (Pos ~= size) {
            call t1ou (ESC)   # position to 'size'
            call t1ou (HT)
            call t1ou (size)
            Chunk += 3
            }
         Pos = size

         for (i = len; i >= start; i -= 1) {
            k = 0
            for (j = i; buf (j) == ' 'c; j -= 1)
               k += 1
            if (k > 3) {   # is it cheaper to do absolute positioning?
               call t1ou (ESC)   # position to 'pos - k'
               call t1ou (HT)
               call t1ou (Pos - k)
               Pos -= k
               Chunk += 3
               i = j   # now put out non-blank
               }

            if (Pos > 0)    # don't print before column 1
               call outch (buf (i))  # put out character
            if (buf (i) == BS)
               Pos += 1
            elif (buf (i) ~= hlf && buf (i) ~= rhlf)
               Pos -= 1
            }
         call outch (NEWLINE)
         }

      else {      # print in forward direction
         call t1ou (ESC)   # start forward print
         call t1ou ('5'c)
         Chunk += 2
         Direction = FORWARD
         if (Pos ~= start) {
            call t1ou (ESC)   # position to 'start'
            call t1ou (HT)
            call t1ou (start)
            Chunk += 3
            }
         Pos = start

         for (i = start; i <= len; i += 1) {
            k = 0
            for (j = i; buf (j) == ' 'c; j += 1)
               k += 1
            if (k > 3) {   # is it cheaper to do absolute positioning?
               call t1ou (ESC)   # position to 'pos + k'
               call t1ou (HT)
               call t1ou (Pos + k)
               Pos += k
               Chunk += 3
               i = j   # now put out non-blank
               }

            if (Pos > 0)      # don't print before column 1
               call outch (buf (i))   # put out character
            if (buf (i) == BS)
               Pos -= 1
            elif (buf (i) ~= hlf && buf (i) ~= rhlf)
               Pos += 1
            }
         call outch (NEWLINE)
         }
      }

   call outch (CR)   # flush out pending NEWLINEs and return carriage
   if (Eject_opt && Line > 1)
      call t1ou (FF)

quit;    # come to this label on QUIT

   call rvonu$ ("QUIT$"v)
   if (Outstanding_poll)
      WAIT_FOR_ACK

   if (Fd ~= STDIN)
      call close (Fd)

   call set_delay (MIN, MAX, SLOPE)    # reset to reasonable value
   call duplx$ (save_lword)   # restore echo

   stop
   end



# inbuf --- input buffer, returning length and text size

   integer function inbuf (buf, len, start, size)
   character buf (BUFLENGTH)
   integer len, start, size

   include "dprint_com.r.i"

   integer l, k, i
   integer getlin

   l = getlin (buf, Fd)
   if (l == EOF)
      return (l)

   while (buf (l) ~= NEWLINE && l < BUFLENGTH - MAXLINE) {
      k = getlin (buf (l + 1), Fd)
      if (k == EOF)
         break
      l += k
      }

   for (len = l - 1; len > 0; len -= 1)
      if (buf (len) ~= ' 'c)
         break

   for (start = 1; start <= len; start += 1)
      if (buf (start) ~= ' 'c)
         break

   size = 0
   for (i = 1; i <= len; i += 1) {
      if (buf (i) == BS)
         size -= 1
      elif (buf (i) ~= hlf && buf (i) ~= rhlf)
         size += 1
      }

   return (l)

   end



# outch --- send character;  handle timing and vertical spacing

   subroutine outch (c)
   character c

   include "dprint_com.r.i"

   integer i, junk, salpha (7), sbeta (11), sdelta (7), sDELTA (19),
      sepsilon (5), seta (13), sgamma (5), sGAMMA (18),
      sinfinity (11), sintegral (26), slambda (17),
      sLAMBDA (11), smu (13), snabla (19), snot (9),
      snu (9), somega (9), sOMEGA (12), spartial (13),
      sphi (3), sPHI (4), spsi (17), sPSI (18), spi (12),
      sPI (20), srho (11), ssigma (9), sSIGMA (14),
      stau (12), stheta (3), sTHETA (3), sxi (15), szeta (12)
   bool outstanding_lf
   character t1in

   data outstanding_lf / FALSE /
   data _
      salpha /L, 'c'c, R, R, '('c, L, 0/,
      sbeta /'B'c, L, L, D, D, '|'c, R, R, U, U, 0/,
      sdelta /'o'c, U, U, '<'c, D, D, 0/,
      sDELTA /L, L, '/'c, D, D, D, '-'c, R, R, R, R, '-'c,
         U, U, U, '\'c, L, L, 0/,
      sepsilon /'c'c, D, '-'c, U, 0/,
      seta /'n'c, R, R, D, D, D, '|'c, L, L, U, U, U, 0/,
      sgamma /')'c, R, '/'c, L, 0/,
      sGAMMA /L, L, '|'c, R, R, U, U, U, '-'c, D, D, D,
         R, R, '`'c, L, L, 0/,
      sinfinity /L, L, 'c'c, R, R, R, R, 'o'c, L, L, 0/,
      sintegral /'|'c, "'"c, R, R, '`'c, L, L, L,
         D, D, D, D, D, D, "'"c, L, '`'c, R, R, U, U, U, U, U, U, 0/,
      slambda /'\'c, D, D, D, L, "'"c, D, L, "'"c,
         U, U, U, U, U, R, R, 0/,
      sLAMBDA /L, L, '/'c, R, R, R, R, '\'c, L, L, 0/,
      smu /'u'c, L, L, D, D, D, '|'c, U, U, U, R, R, 0/,
      snabla /L, L, '\'c, U, U, U, '-'c, R, R, R, R,
         '-'c, D, D, D, '/'c, L, L, 0/,
      snot /'-'c, R, R, U, ','c, D, L, L, 0/,
      snu /L, '('c, R, R, R, '/'c, L, L, 0/,
      somega /L, 'u'c, R, R, R, 'u'c, L, L, 0/,
      sOMEGA /'O'c, D, D, L, '-'c, R, R, '-'c, L, U, U, 0/,
      spartial /'o'c, R, D, '`'c, L, U, '`'c, L, U, '`'c, R, D, 0/,
      sphi /'o'c, '|'c, 0/,
      sPHI /'o'c, '['c, ']'c, 0/,
      spsi /'/'c, '-'c, D, D, R, R, "'"c, L, L, L, L, "'"c,
         R, R, U, U, 0/,
      sPSI /'['c, ']'c, '-'c, D, R, R, "'"c, L, L, L, L, D,
         '`'c, R, R, U, U, 0/,
      spi /U, '-'c, D, D, D, '"'c, D, '"'c, U, U, U, 0/,
      sPI /L, L, '['c, ']'c, R, R, R, R, '['c, ']'c, L, L,
         U, U, U, '-'c, D, D, D, 0/,
      srho /'o'c, L, L, D, D, '|'c, U, U, R, R, 0/,
      ssigma /'o'c, D, R, R, '~'c, U, L, L, 0/,
      sSIGMA /'>'c, D, D, '-'c, U, U, U, U, U, '-'c, D, D, D, 0/,
      stau /'t'c, D, R, R, '~'c, L, L, L, '~'c, R, U, 0/,
      stheta /'O'c, '-'c, 0/,
      sTHETA /'O'c, '='c, 0/,
      sxi /'c'c, R, D, ','c, L, U, U, U, 'c'c, L, D, '`'c, R, D, 0/,
      szeta /'c'c, R, D, ','c, L, U, U, U, '<'c, D, D, 0/

   if (Chunk >= MAXCHUNK) {
      DISABLE_BREAKS
      if (Outstanding_poll)   # have we polled yet?
         WAIT_FOR_ACK
      else
         Outstanding_poll = TRUE
      call t1ou (ETX)         # send poll character
      Chunk = 0
      ENABLE_BREAKS
      }

   if (c == FF) {
      Chunk += 1
      call t1ou (FF)
      TOP_OF_FORM
      Line = 1
      outstanding_lf = FALSE
      }
   elif (c == NEWLINE) {
      Line += 1
      if (Line > Page_length) {
         Chunk += 1
         call t1ou (FF)
         TOP_OF_FORM
         Line = 1
         outstanding_lf = FALSE
         }
      else
         outstanding_lf = TRUE
      }
   else {
      if (outstanding_lf) {
         call t1ou (ESC)   # vertical tab
         call t1ou (VT)
         call t1ou (Line)
         outstanding_lf = FALSE
         Chunk += 3
         }
      select (c)
         when (alpha)     call plotstr (salpha)
         when (beta)      call plotstr (sbeta)
         when (delta)     call plotstr (sdelta)
         when (DELTA)     call plotstr (sDELTA)
         when (epsilon)   call plotstr (sepsilon)
         when (eta)       call plotstr (seta)
         when (gamma)     call plotstr (sgamma)
         when (GAMMA)     call plotstr (sGAMMA)
         when (infinity)  call plotstr (sinfinity)
         when (integral)  call plotstr (sintegral)
         when (lambda)    call plotstr (slambda)
         when (LAMBDA)    call plotstr (sLAMBDA)
         when (mu)        call plotstr (smu)
         when (nabla)     call plotstr (snabla)
         when (not)       call plotstr (snot)
         when (nu)        call plotstr (snu)
         when (omega)     call plotstr (somega)
         when (OMEGA)     call plotstr (sOMEGA)
         when (partial)   call plotstr (spartial)
         when (phi)       call plotstr (sphi)
         when (PHI)       call plotstr (sPHI)
         when (psi)       call plotstr (spsi)
         when (PSI)       call plotstr (sPSI)
         when (pi)        call plotstr (spi)
         when (PI)        call plotstr (sPI)
         when (rho)       call plotstr (srho)
         when (sigma)     call plotstr (ssigma)
         when (SIGMA)     call plotstr (sSIGMA)
         when (tau)       call plotstr (stau)
         when (theta)     call plotstr (stheta)
         when (THETA)     call plotstr (sTHETA)
         when (xi)        call plotstr (sxi)
         when (zeta)      call plotstr (szeta)
         when (hlf) {
            call t1ou (ESC)
            if (Direction == FORWARD)
               call t1ou ('U'c)
            else
               call t1ou ('D'c)
            Chunk += 2
            }
         when (rhlf) {
            call t1ou (ESC)
            if (Direction == FORWARD)
               call t1ou ('D'c)
            else
               call t1ou ('U'c)
            Chunk += 2
            }
      else
         OUTCON (c)
      }

   return
   end



# set_delay --- set terminal delay characteristics

   subroutine set_delay (minimum, maximum, slope)
   integer minimum, maximum, slope

   integer i, vcmd (40)
   character scmd (MAXLINE)

   call encode (scmd, MAXLINE, "*,-8udelay *i *i *i*n"s,
         minimum, maximum, slope)
   i = 1
   call ctov (scmd, i, vcmd, 40)
   call cp$ (vcmd, i, i)

   return
   end




# plotstr --- output special character plot string

   subroutine plotstr (str)
   integer str (ARB)

   include "dprint_com.r.i"

   integer i, junk
   integer t1in

   DISABLE_BREAKS    # so Diablo isn't left in plot mode
   call t1ou (ESC)         # enter plot mode
   call t1ou ('3'c)
   Chunk += 2

   for (i = 1; str (i) ~= 0; i += 1) {
      if (Chunk >= MAXCHUNK) {
         if (Outstanding_poll)
            WAIT_FOR_ACK
         else
            Outstanding_poll = TRUE
         call t1ou (ETX)   # send poll
         Chunk = 0
         }

      select (str (i))
         when (L)
            if (Direction == REVERSE)
               call t1ou (8r040)
            else
               call t1ou (8r010)
         when (R)
            if (Direction == REVERSE)
               call t1ou (8r010)
            else
               call t1ou (8r040)
         when (U) {
            call t1ou (8r033)
            call t1ou (8r012)
            Chunk += 1
            }
         when (D)
            call t1ou (8r012)
      else
         call t1ou (str (i))
      Chunk += 1
      }

   call t1ou (ESC)         # leave plot mode
   call t1ou ('4'c)
   call t1ou (' 'c)
   Chunk += 3
   ENABLE_BREAKS

   return
   end



# quit_unit --- on-unit for the QUIT$ condition

   subroutine quit_unit (cp)
   longint cp

   include "dprint_com.r.i"

   call t1ou (NEWLINE)
   call pl1$nl (Quit_label)

   return
   end
#-t-
#-h-  dprint_com.r.i          719  local  09/24/80  13:23:25
   integer  Pos,              # Current column position
            Line,             # Current line number on page
            Chunk,            # Number of chars sent since last poll
            Page_length,      # Number of lines per page
            Fd,               # Input file descriptor
            Direction         # Current printing direction
   bool     Letter_opt,       # Stop after form feed option
            Eject_opt,        # Eject page at end of file
            Outstanding_poll  # TRUE if there is an outstanding poll
   longreal Quit_label        # Exit label for QUITs

   common /dp$com/ Pos, Line, Chunk, Page_length, Fd, Letter_opt,
      Eject_opt, Outstanding_poll, Direction, Quit_label
#-t-
#-h-  dprint_def.r.i         1890  local  09/24/80  13:23:25
   define (TOP_OF_FORM,{
    if(Letter_opt){
     if(Outstanding_poll)WAIT_FOR_ACK;Chunk=0;Outstanding_poll=FALSE
     call t1ou(BEL);WAIT_FOR_ACK}})
   define (OUTCON(c),{call t1ou(c);Chunk+=1})
   define (WAIT_FOR_ACK,while(t1in(junk)~=ACK);)
   define (DISABLE_BREAKS,call break$(1))
   define (ENABLE_BREAKS,call break$(0))

   define (MAXCHUNK,72)
   define (BUFLENGTH,1000)
   define (MIN,4)
   define (MAX,180)
   define (SLOPE,90)
   define (FORWARD, 0)
   define (REVERSE, 1)

   define (alpha,8r141)          # a
   define (beta,8r142)           # b
   define (delta,8r144)          # d
   define (DELTA,8r104)          # D
   define (epsilon,8r145)        # e
   define (eta,8r156)            # n
   define (gamma,8r147)          # g
   define (GAMMA,8r107)          # G
   define (infinity,8r070)       # 8
   define (integral,8r053)       # +
   define (lambda,8r154)         # l
   define (LAMBDA,8r114)         # L
   define (mu,8r165)             # u
   define (nabla,8r136)          # ^
   define (not,8r176)            # ~
   define (nu,8r166)             # v
   define (omega,8r167)          # w
   define (OMEGA,8r127)          # W
   define (partial,8r055)        # -
   define (phi,8r160)            # p
   define (PHI,8r120)            # P
   define (psi,8r171)            # y
   define (PSI,8r131)            # Y
   define (pi,8r063)             # 3
   define (PI,8r064)             # 4
   define (rho,8r162)            # r
   define (sigma,8r163)          # s
   define (SIGMA,8r123)          # S
   define (tau,8r164)            # t
   define (theta,8r150)          # h
   define (THETA,8r110)          # H
   define (xi,8r170)             # x
   define (zeta,8r172)           # z
   define (hlf,8r012)            # line feed
   define (rhlf,8r013)           # vertical tab

   define (U,8r013)
   define (D,8r012)
   define (L,8r010)
   define (R,8r040)
#-t-
#-t-  dprint                    19132  local   01/05/81  16:48:14
#-h-  join                       2162  local   01/05/81  16:48:22
#-h-  join.doc          633  local  09/24/80  13:27:25
.he 'JOIN'03/20/80'JOIN'
NAME
.sp
join - replace newlines with an arbitrary string
.sp 2
SYNOPSIS
.sp
join [ <delimiter> ] [ -l<nlines> ]
.sp 2
DESCRIPTION
.sp
'Join' reads its first standard input, replaces all newlines
with the <delimiter> string, and writes the result on its first
standard output.  The <delimiter> argument may be specified as
any arbitrary string.  If it is omitted, a single blank is assumed.
If the '-l<nlines>' construct is specified, a maximum of <nlines>
input lines will be joined into each output line.
.sp 2
EXAMPLES
.sp
.nf
files .r | join -l10 | change % "ar -u arch " | sh
file1> join "|" >file2
.fi
#-t-
#-h-  join.r         1411  local  09/24/80  13:27:25
# join --- replace newlines with string

   character line (MAXLINE), outbuf (MAXLINE),
               delim (MAXARG), arg (MAXARG)

   integer i, j, k, l, nlines
   integer getlin, getarg, ctoi


   nlines = 0
   delim (1) = ' 'c
   delim (2) = EOS

   for (i = 1; getarg (i, arg, MAXARG) ~= EOF; i = i + 1) {
      if (arg (1) == '-'c)
         if (arg (2) == 'l'c || arg (2) == 'L'c) {
            j = 3
            nlines = ctoi (arg, j)
            if (arg (j) == EOS && j > 3)
               next
            else
               nlines = 0
            }

      call scopy (arg, 1, delim, 1)
      }

   j = 1
   k = 0

   repeat {
      l = getlin (line, STDIN)
      if (l == EOF)
         break
      for (i = 1; i <= l; i = i + 1) {
         if (line (i) == NEWLINE) {
            outbuf (j) = EOS
            call putlin (outbuf, STDOUT)
            k = k + 1
            if (k >= nlines) {
               k = 0
               if (nlines ~= 0)
                  call putch (NEWLINE, STDOUT)
               else
                  call putlin (delim, STDOUT)
               }
            else
               call putlin (delim, STDOUT)
            j = 1
            }
         else {
            outbuf (j) = line (i)
            j = j + 1
            }
         }
      }
   if (j > 1) {
      outbuf (j) = EOS
      call putlin (outbuf, STDOUT)
      }
   call putch (NEWLINE, STDOUT)

   stop
   end
#-t-
#-t-  join                       2162  local   01/05/81  16:48:22
#-h-  label                     10299  local   01/05/81  22:59:27
#-h-  lablsym                    1371  local   01/05/81  22:48:53
# ----------------------------------------------------------
# This tool for producing mailing labels was written by
# Dennis Hall of Lawrence Berkeley Laboratory.  The tool
# was considered experimental and no documentation was
# ever made.  It is felt that a better tool for making labels
# should be developed, but this one is included for use until
# another version appears.
# -------------------------------------------------------------
 ## Definitions for label tool
 #  Put on a file called 'lablsym'
 #  Used only by label tool
 
 define(LLINS,1)        # number of lines on label
 define(DLINS,2)        # number of lines between labels
 define(NCOL,3)         # number of columns on label
 define(DCOL,4)         # number of columns between labels
 define(FACROSS,5)      # number of labels across page
 define(FDOWN,6)        # number of label rows per page
 define(PAUSE,10)       # number of label rows to print between pauses
 define(TMARG,7)        # top of page margin (lines)
 define(BMARG,8)        # bottom of page margin (lines)
 define(LMARG,9)        # left page margin (columns)
 define(CENTER,11)      # flag for centering of label
 define(NFORM,11)       # number of qualities in above list
 define(MAXFORM,2)      # number of defined forms
 define(MAXFILES,4)     # maximum number of input files
 define(EFORM,1)        # end of form flag
 define(CMD,2)          # signals command line
 define(MAXACC,60)      # max number of lines per label (input)
#-t-  lablsym                    1371  local   01/05/81  22:48:53
#-h-  forms                       428  local   01/05/81  22:48:54
 ## Forms common block
 #  Put on a file called 'forms'
 #  Used by the label tool
 
 common /forms/ ibuf(MAXLINE,MAXACC), obuf(MAXLINE,MAXACC),
                form(NFORM,MAXFORM), flist(MAXLINE,MAXFILES),
                fnum, nfiles
                character ibuf          # input buffer
                character obuf          # output buffer
                character flist         # file list
                integer form            # constants
                integer fnum            # form number
                integer nfiles          # number of files
#-t-  forms                       428  local   01/05/81  22:48:54
#-h-  label.r                    8104  local   01/05/81  22:59:08
 include lablsym 
 ## labl - make labels
 DRIVER(labl)
 integer int, open, getlin, i, gtlabl, cond, nl
 include forms    
  
 call setem(cond)
 for (i=1; i <= nfiles; i = i + 1)
        {
        cond = 0
        if(flist(1,i) == MINUS)
                int = STDIN
        else
                {
                int = open(flist(1,i),READ)
                if (int == ERR)
                        call cant(flist(1,i))
                }
        while (gtlabl(int,nl,cond) != EOF)
                call ptlabl(int,nl,cond)
        if (int != STDIN)
                call close(int)
        }
 call flush
 return
 end
 ## adblnk - add n leading blanks to buf
 subroutine adblnk(n,buf)
 character buf(ARB)
 integer n, i, index
  
 for (i=index(buf,NEWLINE); i >= 1; i = i - 1)
        buf(i+n) = buf(i)
 for (i=1; i <= n; i = i + 1)
        buf(i) = BLANK
 return
 end
 ## flush - flush label buffer
 subroutine flush
 integer endl, i
 include forms    
  
 endl = form(LLINS,fnum) + form(DLINS,fnum)
 for (i=1; i <= endl; i = i + 1)
        {
        call adblnk(form(LMARG,fnum),obuf(1,i))
        call reduce(obuf(1,i))
        call putlin(obuf(1,i),STDOUT)
        obuf(1,i) = NEWLINE
        obuf(2,i) = EOS
        }
 return
 end
 ## gtlabl - get next label from file
 integer function gtlabl(int,nl,cond)
 integer int, cond, nchr, nl, lintyp, getlin, junk, setarg
 include forms    
  
 gtlabl = cond
 if (cond == EOF)
        return
 for (nl = 1; nl <= form(LLINS,fnum) + 1; nl = nl + 1)
        {
        cond = getlin(ibuf(1,nl),int)
        if (cond == EOF | lintyp(ibuf(1,nl)) == EFORM)
                break
        if (lintyp(ibuf(1,nl)) == CMD)
                {
                junk = setarg(ibuf(1,nl))
                nl = nl - 1
                }
        }
 while (cond != EOF & lintyp(ibuf(1,nl)) != EFORM)
        cond = getlin(ibuf(1,nl),int)
 nl = nl - 1
 nl = min(nl,form(LLINS,fnum))
 return
 end
 ## lintyp - get line type
 integer function lintyp(str)
 character str(ARB)
  
 lintyp = 0
 if(str(1) == NEWLINE)
        lintyp = EFORM
 else if (str(1) == BACKSLASH & str(2) == NEWLINE)
        lintyp = EFORM
 else if (str(1) == MINUS)
        lintyp = CMD
 return
 end
 ## ptbody - put body of labe in obuf
 subroutine ptbody(nl,fcol,line)
 integer nl,fcol,line,maxw,endl,i,nblnk
 include forms    
  
 maxw = 0
 for(i=1; i <= nl; i=i+1)
        {
        endl = index(ibuf(1,i),BACKSLASH)
        if (endl == 0)
                endl = index(ibuf(1,i),NEWLINE)
        ibuf(endl,i) = NEWLINE
        ibuf(endl+1,i) = EOS
        if (endl > maxw)
                maxw = endl
        }
 if (maxw > form(NCOL,fnum))
        maxw = form(NCOL,fnum)
 nblnk = (form(NCOL,fnum) - maxw)/2
 if (form(CENTER,fnum) == NO)
        nblnk = 0
 for (i=1; i <= nl; i=i+1)
        {
        call adblnk(nblnk,ibuf(1,i))
        call ptline(ibuf(1,i),fcol,line + i )
        }
 line = line + i - 1
 return
 end
 ## pbotm - pad out bottom of form
 subroutine ptbotm(nl,fcol,line)
 integer nl, fcol, line, endl
 include forms    
  
 endl = form(LLINS,fnum) + form(DLINS,fnum)
 for ( line = line + 1 ; line <= endl; line = line + 1)
        call ptline(NEWLINE,fcol,line)
 return
 end
 ## pthead - put leading blanks in obuf
 subroutine pthead(nl,fcol,line)
 integer nl, fcol, line, lcol, nhed
 include forms    
  
 if (form(CENTER,fnum) == YES)
         {
         nhed = (form(LLINS,fnum) - nl)/2
         for (line = 0; line <= nhed; line = line + 1)
                call ptline(NEWLINE,fcol,line)
         }
 else
        line = 0
 return
 end
 ## ptlabl - format label and output
 subroutine ptlabl(int,nl,cond)
 integer nl, cond, fcol, frow, nxt, junk, ready
 include forms    
 data fcol/1/
 data frow/1/
  
 call pthead(nl,fcol,nxt)
 call ptbody(nl,fcol,nxt)
 call ptbotm(nl,fcol,nxt)
 if (ready(int,frow,fcol) == YES)
        {
        if(mod(frow,form(FDOWN,fnum)) == 1 | form(FDOWN,fnum) == 1)
                call spac (form(TMARG,fnum))
        call flush
        if(mod(frow,form(FDOWN,fnum)) == 0)
                call spac (form(BMARG,fnum))
        }
 fcol = fcol + 1
 if (fcol > form(FACROSS,fnum))
        {
        fcol = 1
        frow = frow + 1
        }
 return
 end
 ## ptline - put line in obuf 
 subroutine ptline(buf,fcol,line)
 character buf(ARB)
 integer  fcol, line, n0, n1, n2, i
 include forms    
 
 n0 = form(NCOL,fnum)
 n1 = n0 + form(DCOL,fnum)              # overall width
 n2 = n1*(fcol-1)                               # first column
 for (i=1; i <= n0 & buf(i) != NEWLINE; i=i+1)
        obuf(n2+i,line) = buf(i)
 for( ; i <=n1; i=i+1)
        obuf(n2+i,line) = BLANK
 obuf(n1+n2+1,line) = NEWLINE
 obuf(n1+n2+2,line) = EOS
 return
 end
 ## ready - see if ready to output form, bump counters
 integer function ready(int,frow,fcol)
 integer int, frow, fcol, tty, getlin, t, open
 integer ttyin
 character messag(32)
 string termin TERMINAL_IN
 include forms    
 
 data messag(1), messag(2), messag(3), messag(4), messag(5), messag(6),
      messag(7), messag(8), messag(9), messag(10), messag(11),
      messag(12), messag(13), messag(14), messag(15), messag(16),
      messag(17), messag(18), messag(19), messag(20), messag(21),
      messag(22), messag(23), messag(24), messag(25), messag(26),
      messag(27), messag(28), messag(29), messag(30),
      messag(31), messag(32) /BIGP, LETO, LETS, LETI,
      LETT, LETI, LETO, LETN, BLANK,
      LETL, LETA, LETB, LETE, LETL, LETS, COMMA, BLANK,
      LETT, LETH, LETE, LETN, BLANK,
      LETH, LETI, LETT, BLANK,
      LESS, BIGC, BIGR, GREATER, NEWLINE, EOS/
 
 ready = NO
 if(fcol >= form(FACROSS,fnum))
        {
        ready = YES
        if (mod(frow,form(PAUSE,fnum)) == 1 | form(PAUSE,fnum) == 1)
                {
                if(tty(STDOUT) == YES)
                        {
                        ttyin = open(termin, WRITE)
                        if (ttyin == ERR)
                                call error ("can't open terminal connection.")
                        call putlin(messag, STDOUT)
                        t = getlin(line, ttyin)
                        call close(ttyin)
                        }
                }
        }
 return
 end
 ## reduce - remove trailing blanks
 subroutine reduce(buf)
 character buf(ARB)
 integer i, index
  
 for (i=index(buf,NEWLINE)-1; i>0; i = i - 1)
        if(buf(i) != BLANK)
                break
 buf(i+1) = NEWLINE
 buf(i+2) = EOS
 return
 end
 ## setarg - install command arguments
 integer function setarg(str)
 character str(ARB)
 integer i, ctoi
 include forms    
  
 setarg = OK
 i = 4
 if(str(2) == LETL & str(3) == LETM)
        form(LMARG,fnum) = ctoi(str,i)
 else if(str(2) == LETH & str(3) == LETS)
        form(DCOL,fnum) = ctoi(str,i)
 else if(str(2) == LETW & str(3) == LETD)
        form(NCOL,fnum) = max(1,ctoi(str,i))
 else if(str(2) == LETT & str(3) == LETM)
        form(TMARG,fnum) = ctoi(str,i)
 else if(str(2) == LETB & str(3) == LETM)
        form(BMARG,fnum) = ctoi(str,i)
 else if(str(2) == LETN & str(3) == LETD)
        form(FDOWN,fnum) = max(1,ctoi(str,i))
 else if(str(2) == LETV & str(3) == LETS)
        form(DLINS,fnum) = ctoi(str,i)
 else if(str(2) == LETH & str(3) == LETT)
        {
        form(LLINS,fnum) = max(1,ctoi(str,i))
        if (form(LLINS,fnum) > MAXACC)
                call error ('too many lines per label.')
        }
 else if(str(2) == LETN & str(3) == LETA)
        form(FACROSS,fnum) = max(1,ctoi(str,i))
 else if (str(2) == LETC & str(3) == LETE)
        form(CENTER,fnum) = YES
 else if (str(2) == LETN & str(3) == LETC)
        form(CENTER,fnum) = NO
 else if(str(2) == LETS)
        form(PAUSE,fnum) = max(1,ctoi(str,3))
 else if(str(2) == LETF)
        fnum = max(1,ctoi(str,3))
 else
        setarg = ERR
 return
 end
## setem - get arguments and file list
 subroutine setem(cond)
 character abuf(MAXLINE)
 integer i, j, getarg, n, ctoi, cond
 integer setarg
 include forms    
 data fnum/1/
  
 data form(1,1)/8/      #standard form 1
 data form(2,1)/1/
 data form(3,1)/39/
 data form(4,1)/0/
 data form(5,1)/1/
 data form(6,1)/10000/
 data form(7,1)/0/
 data form(8,1)/0/
 data form(9,1)/0/
 data form(10,1)/10000000/
 data form(11,1)/NO/
  
 data form(1,2)/8/      # standard form 2
 data form(2,2)/1/
 data form(3,2)/35/
 data form(4,2)/0/
 data form(5,2)/2/
 data form(6,2)/1/
 data form(7,2)/5/
 data form(8,2)/5/
 data form(9,2)/10/
 data form(10,2)/10/
 data form(11,2)/NO/
 
 call query ("usage: label [-s -f -LMn -HSn -WDn -TMn -BMn -NDn -VSn _
        -HTn -NAn -CEn -NCn] [file].")
 cond = 0
 nfiles = 0
 for (i=1; getarg(i,abuf,MAXLINE) != EOF; i = i + 1)
    {
    call fold (abuf)
    if (abuf(1) == QMARK & abuf(2) == EOS)
                call error('usage:  label [file].')
    if (abuf(1) == MINUS & abuf(2) != EOS)
        {
        if (setarg(abuf) == ERR)
                call error ('invalid flag.')
        }
     else
        {
        nfiles = nfiles + 1
        if (nfiles > MAXFILES)
                call error('too many file arguments.')
        call scopy(abuf,1,flist(1,nfiles),1)
        }
     }
 if(nfiles == 0)
     {
     nfiles = 1
     flist(1,nfiles) = MINUS
     flist(2,nfiles) = EOS
     }
 return
 end
 ## spac  - space n lines
 subroutine spac (n)
 integer n, i
  
 for (i = 1; i <= n; i = i + 1)
        call putc(NEWLINE)
 return
 end
#-t-  label.r                    8104  local   01/05/81  22:59:08
#-t-  label                     10299  local   01/05/81  22:59:27
#-h-  mail                      16031  local   01/05/81  16:48:23
#-h-  mail.doc         2448  local  09/24/80  12:55:21
.bp 1
.in 0
.he 'MAIL (3)'1/11/79'MAIL (3)'
.fo //-#-/
.in 3
.ti -3
NAME

mail
- software tools mail facility

.ti -3
SYNOPSIS

mail [+r] [+e] [+lmlist] [addressee ... | all]

.ti -3
DESCRIPTION

Mail
is a tool designed to allow the user to send and receive mail to
fellow users of any system which supports the software tools shell.  It
operates in two modes:

.in +5
.rm -2
.ti -3
1. Sending mail to other users; the addressees specified in
the command line and in any mailing list files specified are
validated.  If there were any valid users, the standard input is
read up to an end-of-file and then mailed to each valid user with
an appropriate postmark. (Note: if one wishes to terminate the mail
session without sending any mail, type a line consisting of only
the letter
q
[for quit] during the input of mail.)
Mailing list files are specified with
the
+l
switch in the command line.  The structure of the mailing
list files is described below.  The
+r
switch indicates to
mail
that the user wishes to be notified as the mail is posted to each
addressee ('posted' implying that the mail has been appended successfully to the
addressee's mail file).
The
+e
flag will cause the editor "ed" to be invoked, allowing the user
to perform complex mail composition.
.sp
.ti -3
2. Reading one's own mail; if no addressees have been specified in
the command line (explicitly or via mailing lists), then the
current mail is printed 22 lines at a time.
At the end of the file, the user is prompted concerning
saving of the mail after it has been displayed.
.sp
.in -5
.rm +2
The mailing list files have a very simple structure: user names
separated by blanks and tabs, with as many users per line as
desired.  A pound sign (#) appearing anywhere on a line indicates
the start of a comment field, and the rest of the line is ignored
by mail.  This allows the user complete flexibility in commenting
her/his mailing lists for informational purposes.
.sp
Broadcast mailings are supported, also.  One must merely specify
all
as an addressee in the command line.
.sp
.ti -3
FILES
.sp
mymail
- file for storage of each users mail
.br
mbox
- file for storage of new incoming mail
.br
three temporary files are used by mail
("mt1", "mt2", "mts")
.sp
.ti -3
SEE ALSO
.sp
.br
postmn
- a program which notifies user of existence of mail
.br
The Unix command 'mail'
.sp
.ti -3
AUTHOR
.sp
Joe Sventek (Lawrence Berkeley Laboratory)
.sp
.ti -3
BUGS/DEFICIENCIES
.br
#-t-
#-h-  mailid.doc          772  local  09/24/80  12:55:21
.bp 1
.in 0
.he 'MAILID'7/29/80'MAILID'
.fo ''-#-''
.fi
.in 7
.ti -7
NAME
.br
mailid - pick up name and home directory of current user
.sp 1
.ti -7
SYNOPSIS
.br
.nf
call mailid (user, dir)
.sp
character user(ARB), dir(ARB)
.fi
.sp 1
.ti -7
DESCRIPTION
.br
Mailid is used by the "mail" tool to pick up the name of the
current user and the directory in which the tool should
search for mail files.
.sp
.ti -7
IMPLEMENTATION
.br
You'll have to rummage through your system manuals to find
a way to pick up the name/ID of the current user.
If you can't pick up the name of a home directory from the
system, you can search for it in the address file, which is
used by mail to locate the address to which to send mail.
.sp 1
.ti -7
SEE ALSO
.br
.sp 1
.ti -7
DIAGNOSTICS
.br
None
#-t-
#-h-  mailsym          564  local  09/24/80  12:55:21
# symbol definitions used by:   mail,   postmn,   users
# should be placed on a file named     mailsym
#
#         Set the following definitions to the appropriate locations:
#              define(ADDRESS_FILE,"name of your mail address file")
#              define(EDITOR,"name and location of your editor")
#
#           Also, define TIMEZONE to the appropriate one

 define(ADDRESS_FILE,"address")
 define(EDITOR,"ed")
 define(TIMEZONE,"Pacific time")

 define(UNKNOWN,-1)
 define(RIGHTMARGIN,70)
 define(USERSIZE,40)
 define(TERMEOF,"^Z")
 define(PAGESIZE,22)
#-t-
#-h-  cmail          445  local  09/24/80  12:55:22
# common block used by:  mail
# should be placed on a file named     cmail
#
 common / cmail /  nusers, regist, edit, temp1(FILENAMESIZE),
                   temp2(FILENAMESIZE)

 integer nusers         #  number of validated users to send mail to
 integer regist         #  whether mail is registered or not
 integer edit           #  whether to invoke editor to generate mail to send
 character temp1        #  name of mail temporary file
 character temp2        #  name of mail temporary file
#-t-
#-h-  mail          979  local  09/24/80  12:55:22
 DRIVER(mail)

 include mailsym

 character arg(FILENAMESIZE), buf(MAXLINE), file(FILENAMESIZE)
 integer i, int, n, junk
 integer getarg, equal, open, getlin, index, getwrd

 include cmail

 string all "all"
 string flags "+-?"

 call malint(arg, file, buf)
 for (i=1; getarg(i, arg, FILENAMESIZE) != EOF; i=i+1)
    {
    call fold(arg)
    if (equal(arg, all) == YES)
        {
        call adrfil(file)
        int = open(file, READ)
        if (int != ERR)
            {
            while (getlin(buf, int) != EOF)
                {
                n = 1
                junk = getwrd(buf, n, arg)
                if (junk > 0)
                    call addusr(arg, buf)
                }
            call close(int)
            }
        }
    else if (index(flags, arg(1)) > 0)
        call malcmd(arg, file, buf)
    else
        call addusr(arg, buf)
    }
 if (nusers != 0)
    call sdmail(buf, arg, file)

 if (i == 1)        #read mail
        call rmail
 DRETURN
 end
#-t-
#-h-  addusr          758  local  09/24/80  12:55:22
 #      addusr -- subroutine to add user to stack of users for mail

 subroutine addusr(arg, temp)

 character arg(USERSIZE), temp(FILENAMESIZE)
 integer int, init
 integer create, lookup

 include cmail

 string t1 "mt1"
 string t2 "mt2"
 string inval "invalid user name: "

 data init /YES/

 if (init == YES)
    {
    call mkuniq(t1, temp1)
    call mkuniq(t2, temp2)
    int = create(temp1, WRITE)
    if (int == ERR)
        call merror(temp1)
    init = NO
    }
 if (arg(1) == EOS)
    call close(int)
 else if (lookup(arg, temp) == YES)
    {
    nusers = nusers + 1
    call putlin(arg, int)
    call putch(NEWLINE, int)
    }
 else
    {
    call putlin(inval, ERROUT)
    call putlin(arg, ERROUT); call putch(NEWLINE, ERROUT)
    }

 return
 end
#-t-
#-h-  adrfil          165  local  09/24/80  12:55:22
 ## adrfil - pick up name of mail address file
 subroutine adrfil (name)
 character name(ARB)

 string afil ADDRESS_FILE

 call scopy(afil, 1, name, 1)
 return
 end
#-t-
#-h-  badarg          190  local  09/24/80  12:55:22
 subroutine badarg(arg)

 character arg(ARB)
 string invald "ignoring invalid argument: "

 call putlin(invald, ERROUT)
 call putlin(arg, ERROUT);  call putch(NEWLINE, ERROUT)

 return
 end
#-t-
#-h-  cleanf           94  local  09/24/80  12:55:22
 subroutine cleanf

 include cmail

 call remove(temp1)
 call remove(temp2)
 call endst

 end
#-t-
#-h-  dotost          722  local  09/24/80  12:55:23
 subroutine dotost(out, user)

 integer out, in, i, j, n
 integer open, length, getlin
 character user(USERSIZE)

 include cmail

 string tos "To:     "
 string bls "        "

 in = open(temp1, READ)
 if (in == ERR)
    call merror(temp1)
 call putlin(tos, out)
 j = 9
 for (i=getlin(user,in); i !=  EOF; i=getlin(user,in))
    {
    user(i) = EOS
    n = j + length(user) + 1
    if (n > RIGHTMARGIN)
        {
        call putch(COMMA, out)
        call putch(NEWLINE, out)
        call putlin(bls, out)
        j = 9
        }
    if (j > 9)
        call putch(COMMA, out)
    call putch(BLANK, out)
    call putlin(user, out)
    j = j + length(user) + 2
    }
 call putch(NEWLINE, out)
 call close(in)

 return
 end
#-t-
#-h-  editit          327  local  09/24/80  12:55:23
 subroutine editit(file, buf)

 character file(FILENAMESIZE), buf(ARB), proc(FILENAMESIZE)
 integer i, spawn, open

 string ed EDITOR

 i = open(ed, READ)
 if (i == ERR)
    call error("Cannot locate ed image file.")
 call close(i)
 if (spawn(proc, file, buf, WAIT) != OK)
    call error("error in spawning ed.")

 return
 end
#-t-
#-h-  fsize          347  local  09/24/80  12:55:23
 ## 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
#-t-
#-h-  gsbjct          291  local  09/24/80  12:55:23
 subroutine gsbjct(buf)

 character buf(MAXLINE)
 integer n
 integer isatty, prompt

 string subjct "Subject: "

 if (isatty(STDIN) == YES)
    {
    n = prompt(subjct, buf, STDIN)
    if (n >= 1)
        buf(n) = EOS
    else
        buf(1) = EOS
    }
 else
    buf(1) = EOS

 return
 end
#-t-
#-h-  malcmd         1300  local  09/24/80  12:55:24
 #-----------------------------------------------------------
 ##     malcmd -- interprets command switches for mail

 subroutine malcmd(iarg, out, buf)

 character iarg(FILENAMESIZE), mllist(FILENAMESIZE), out(FILENAMESIZE),
           buf(MAXLINE)
 integer i, int, open, getlin, getwrd, index

 include cmail
 string errmsg "error in opening mailing list file: "

 if (iarg(1) == PLUS & iarg(2) == LETL)
    {
    call scopy(iarg, 3, mllist, 1)
    int = open(mllist, READ)
    if (int != ERR)
        {
        while (getlin(buf, int) != EOF)
            {
            i = index(buf, SHARP)       # pound sign signals start of comment
            if (i > 0)
                buf(i) = EOS            # terminate scan for users there
            i = 1
            while (getwrd(buf, i, out) > 0)
                call addusr(out, iarg)
            }
        call close(int)
        }
    else
        {
        call putlin(errmsg, ERROUT)
        call putlin(mllist, ERROUT);  call putch(NEWLINE, ERROUT)
        }
    }
 else if (iarg(1) == PLUS & iarg(2) == LETR)
    regist = YES
 else if (iarg(1) == QMARK & iarg(2) == EOS)
    call error("usage:  mail [+lmlist] [+r] [+e] [all] [addressees ].")
 else if (iarg(1) == PLUS & iarg(2) == LETE)
    edit = YES
 else
    call badarg(iarg)
 return
 end
#-t-
#-h-  malinp         1289  local  09/24/80  12:55:24
 subroutine malinp(temp, file, buf, edit)

 integer edit, int, open, isatty, create, getlin, inp, fsize, prompt
 character file(FILENAMESIZE), buf(MAXLINE), clower, temp(FILENAMESIZE)

 string mts "mts"
 string msg "Input message: (q to quit or "

 int = create(temp, WRITE)
 if (int == ERR)
    call merror(temp)
 call gsbjct(buf)
 call pstmrk(int, buf)
 inp = STDIN
 if (isatty(STDIN) == YES)
    {
    if (edit == YES)
        {
        call mkuniq(mts, file)
        call remark("You are now entering ed to create your mail.")
        call remark("Please wait for ed to respond with 0.")
        call editit(file, buf)
        inp = open(file, READ)
        if (inp == ERR | fsize(file) == 0)
            {
            call close(inp)
            call remove(file)
            call close(int)
            call cleanf
            }
        }
    else
        {
        call putlin(msg, ERROUT)
        call putlin(TERMEOF, ERROUT)
        call remark(" to send).")
        }
    }
 while (getlin(buf, inp) != EOF)
    if (clower(buf(1)) == LETQ & buf(2) == NEWLINE & edit == NO)
        {
        call close(int)
        call cleanf
        }
    else
        call putlin(buf, int)
 call close(int)
 if (inp != STDIN)
    {
    call close(inp)
    call remove(file)
    }

 return
 end
#-t-
#-h-  malint          549  local  09/24/80  12:55:24
 subroutine malint(arg, file, buf)

 character arg(FILENAMESIZE), file(FILENAMESIZE), buf(MAXLINE)
 integer int, i, junk
 integer open, getlin, getwrd

 include cmail

 nusers = 0
 regist = NO
 edit = NO
 call adrfil(file)
 call tbinit
 int = open(file, READ)
 if (int != ERR)
    {
    while (getlin(buf, int) != EOF)
        {
        i = 1
        junk = getwrd(buf, i, arg)
        junk = getwrd(buf, i, file)
        call instal(arg, file)
        }
    call close(int)
    }
 else
    call error("Cannot open local users file.")

 return
 end
#-t-
#-h-  merror          202  local  09/24/80  12:55:24
 subroutine merror(buf)

 character buf(ARB)
 string msg "cannot open mail temporary file: "

 call putlin(msg, ERROUT)
 call putlin(buf, ERROUT)
 call putch(NEWLINE, ERROUT)
 call cleanf

 return
 end
#-t-
#-h-  pstmrk          815  local  09/24/80  12:55:25
 subroutine pstmrk(int, subjct)

 character idate(10), itime(10), user(USERSIZE), cupper, dummy(FILENAMESIZE)
 character hdrpat(4), subjct(ARB)
 integer int

 string dates "Date:    "
 string dashst " - "
 string timzon TIMEZONE
 string froms "From:    "
 string subjs "Subject: "

 data hdrpat/1, 1, NEWLINE, EOS/

 call mailid(user, dummy)
 user(1) = cupper(user(1))
  call gdate(idate, itime)
 call putlin(hdrpat, int)
 call putlin(dates, int)
 call putlin(idate, int)
 call putch(BLANK, int)
 call putlin(itime, int)
 call putlin(dashst, int)
 call putlin(timzon, int)
 call putch(NEWLINE, int)
 call putlin(froms, int)
 call putlin(user, int)
 call putch(NEWLINE, int)
 call putlin(subjs, int)
 call putlin(subjct, int)
 call putch(NEWLINE, int)
 call dotost(int, user)
 call putch(NEWLINE, int)

 return
 end
#-t-
#-h-  rmail         1388  local  09/24/80  12:55:25
 ## rmail - read mail

 subroutine rmail
 integer fd, open, getlin, fd2
 integer j, length
 character buf(MAXLINE)
 character oldm(FILENAMESIZE), newm(FILENAMESIZE)

 string mbox "mbox"             #where mail is stored
 string mymail "mymail"         #where mail has arrived
 string more "more? "
 string save "Save your mail? "

 call mailid (buf, newm)
 j = length(newm)
 call scopy(mymail, 1, newm, j+1)
 fd = open(newm, READ)
 if (fd == ERR)
        return
 for (i=1; getlin(buf, fd) != EOF; i=i+1)
        {
        call putlin(buf, STDOUT)
        if (i == PAGESIZE)
                {
                call prompt(more, buf, STDIN)
                if (buf(1) == LETN | buf(1) == BIGN |
                    buf(1) == LETQ | buf(1) == BIGQ )
                        return
                i = 0
                }
        }
 call prompt (save, buf, STDIN)
 if (buf(1) != LETN & buf(1) != BIGN)
        {
        call mailid(buf, oldm)
        j = length(oldm)
        call scopy(mbox, 1, oldm, j+1)
        fd2 = open(oldm, APPEND)
        if (fd2 == ERR)
                {
                call remark ("can't open mbox.")
                return
                }
        call close(fd)
        fd = open(newm, READ)
        while (getlin(buf, fd) != EOF)
                call putlin(buf, fd2)
        call close (fd)
        call close (fd2)
        }
 call remove(newm)
 return
 end
#-t-
#-h-  sdmail         1224  local  09/24/80  12:55:25
 subroutine sdmail(buf, file, user)

 character buf(MAXLINE), file(FILENAMESIZE), user(FILENAMESIZE)
 integer inp, int, n, junk, out
 integer open, getlin, lookup, create
# linepointer topfil
 integer topfil(2)

 include cmail

 string mymail "mymail"
 string msg "cannot send mail to "
 string pmail "mail posted to "

 call addusr(EOS)
 call malinp(temp2, file, buf, edit)
 inp = open(temp2, READ)
 if (inp == ERR)
    call merror(temp2)
 call markl(inp, topfil)
 int = open(temp1, READ)
 if (int ==  ERR)
    {
    call close(inp)
    call merror(temp1)
    }
 for (n=getlin(buf,int); n != EOF; n=getlin(buf,int))
    {
    buf(n) = EOS
    junk = lookup(buf, file)
    call concat(file, mymail, file)
    call seek(topfil, inp)
    out = create(file, APPEND)
    if (out == ERR)
        {
        call putlin(msg, ERROUT)
        call putlin(buf, ERROUT)
        call putch(NEWLINE, ERROUT)
        }
    else
        {
        call fcopy(inp, out)
        call close(out)
        if (regist == YES)
            {
            call putlin(pmail, ERROUT)
            call putlin(buf, ERROUT)
            call putch(NEWLINE, ERROUT)
            }
        }
    }
 call close(int)
 call close(inp)
 call cleanf
 return
 end
#-t-
#-t-  mail                      16031  local   01/05/81  16:48:23
#-h-  man                         829  local   01/05/81  16:48:29
#-h-  man.doc          660  local  09/24/80  12:57:42
.bp 1
.in 0
.he 'MAN (3)'1/11/79/'MAN (3)'
.fo ''-#-'
.fi
NAME
.br
.in 7
man - run off section of users manual
.sp 1
.in
SYNOPSIS
.br
.in 7
man
toolname
.sp 1
.in
DESCRIPTION
.br
.in 7
Man
is a command script file which locates and prints a section of the
users manual describing the use of a particular tool.
.sp 1
.in
FILES
.br
.in 7
Accesses the file containing user documents.
.sp 1
.in
SEE ALSO
.br
.in 7
The tool 'help'; the Unix command 'man'
.sp 1
.in
DIAGNOSTICS
.br
.in 7
A message is printed if the tool specified by 'toolname' cannot be
located.
.sp 1
.in
AUTHORS
.br
.in 7
.sp 1
Dennis Hall (Lawrence Berkeley Laboratory)
.sp 1
.in
BUGS
.br
.in 7
#-t-
#-h-  man           55  local  09/24/80  12:57:42
ar p manual $1 $2 $3 $4 $5 $6 $7 $8 $9 | format | page
#-t-
#-t-  man                         829  local   01/05/81  16:48:29
#-h-  os                         6132  local   01/05/81  16:48:30
#-h-  os.doc          952  local  09/24/80  13:32:38
.he 'OS'03/20/80'OS'
NAME
.sp
os - convert backspaces to line printer overstrikes
.sp 2
SYNOPSIS
.sp
os [ -<page_length> ]
.sp 2
DESCRIPTION
.sp
'Os' is a filter that may be used to convert backspaces
(such as those produced by the formatter for underlining
and boldfacing) into standard Fortran line printer carriage
control codes.
.sp
If the output of 'os' is spooled, the Fortran forms control
mode must be in effect.
Use of the "f" option on the 'sp' command (e.g. "os | sp / f") or the
"f" option in the line printer spooler's pathname (e.g.
"os >/dev/lps/f") will enable Fortran forms control.
.sp
'Os' will generate a page-eject at the bottom of each page
(to keep the pages correct in case of a paper jam).  The
<page_length> is the number of lines per output page.  If
<page_length> is omitted, 'os' assumes 66 (standard paper).
.sp 2
EXAMPLES
.sp
.nf
fmt report | os | sp / f
junk> os >/dev/lps/f/bjunk
.fi
.sp 2
SEE ALSO
.sp
sp (1), fos (1)
#-t-
#-h-  os.r         5069  local  09/24/80  13:32:39
# os --- convert text with backspaces to line printer spacing

   define (DEFAULT_PAGE_SIZE,66)
   define (MAXLINE,134)
   define (MAXLINE2,268)   # MAXLINE * 2
   define (MAXLINE3,402)   # MAXLINE * 3
   define (MAXLINE4,536)   # MAXLINE * 4
   define (MAXLINE5,670)   # MAXLINE * 5
   define (MAXLINE6,804)   # MAXLINE * 6

   character c, arg (MAXARG), ibuf (MAXLINE), obuf (MAXLINE6)
   integer i, j, ibp, obp, newlines, overprint, topbuf,
         page_size, line_ctr
   integer ctoi, getarg, getlin

   procedure dump_buffer forward
   procedure trim_buffer (offset) forward
   procedure clear_buffer (offset) forward

   if (getarg (1, arg, MAXARG) == EOF || arg (1) ~= '-'c)
      page_size = DEFAULT_PAGE_SIZE
   else {
      i = 2
      page_size = ctoi (arg, i)
      if (arg (i) ~= EOS)
         call error ("usage: os [-<page length>]"p)
      }

   line_ctr = page_size
   newlines = 1
   overprint = NO
   topbuf = 0
   ibp = 0
   ibuf (1) = EOS
   do i = 1, MAXLINE6
      obuf (i) = ' 'c

   repeat {    # for each logical input line
      obp = 0
      repeat {    # for each character in that line
         ibp += 1
         c = ibuf (ibp)
         while (c == EOS) {   # end of string, but not end of line
            if (getlin (ibuf, STDIN, MAXLINE) == EOF)
               break 3
            ibp = 1
            c = ibuf (1)
            }
         select (or (c, NUL))
            when (NEWLINE)       # end of line reached
               break
            when (FF) {
               dump_buffer
               line_ctr = page_size
               }
            when (BS)
               obp -= 1
            when (' 'c)
               obp += 1
         else {
            obp += 1
            if (0 < obp && obp < MAXLINE) {
               select
                  when (obuf (obp) == ' 'c) {
                     obuf (obp) = c
                     i = 1
                     }
                  when (obuf (obp + MAXLINE) == ' 'c) {
                     obuf (obp + MAXLINE) = c
                     i = 2
                     }
                  when (obuf (obp + MAXLINE2) == ' 'c) {
                     obuf (obp + MAXLINE2) = c
                     i = 3
                     }
                  when (obuf (obp + MAXLINE3) == ' 'c) {
                     obuf (obp + MAXLINE3) = c
                     i = 4
                     }
                  when (obuf (obp + MAXLINE4) == ' 'c) {
                     obuf (obp + MAXLINE4) = c
                     i = 5
                     }
                  when (obuf (obp + MAXLINE5) == ' 'c) {
                     obuf (obp + MAXLINE5) = c
                     i = 6
                     }
               ifany {
                  if (topbuf < i)
                     topbuf = i
                  }
               else {
                  dump_buffer
                  overprint = YES
                  obuf (obp) = c
                  topbuf = 1
                  }
               }
            }
         }
      dump_buffer
      }

   stop



# dump_buffer --- output buffers to STDOUT and clear

   procedure dump_buffer {

      local i, j, k
      integer i, j, k

      trim_buffer (0)

      if (overprint == NO) {           # starting a new line
         line_ctr += 1
         if (line_ctr > page_size) {
            if (newlines > 0) {        # at least 1 blank line at bottom
               call putch ('1'c, STDOUT)
               call putch (NEWLINE, STDOUT)
               newlines = 0
               overprint = YES         # so next line is 1st on page
               }
            # else we're already at top of page
            line_ctr = 1
            }
         if (obuf (1) == NEWLINE)      # outputting a blank line
            newlines += 1
         }

      if (obuf (1) ~= NEWLINE) {       # a non-blank line to print
         for ( ; newlines > 0; newlines -= 1) {
            call putch (' 'c, STDOUT)  # dump outstanding blank lines
            call putch (NEWLINE, STDOUT)
            }
         if (overprint == NO)
            call putch (' 'c, STDOUT)
         else
            call putch ('+'c, STDOUT)
         call putlin (obuf, STDOUT)    # write first buffer segment
         for ({i = 1; k = MAXLINE}; i < topbuf;
               {i += 1; k += MAXLINE}) {
            trim_buffer (k)
            call putch ('+'c, STDOUT)
            call putlin (obuf (k + 1), STDOUT)
            clear_buffer (k)
            }
         }
      clear_buffer (0)
      topbuf = 0
      overprint = NO

      }



# trim_buffer --- strip trailing blanks and terminate a buffer

   procedure trim_buffer (offset) {
   integer offset

      local i
      integer i

      for (i = offset + MAXLINE - 2; i > offset; i -= 1)
         if (obuf (i) ~= ' 'c)
            break
      obuf (i + 1) = NEWLINE
      obuf (i + 2) = EOS

      }



# clear_buffer --- clear buffer to all blanks

   procedure clear_buffer (offset) {
   integer offset

      local i
      integer i

      for (i = offset + MAXLINE; i > offset; i -= 1)
         obuf (i) = ' 'c

      }


   end
#-t-
#-t-  os                         6132  local   01/05/81  16:48:30
#-h-  pad                         813  local   01/05/81  16:53:36
# from the University of Arizona
#include ratdef
define(MAXSIZE,10)
# pad - writes fixed-length lines to standard output
   character c, getc, size(MAXSIZE)
   integer n, len, getarg, ctoi

   len = 80     # default
   if (getarg(1, size, MAXSIZE) ^= EOF) {
      n = 1
      len = ctoi(size, n)
      if (len <= 0 | size(n) ^= EOS)
         call error("usage: pad [n].")
      }
   n = 0
   while (getc(c) ^= EOF)
      if (c == NEWLINE) {          # pad to line length
         for (; n < len; n = n + 1)
            call putc(BLANK)
         call putc(NEWLINE)
         n = 0
         }
      else {
         if (n < len)
            call putc(c)
         n = n + 1
         }
   if (n > 0) {
      for (; n <= len; n = n + 1)  # pad out last line
         call putc(BLANK)
      call putc(NEWLINE)
      }
   end
#-t-  pad                         813  local   01/05/81  16:53:36
#-h-  pg                         3364  local   01/05/81  16:48:32
#-h-  pg.doc         2045  local  09/24/80  13:38:46
.he 'PG'05/07/80'PG'
NAME
.sp
pg - listing program for fast terminals
.sp 2
SYNOPSIS
.sp
pg { -<screensize> | -m <message> | <file_spec> }
.sp
<file_spec> ::= <filename> | -[<stdin_number>] |
.ti +16
-n(<stdin_number>|<filename>)
.sp 2
DESCRIPTION
.sp
'Pg' is a filter used to view large files on fast CRT terminals.
For each file specified (see 'gfnarg')
it fills up the screen with a block of text, then prints a prompt
and reads a one-line response from the terminal.
Depending on the response, succeeding blocks of text may be displayed
or display may be discontinued.
.sp
Since 'pg' uses the library routine 'page' to display the named files,
the following responses can be made after each block of text:
.sp
.in +15
.ti -10
n         Proceed to next file (exit if on last file).
.ti -10
q         Proceed to next file (exit if on last file).
.ti -10
ctrl-c    Proceed to next file (exit if on last file).
.ti -10
y         Advance to the next page.
.ti -10
newline   Advance to the next page.
.ti -10
l<lines>  Set screen size to specified number of lines.
.ti -10
.         Redisplay current page.
.ti -10
^         Redisplay previous page.
.ti -10
<page>    Display specified page number.
.ti -10
+<pages>  Advance given number of pages (default 1).
.ti -10
-<pages>  Back up given number of pages (default 1).
.sp
.in -15
When an entire file has been displayed, 'pg' prompts with the
string "END".
The response is interpreted as above, with the exception that
NEWLINE causes 'pg' to proceed to the next file in its argument list.
.sp
The <screensize> parameter is used to inform 'pg' of the number of
lines on the screen of the user's terminal.  If omitted, a default
value of 22 is used.  The string that is printed for a prompt may
be specified using the "-m <message>" argument sequence. The default
prompt is "[<page_number>] more?", which is specified by the string
"[*i] more?".
.sp 2
EXAMPLES
.sp
.nf
pg -5 file
fmt english | pg
help -i | pg -m "continue or quit? "
.fi
.sp 2
SEE ALSO
.sp
cat (1), copy (1), print (1), page (2)
#-t-
#-h-  pg.r         1206  local  09/24/80  13:38:47
# pg --- print a file page by page on a terminal


   define (SCREENSIZE,22)
   define (QUIT,0)
   define (GO_ON,1)

   character name (MAXARG), message (MAXLINE)
   integer i, lines_per_page, fd
   integer state (4)
   integer ctoi, open, pg, gfnarg, mapdn

   string usage "Usage: pg {-<screensize> | -m <message> | <pathname>}"

   state (1) = 1
   lines_per_page = SCREENSIZE
   call ctoc ("[*i] more? "s, message, MAXLINE)

   repeat
      select (gfnarg (name, state))
         when (EOF)
            break
         when (OK) {
            fd = open (name, READ)
            if (fd ~= ERR) {
               call page (fd, message, "[END] "s, lines_per_page)
               call close (fd)
               }
            else
               call print (ERROUT, "*s: can't open*n"p, name)
            }
         when (ERR) {
            if (mapdn (name (2)) == 'm'c)
               call gvlarg (message, state)
            else {
               i = 2
               lines_per_page = ctoi (name, i)
               if (name (i) ~= EOS)
                  call error (usage)
               if (lines_per_page == 0)
                  lines_per_page = SCREENSIZE
               }
            }

   stop
   end
#-t-
#-t-  pg                         3364  local   01/05/81  16:48:32
#-h-  postmn                     1045  local   01/05/81  16:48:34
#-h-  mailsym          564  local  09/24/80  12:56:20
# symbol definitions used by:   mail,   postmn,   users
# should be placed on a file named     mailsym
#
#         Set the following definitions to the appropriate locations:
#              define(ADDRESS_FILE,"name of your mail address file")
#              define(EDITOR,"name and location of your editor")
#
#           Also, define TIMEZONE to the appropriate one

 define(ADDRESS_FILE,"address")
 define(EDITOR,"ed")
 define(TIMEZONE,"Pacific time")

 define(UNKNOWN,-1)
 define(RIGHTMARGIN,70)
 define(USERSIZE,40)
 define(TERMEOF,"^Z")
 define(PAGESIZE,22)
#-t-
#-h-  postmn          364  local  09/24/80  12:56:20
 DRIVER(postmn)

 include mailsym

 character user(FILENAMESIZE), dir(FILENAMESIZE), mymail(7)
 integer i, length, fsize

 data mymail/LETM, LETY, LETM, LETA, LETI, LETL, EOS/

 call mailid(user, dir)
 i = length(dir) + 1
 call scopy(mymail, 1, dir, i)
 if (fsize(dir) > 1)
    {
    call putlin("You have mail", STDOUT)
    call putc(NEWLINE)
    }

 return
 end
#-t-
#-t-  postmn                     1045  local   01/05/81  16:48:34
#-h-  pp                         8684  local   01/05/81  16:53:37
# from the University of Arizona
common /cpp/ buf(MAXBUF), avail, infile(NFILES), level, iflvl, prlvl,
   linbuf(BUFSIZE)
   integer buf          # free storage
   integer avail        # next free slot in buf
   integer infile       # stack of file descriptors
   integer level        # current file is infile(level)
   integer iflvl        # current if nesting level
   integer prlvl        # current if sucessful if level
   integer linbuf       # holds current line
#include ratdef

define(COMMAND,SHARP)   # default command character
define(COMMENT,SHARP)   # comment character
define(BUFSIZE,300)     # line buffer size
define(NFILES,8)        # include nesting limit
define(NCHARS,128)      # number of ascii characters
define(MAXBUF,5000)     # storage array
define(ACTIVE,LETA)     # active replacement
define(PASSIVE,LETP)    # passive replacement
define(NEXT,0)          # pointer to next entry
define(NAME,1)          # start of name; definition follows
define(INCLCOM,301)     # command numbers
define(DEFCOM,302)
define(IFCOM,303)
define(IFNCOM,304)
define(ENDIFCOM,305)
define(UNKNOWN,0)

# pp - define, include and conditional preprocessor
   character arg(MAXLINE), cchar
   integer getarg, open, index
   integer i, fd, nf, j
 
   call init
   nf = 0
   cchar = COMMAND
   for (i = 1; getarg(i, arg, MAXLINE) ^= EOF; i = i + 1)
      if (arg(1) == MINUS & (arg(2) == LETU | arg(2) == BIGU) &
         arg(3) ^= EOS)
            call undef(arg(3))
      else if (arg(1) == MINUS & (arg(2) == LETD | arg(2) == BIGD) &
         arg(3) ^= EOS) {
            j = index(arg, EQUALS)
            if (j > 0) {
               arg(j) = EOS
               call instal(arg(3), arg(j+1), ACTIVE)
               }
            else
               call instal(arg(3), arg(3), PASSIVE)
            }
      else if (arg(1) == MINUS & (arg(2) == LETC | arg(2) == BIGC))
         if (arg(3) == EOS)
            cchar = COMMAND
         else
            cchar = arg(3)
      else if (arg(1) == MINUS & arg(2) ^= EOS)
         call error("usage: pp [file | -Dname[=def] | -Uname | -cx]*.")
      else {
         if (arg(1) == MINUS)
            fd = STDIN
         else
            fd = open(arg, READ)
         if (fd == ERR)
            call cant(arg)
         call dopp(fd, cchar)
         nf = nf + 1
         if (fd ^= STDIN)
            call close(fd)
         }
   if (nf == 0) # no files, do STDIN
      call dopp(STDIN, cchar)
   end
# comand - do command cmd; args begin at linbuf(i)
   subroutine comand(cmd, i)
   integer cmd, i
   character name(MAXLINE)
   integer gettok, open, lookup
   integer j, k, junk
   include cpp

   j = i
   call skipbl(linbuf, j)
   for (k = j; linbuf(k) ^= EOS & linbuf(k) ^= NEWLINE &
        linbuf(k) ^= COMMENT; k = k + 1)        # find end
           ;
   for (; k > j; k = k - 1)             # trim blanks
      if (linbuf(k-1) ^= BLANK & linbuf(k-1) ^= TAB)
         break
   linbuf(k) = EOS
   if (cmd == INCLCOM) {                # include file
      if (prlvl < iflvl)
         return
      if (level + 1 > NFILES)
         call error("includes nested too deeply.")
      infile(level+1) = open(linbuf(j), READ)
      if (infile(level+1) == ERR) {
         call putlin(linbuf(j), ERROUT)
         call remark(": can't include.")
         }
      else
         level = level + 1
      }
   else if (cmd == DEFCOM) {            # define name value
      if (prlvl < iflvl)
         return
      if (gettok(linbuf, j, name) ^= ALPHA)
         call error("non-alphanumeric name.")
      call skipbl(linbuf, j)
      call instal(name, linbuf(j), ACTIVE)
      }
   else if (cmd == IFCOM) {             # ifdef name
      if (prlvl >= iflvl & lookup(linbuf(j), name, junk) == YES)
         prlvl = prlvl + 1
      iflvl = iflvl + 1
      }
   else if (cmd == IFNCOM) {            # ifndef name
      if (prlvl >= iflvl & lookup(linbuf(j), name, junk) == NO)
         prlvl = prlvl + 1
      iflvl = iflvl + 1
      }
   else if (cmd == ENDIFCOM) {          # endif
      if (iflvl > 0) {
         iflvl = iflvl - 1
         if (prlvl > iflvl)
            prlvl = prlvl - 1
         }
      }
   else
      call error("comand: can't happen.")
   return
   end
# comtyp - determine type of command in cmd
   integer function comtyp(cmd)
   character cmd(MAXLINE)
   integer equal
   string incl "include"
   string def "define"
   string ifdef "ifdef"
   string ifndef "ifndef"
   string endif "endif"

   if (equal(cmd, incl) == YES)
      comtyp = INCLCOM
   else if (equal(cmd, def) == YES)
      comtyp = DEFCOM
   else if (equal(cmd, ifdef) == YES)
      comtyp = IFCOM
   else if (equal(cmd, ifndef) == YES)
      comtyp = IFNCOM
   else if (equal(cmd, endif) == YES)
      comtyp = ENDIFCOM
   else
      comtyp = UNKNOWN
   return
   end
# dopp - preprocess file fd using command character cchar
   subroutine dopp(fd, cchar)
   integer fd
   character cchar, cmd(MAXLINE)
   integer getlin, getwrd, comtyp
   integer i, c, junk
   include cpp
 
   infile(1) = fd
   for (level = 1; level > 0; level = level - 1) {
      while (getlin(linbuf(BUFSIZE-MAXLINE), infile(level)) ^= EOF)
         if (linbuf(BUFSIZE-MAXLINE) == cchar) {   # it's a command
            i = BUFSIZE-MAXLINE + 1
            junk = getwrd(linbuf, i, cmd)
            c = comtyp(cmd)
            if (c ^= UNKNOWN)
               call comand(c, i)
            else
               call text(BUFSIZE-MAXLINE)
            }
         else
            call text(BUFSIZE-MAXLINE)
      if (level > 1)
         call close(infile(level))
      }
   return
   end
# gettok - get next token in lin, increment i
   character function gettok(lin, i, token)
   character lin(MAXLINE), token(MAXLINE)
   integer i
   character type
   integer j, t
   include cpp
 
   j = 1
   while (type(lin(i)) ^= LETTER & lin(i) ^= EOS) {
      token(j) = lin(i)
      i = i + 1
      j = j + 1
      }
   if (j > 1) {         # non-alphanumeric token
      token(j) = EOS
      return(token(1))
      }
   for (t = type(lin(i)); t ^= EOS; t = type(lin(i))) {
      if (t ^= LETTER & t ^= DIGIT & t ^= UNDERLINE & t ^= PERIOD)
         break
      token(j) = lin(i)
      i = i + 1
      j = j + 1
      }
   token(j) = EOS
   if (j > 1)
      return(ALPHA)
   return(EOF)
   end
# init - initialization
   subroutine init
   include cpp

   for (avail = 1; avail <= NCHARS; avail = avail + 1) # set up hash table
      buf(avail) = 0
   iflvl = 0            # set if levels
   prlvl = 0
   return
   end
# instal - install name and defn into table
   subroutine instal(name, defn, flag)
   character name(MAXLINE), defn(MAXLINE)
   integer flag
   integer length, min
   integer dlen, nlen, i
   include cpp
 
   nlen = length(name) + 1
   dlen = length(defn) + 1 + 1  # 1 for flag
   if (avail + nlen + dlen + NAME > MAXBUF) {
      call putlin(name, ERROUT)
      call remark(": too many definitions.")
      return
      }
   i = min(NCHARS, name(1))
   buf(avail+NEXT) = buf(i+1)
   buf(i+1) = avail
   call scopy(name, 1, buf, avail + NAME)
   buf(avail+NAME+nlen) = flag
   call scopy(defn, 1, buf, avail + NAME + nlen + 1)
   avail = avail + NAME + nlen + dlen
   return
   end
# lookup - lookup name, return defn, active/passive flag, and YES/NO
   integer function lookup(name, defn, flag)
   character name(MAXLINE), defn(MAXLINE)
   integer flag
   integer i
   integer equal, length, min
   include cpp

   i = min(NCHARS, name(1))
   for (i = buf(i+1); i > 0; i = buf(i+NEXT))
      if (equal(name, buf(i+NAME)) == YES) {    # got it
         i = i + NAME + length(buf(i+NAME)) + 1
         flag = buf(i)
         call scopy(buf, i + 1, defn, 1)
         return(YES)
         }
   return(NO)
   end
# text - process text in linbuf starting at linbuf(i)
   subroutine text(i)
   integer i
   integer gettok, lookup
   character t, token(MAXLINE), defn(MAXLINE)
   integer j, bp, flag
   include cpp

   if (prlvl < iflvl)
      return
   bp = i
   for (t = gettok(linbuf, bp, token); t ^= EOF; t = gettok(linbuf, bp, token)) 
      if (t ^= ALPHA)
         call putlin(token, STDOUT)
      else if (lookup(token, defn, flag) == NO)
         call putlin(token, STDOUT)
      else if (flag == PASSIVE)
         call putlin(defn, STDOUT)
      else      # push definition back on linbuf
         for (j = length(defn); j > 0; j = j - 1) {
            bp = bp - 1
            if (bp <= 0)
               call error("too many characters pushed back.")
            linbuf(bp) = defn(j)
            }
   return
   end
# undef - undefine name
   subroutine undef(name)
   character name(MAXLINE)
   integer i, j
   integer equal, min
   include cpp

   j = min(NCHARS, name(1)) + 1
   for (i = buf(j); i > 0; i = buf(i+NEXT))
      if (equal(name, buf(i+NAME)) == YES)      # got it
         buf(j) = buf(i+NEXT)   # drop out of list
      else
         j = i + NEXT
   return
   end
#-t-  pp                         8684  local   01/05/81  16:53:37
#-h-  rsa                        7957  local   01/05/81  16:48:38
#-h-  rsa.doc         2270  local  09/24/80  13:44:49
.he 'RSA'03/23/80'RSA'
NAME
.sp
rsa - toy RSA public-key cryptosystem
.sp 2
SYNOPSIS
.sp
rsa (-i | -e <correspondent> | -d)
.sp 2
DESCRIPTION
.sp
'Rsa' is a simplified implementation of an RSA (Rivest-Shamir-Adleman)
public-key cryptosystem.
While interesting as a novelty, it does not provide sufficient
security to resist an informed attack.
.sp
'Rsa' has three options.
The "-i" (initialize) option must be selected by a user before any
other users can send him encrypted information.
The "-e correspondent" (encipher) option is used to encrypt standard
input to standard output using the public key of the named user.
(In a practical system, only the named user would then be able
to decrypt the result, using his private key.)
The "-d" (decipher) option is used to decrypt standard input to
standard output using the private key of the current user.
Thus, if the current user has login name "BOZO", the network
.sp
.in +10
rsa -e bozo | rsa -d
.sp
.in -10
effects an identity transformation.
.sp
Further information on public-key cryptosystems in general and
the RSA algorithm in particular can be found in the following
references:
.sp
.in +5
Hellman, Martin E.
"The Mathematics of Public-Key Cryptography,"
in
.ul
Scientific American,
Vol. 241, No. 2, pp. 146-157, August, 1979
.sp
Rivest, R. L., Adi Shamir, and Len Adleman
.ul
On Digital Signatures and Public-Key Cryptosystems,
Report MIT/LCS/Tm-82,
Laboratory for Computer Science,
Massachusetts Institute of Technology,
April, 1977
.sp
Rivest, R. L., A. Shamir, and A. Adleman
"A Method for Obtaining Digital Signatures and Public-Key
Cryptosystems,"
in
.ul
Communications of the ACM,
Vol. 21, No. 2, pages 120-126, February, 1978.
.in -5
.sp 2
EXAMPLES
.sp
.nf
rsa -i   # initializes public and private key files
plaintext> rsa -e system >ciphertext
ciphertext> rsa -d >plaintext
rsa -e bozo >>=extra=/mail/bozo
.fi
.sp 2
FILES
.sp
"=varsdir=/.rsa_encipher" for public-key information;
.br
"=varsdir=/.rsa_decipher" for private-key information.
.sp 2
MESSAGES
.sp
Various self-explanatory messages if key files are not present
or unreadable.
.sp 2
BUGS
.sp
32 bit arithmetic is insufficient to guarantee security.
.sp
Locally supported.
.sp 2
SEE ALSO
.sp
Subsystem Mathematical Function Library ('vswtml')
#-t-
#-h-  rsa.r         5571  local  09/24/80  13:44:51
# rsa --- toy RSA public-key cryptosystem

#     usage:   rsa -i
#              rsa -e correspondent
#              rsa -d

   character option (MAXLINE), correspondent (MAXLINE)
   character mapdn

   string options "ied"

   integer choice
   integer getarg, index

   if (getarg (1, option, MAXLINE) == EOF || option (1) ~= '-'c)
      call usage

   choice = index (options, mapdn (option (2)))
   case choice {

     #   -i
      call initialize

     #   -e
      {
         if (getarg (2, correspondent, MAXLINE) == EOF)
            call usage
         call send (STDIN, STDOUT, correspondent)
         }

     #   -d
      {
         if (getarg (2, correspondent, MAXLINE) == EOF)
            ;  # do nothing now --- correspondent is optional
         call receive (STDIN, STDOUT, correspondent)
         }

      }

   else
      call usage

   stop
   end



# usage --- print usage message, then die

   subroutine usage

   call remark ("usage:  rsa (-i | -e correspondent | -d).")

   stop
   end



# initialize --- create RSA parameter files

   subroutine initialize

   long_int p, q, E, D, n
   long_int invmod

   string en_file "=varsdir=/.rsa_encipher"
   string en_prot "a/r"             # owners all, non-owners read-only
   string de_file "=varsdir=/.rsa_decipher"
   string de_prot "a"               # owners all, non-owners none

   file_des en_fd, de_fd
   file_des create

   en_fd = create (en_file, READWRITE)
   if (en_fd == ERR) {
      call remark ("cannot create encryption parameters file.")
      return
      }

   de_fd = create (de_file, READWRITE)
   if (de_fd == ERR) {
      call close (en_fd)
      call remark ("cannot create decryption parameters file.")
      return
      }

   call get_primes (p, q, E)
   n = p * q
   call print (en_fd, "*l,*l*n.", E, n)
   D = invmod (E, (p - 1) * (q - 1))
   call print (de_fd, "*l,*l*n.", D, n)

   call close (en_fd)
   call close (de_fd)

   call prot$ (en_file, en_prot)
   call prot$ (de_file, de_prot)

   return
   end



# get_primes --- get prime numbers for generating encryption parameters

   subroutine get_primes (p, q, E)
   long_int p, q, E

   long_int random, prime

   call randomize

   p = prime (random (intl (20), intl (54)))
   q = prime (random (intl (20), intl (54)))
   E = prime (random (intl (55), intl (3511)))

   return
   end



# randomize --- set random number generator to nonobvious seed

   subroutine randomize

   integer td (10), i, seed

   call timdat (td, 10)
   seed = 0
   do i = 1, 10
      seed = seed + td (i)
   call rnd (iabs (seed))

   return
   end



# random --- return random number between bounds

   long_int function random (lwb, upb)
   long_int lwb, upb

   real rnd

   random = (upb - lwb) * rnd (0) + lwb

   return
   end



# send --- encrypt fin to fout using parameters of self and correspondent

   subroutine send (fin, fout, correspondent)
   file_des fin, fout
   character correspondent (ARB)

   integer get_en_params
   long_int E, n

   if (get_en_params (correspondent, E, n) == OK)
      call encipher (fin, fout, E, n)
   else
      call remark ("RSA enciphering file missing or unreadable.")

   return
   end



# get_en_params --- get enciphering parameters from user's RSA file

   integer function get_en_params (user, E, n)
   character user (ARB)
   long_int E, n

   string prefix "=vars=/"
   string suffix "/.rsa_encipher"
   character param_file (MAXLINE)

   integer length, input

   file_des param
   file_des open

   call scopy (prefix, 1, param_file, 1)
   call scopy (user, 1, param_file, length (param_file) + 1)
   call scopy (suffix, 1, param_file, length (param_file) + 1)

   param = open (param_file, READ)
   if (param == ERR || input (param, "*,,,l*l.", E, n) == EOF)
      get_en_params = ERR
   else
      get_en_params = OK

   if (param ~= ERR)
      call close (param)

   return
   end



# encipher --- RSA encipher characters on file 'fi' to file 'fo'

   subroutine encipher (fi, fo, E, n)
   file_des fi, fo
   long_int E, n

   character p
   character getch

   long_int pwrmod

   while (getch (p, fi) ~= EOF)
      call print (fo, "*l*n.", pwrmod (intl (p), E, n))

   return
   end



# receive --- decrypt fin to fout using params of self and correspondent

   subroutine receive (fin, fout, correspondent)
   file_des fin, fout
   character correspondent (ARB)    # presently unused

   integer get_de_params
   long_int D, n

   if (get_de_params (D, n) == OK)
      call decipher (fin, fout, D, n)
   else
      call remark ("RSA deciphering file missing or unreadable.")

   return
   end



# get_de_params --- get deciphering parameters from user's RSA file

   integer function get_de_params (D, n)
   long_int D, n

   string param_file "=varsdir=/.rsa_decipher"

   integer length, input

   file_des param
   file_des open

   param = open (param_file, READ)
   if (param == ERR || input (param, "*,,,l*l.", D, n) == EOF)
      get_de_params = ERR
   else
      get_de_params = OK

   if (param ~= ERR)
      call close (param)

   return
   end



# decipher --- RSA decipher integers on file 'fi' to file 'fo'

   subroutine decipher (fi, fo, D, n)
   file_des fi, fo
   long_int D, n

   long_int c
   integer get_cipher

   long_int pwrmod

   while (get_cipher (c, fi) ~= EOF)
      call putch (ints (pwrmod (c, D, n)), fo)

   return
   end



# get_cipher --- read ciphertext integer from specified file

   integer function get_cipher (l, fi)
   long_int l
   file_des fi

   integer input

   get_cipher = input (fi, "*l.", l)

   return
   end
#-t-
#-t-  rsa                        7957  local   01/05/81  16:48:38
#-h-  stats                      8069  local   01/05/81  16:48:42
#-h-  stats.doc         1878  local  09/24/80  13:51:47
.he 'STATS'03/20/80'STATS'
NAME
.sp
stats - print statistical measures
.sp 2
SYNOPSIS
.sp
stats  [ -{option} ]
.sp
option -> t | a | m | s | v | h | l | r | q | n | %<rank>
.sp 2
DESCRIPTION
.sp
'Stats' is a filter that can be used to generate various statistical
measures of a set of floating point data.
Input to 'stats' is a list of numbers, appearing one per line but
free-form within each line, on its first standard input.
Output from 'stats' is a list of statistics, preceded by labels
(unless the "-q" option has been specified) on the first standard output.
.sp
The options control the statistics to be printed.
Those presently available are:
.sp
.in +10
.rm -5
.ti -5
t    Print the sum (total) of all data values.
.ti -5
a    Print the arithmetic mean (average) of the data values.
.ti -5
m    Print the mode (most frequently occuring value).
.ti -5
s    Print the standard deviation of the population sampled.
.ti -5
v    Print the variance of the population sampled.
.ti -5
h    Print the highest value in the sample.
.ti -5
l    Print the lowest value in the sample.
.ti -5
r    Print the range of values in the sample (highest - lowest).
.ti -5
q    Quiet; turn off the printing of labels on the output.
.ti -5
n    Print the number of data values in the sample.
.ti -5
%    Print percentile ranks for the data.
The percent sign (%) must be followed by the percentile increment
to be used for the ranking.
Note that "-%50" yields the median value for the sample.
.sp
.in -10
.rm +5
The default options are currently "-as%50".
.sp 2
EXAMPLES
.sp
.nf
grades> stats
grades> stats -ahl%25
{tc -l ([files .r])} | stats -tahl
lf -cw | field 1-8 | stats -tq
.fi
.sp 2
MESSAGES
.sp
"Usage..." for improper options.
.sp 2
BUGS
.sp
Restricted to small data sets because of an internal sort which
is not really necessary for any statistic other than the
percentile ranking.
#-t-
#-h-  stats.r         5588  local  09/24/80  13:51:48
# stats --- generate statistics from list of measurements

   define (MAXMEASURES, 4000)

   call options
   call sadistics

   stop
   end



# options --- fetch options from command line

   subroutine options

   include "stats_com.r.i"

   character arg (MAXLINE)

   integer i
   integer getarg, ctoi

  # defaults:
   Print_total = NO
   Print_average = YES
   Print_mode = NO
   Print_sdev = YES
   Print_variance = NO
   Print_high = NO
   Print_low = NO
   Print_range = NO
   Quiet = NO
   Print_ranks = YES
   Percentile = 50
   Print_n = NO

   if (getarg (1, arg, MAXLINE) ~= EOF && arg (1) == '-'c) {
      Print_total = NO
      Print_average = NO
      Print_mode = NO
      Print_sdev = NO
      Print_variance = NO
      Print_high = NO
      Print_low = NO
      Print_range = NO
      Quiet = NO
      Print_ranks = NO
      Print_n = NO
      for (i = 2; arg (i) ~= EOS; i = i + 1)
         if (arg (i) == 't'c || arg (i) == 'T'c)
            Print_total = YES
         else if (arg (i) == 'a'c || arg (i) == 'A'c)
            Print_average = YES
         else if (arg (i) == 'm'c || arg (i) == 'M'c)
            Print_mode = YES
         else if (arg (i) == 's'c || arg (i) == 'S'c)
            Print_sdev = YES
         else if (arg (i) == 'v'c || arg (i) == 'V'c)
            Print_variance = YES
         else if (arg (i) == 'h'c || arg (i) == 'H'c)
            Print_high = YES
         else if (arg (i) == 'l'c || arg (i) == 'L'c)
            Print_low = YES
         else if (arg (i) == 'r'c || arg (i) == 'R'c)
            Print_range = YES
         else if (arg (i) == 'q'c || arg (i) == 'Q'c)
            Quiet = YES
         else if (arg (i) == '%'c) {
            Print_ranks = YES
            i = i + 1
            Percentile = ctoi (arg, i)
            if (Percentile == 0)
               Percentile = 10
            i = i - 1
            }
         else if (arg (i) == 'n'c || arg (i) == 'N'c)
            Print_n = YES
         else
            call error ("usage:  stats [-(t|a|m|s|v|h|l|r|q|n|%<int>)].")
      }

   return
   end



# sadistics --- calculate and print requested statistics

   subroutine sadistics

   include "stats_com.r.i"

   integer i, p, occurs, mode_occurs, index, mode_index,
      ranks, step
   integer input
   logical keep

   longreal sum, sumsq, average, variance, low, high, v

   sum = 0.0
   sumsq = 0.0

   keep = (Print_ranks ~= 0 | Print_mode ~= NO)
   for (N = 1; input (STDIN, "*f.", v) ~= EOF; N += 1) {
      sum += v
      sumsq += v * v
      if (N == 1) {
         low = v
         high = v
         }
      else if (v > high)
         high = v
      else if (v < low)
         low = v
      if (keep)
         Value (N) = v
      }
   N -= 1      # actual number of Values read

   if (N == 0)
      return

   average = sum / N
   variance = N * (average ** 2) - 2 * average * sum + sumsq
   if (N > 1)
      variance /= N - 1

   if (Print_total == YES) {
      call label ("total.")
      call print (STDOUT, "*d*n.", sum)
      }

   if (Print_n == YES) {
      call label ("size.")
      call print (STDOUT, "*i*n.", N)
      }

   if (Print_average == YES) {
      call label ("average.")
      call print (STDOUT, "*d*n.", average)
      }

   if (Print_low == YES) {
      call label ("low.")
      call print (STDOUT, "*d*n.", low)
      }

   if (Print_high == YES) {
      call label ("high.")
      call print (STDOUT, "*d*n.", high)
      }

   if (Print_range == YES) {
      call label ("range.")
      call print (STDOUT, "*d*n.", high - low)
      }

   if (Print_variance == YES) {
      call label ("variance.")
      call print (STDOUT, "*d*n.", variance)
      }

   if (Print_sdev == YES) {
      call label ("std dev.")
      call print (STDOUT, "*d*n.", dsqrt (variance))
      }

   if (Print_ranks == YES) {
      call sort
      ranks = int (100.0 / Percentile + .5)
      p = Percentile
      for (i = 1; i < ranks; i += 1) {
         if (Quiet == NO)
            call print (STDOUT, "*2i%        .", p)
         call print (STDOUT, "*d*n.", Value (int ((i * N) / ranks + .5)))
         p += Percentile
         }
      }

   if (Print_mode == YES) {
      mode_occurs = 1
      mode_index = int (N / 2.0 + .5)
      for (i = 1; i <= N; ) {
         index = i
         occurs = 1
         repeat {
            i += 1
            if (i > N || Value (i) ~= Value (index))
               break
            occurs += 1
            }
         if (occurs > mode_occurs) {
            mode_occurs = occurs
            mode_index = index
            }
         }
      call label ("mode.")
      call print (STDOUT, "*d*n.", Value (mode_index))
      }

   return
   end



# label --- output label for some useful piece of information

   subroutine label (lab)
   integer lab (ARB)

   include "stats_com.r.i"

   character buf (MAXLINE)

   integer i
   integer ptoc

   if (Quiet == NO) {
      call print (STDOUT, "*p.", lab)
      for (i = ptoc (lab, '.'c, buf, MAXLINE); i <= 10; i += 1)
         call putch (' 'c, STDOUT)
      }

   return
   end



# sort --- place array 'value' in ascending order
#           (Shell sort from Ch. 4 Software Tools)

   subroutine sort

   include "stats_com.r.i"

   integer gap, i, j, jg

   longreal k

   for (gap = N / 2; gap > 0; gap /= 2)
      for (i = gap + 1; i <= N; i += 1)
         for (j = i - gap; j > 0; j -= gap) {
            jg = j + gap
            if (Value (j) <= Value (jg))
               break
            k = Value (j)
            Value (j) = Value (jg)
            Value (jg) = k
            }

   return
   end
#-t-
#-h-  stats_com.r.i          418  local  09/24/80  13:51:48
   integer Print_total, Print_average, Print_mode, Print_sdev,
      Print_variance, Print_high, Print_low, Print_range, Quiet,
      Print_ranks, Percentile, Print_n

   common /optcom/ Print_total, Print_average, Print_mode,
      Print_sdev, Print_variance, Print_high, Print_low,
      Print_range, Quiet, Print_ranks, Percentile, Print_n

   floating Value (MAXMEASURES)
   integer N

   common /valcom/ Value, N
#-t-
#-t-  stats                      8069  local   01/05/81  16:48:42
#-h-  ta                        18672  local   01/05/81  16:53:42
# from the University of Arizona
common /ctarch/ fname(NAMESIZE,MAXFILES),fstat(MAXFILES),nfiles,errcnt,
   verbos,curpos,ntapa,nbuf(NBUFSIZE),nptrs(MAXNAMES),nnames,nptr
   character fname     # file arguments
   integer fstat       # YES if touched, NO otherwise; init = NO
   integer nfiles      # number of file args
   integer errcnt      # error count; init = 0
   integer verbos      # YES for verbose output; init = NO
   integer curpos      # current position of the tape
   integer ntapa       # next free file number
   character nbuf      # list of files to write onto tape
   integer nptrs       # pointers to files in nbuf
   integer nnames      # number of names in nbuf, init = 0
   integer nptr        # next free slot in nbuf, init = 1
#include ratdef

define(NAMESIZE,20)
define(MAXFILES,350)
define(MAXLINE,200)
define(NBUFSIZE,2000)
define(MAXNAMES,200)
 
define(TBL,LETT)
define(PRINT,LETP)
define(EXTR,LETX)
define(UPD,LETU)
define(DEL,LETD)
define(REPL,LETR)
define(CMPRS,LETS)
define(VFLG,LETV)
# addfil - add file "name"  to archive
   subroutine addfil(name, dfd, errcnt)
   character entry(MAXLINE), name(ARB)
   integer open
   integer errcnt, dfd, nfd, tapa, date, time, year, junk
 
   nfd = open(name, READ)
   if (nfd == ERR) {
      call putlin(name, ERROUT)
      call remark(": can't add.")
      errcnt = errcnt + 1
      }
   else
      call close(nfd)
   if (errcnt == 0) {
      call makent(name, entry, tapa, year(junk), date(junk), time(junk))
      call putlin(entry, dfd)
      call addnam(name, tapa)
      }
   return
   end
# addnam - add  name  to list of files to write to tape
   subroutine addnam(name, tapa)
   character name(NAMESIZE)
   integer tapa, i, k
   include ctarch

   if (length(name) + 2 > NBUFSIZE | nnames + 1 > MAXNAMES)
      call error("too many files.")
   nbuf(nptr) = tapa
   call scopy(name, 1, nbuf, nptr + 1)
   nnames = nnames + 1
   nptrs(nnames) = nptr
   nptr = nptr + length(name) + 2  # count for tapa and EOS
   for (i = nnames; i > 1; i = i - 1) {  # keep sorted on tapa
      k = nptrs(i-1)
      if (tapa < nbuf(k)) {
         nptrs(i-1) = nptrs(i)
         nptrs(i) = k
         }
      else
         break   # can't go any further
      }
   return
   end
# alldon(junk) - return YES if all files processed, NO otherwise
   integer function alldon(junk)
   integer junk, i
   include ctarch

   if (nfiles <= 0) {
      alldon = NO
      return
      }
   for (i = 1; i <= nfiles; i = i + 1)
      if (fstat(i) == NO) {
         alldon = NO
         return
         }
   alldon = YES
   return
   end
# ta - tape archive maintainer
   character dname(NAMESIZE), comand(NAMESIZE)
   integer getarg, i
   include ctarch
   string aname(NAMESIZE) "mt:"         # logical tape name
 
   i = 2
   if (getarg(1, comand, NAMESIZE) == EOF |
       getarg(2, dname, NAMESIZE) == EOF)
      call help
   call fold(comand)
   call fold(aname)
   if (comand(2) == VFLG) {
      verbos = YES   # talk to user
      i = 3
      }
#   if (comand(i) ^= EOS)  # new archive name
#      call scopy(comand, i, aname, 1)
   call getfns
   if (comand(1) == UPD | comand(1) == REPL)
      call update(aname, dname, comand(1))
   else if (comand(1) == TBL)
      call table(dname)
   else if (comand(1) == EXTR | comand(1) == PRINT)
      call extrac(aname, dname, comand(1))
   else if (comand(1) == DEL)
      call delete(dname)
   else if (comand(1) == CMPRS)
      call comprs(aname, dname)
   else
      call help
   end
# block data for tape archive
   block data
   include ctarch
   data errcnt /0/
   data verbos /NO/
   data curpos /1/
   data ntapa /1/
   data nnames /0/
   data nptr /1/
   end
# comprs - compress tape archive in place
   subroutine comprs(aname, dname)
   character aname(NAMESIZE), dname(NAMESIZE)
   character name(NAMESIZE), in(MAXLINE)
   integer create, open, getent
   integer i, n, itoc, junk, tapa, mdate, mtime, myear, dfd, tfd
   include ctarch
   string tname "ta.tmp"
   string iname(NAMESIZE) "z"

   dfd = open(dname, READ)
   if (dfd == ERR)
      call cant(dname)
   for (n = 1; getent(dfd, in, name, tapa, mdate, mtime, myear) ^= EOF; n = n + 1) {
      if (verbos == YES)
         call show(LETX, name, tapa)
      junk = itoc(n, iname(2), NAMESIZE - 1)
      call addnam(iname, tapa)
      }
   call close(dfd)
   call doio(aname, EXTR, errcnt)
   if (errcnt > 0)
      call error("fatal errors - archive not altered.")
   ntapa = 1   # reset in order to rewrite the tape
   nptr = 1
   nnames = 0
   dfd = open(dname, READ)
   if (dfd == ERR)
      call cant(dname)
   tfd = create(tname, WRITE)
   if (tfd == ERR)
      call cant(tname)
   for (n = 1; getent(dfd, in, name, tapa, mdate, mtime, myear) ^= EOF; n = n + 1) {
      if (verbos == YES)
         call show(LETA, name, ntapa)
      junk = itoc(n, iname(2), NAMESIZE - 1)
      call addnam(iname, ntapa)   # read file into new place
      call makent(name, in, tapa, myear, mdate, mtime)
      if (tapa + 1 ^= ntapa)  # just in case
         call error("comprs: out of phase.")
      call putlin(in, tfd)
      }
   call close(dfd)
   call close(tfd)
   call doio(aname, UPD, errcnt)  # update the tape
   if (errcnt == 0)
      call amove(tname, dname)
   else
      call remark("fatal errors - archive not altered.")
   for (n = n - 1; n > 0; n = n - 1) {  # remove temporary files
      junk = itoc(n, iname(2), NAMESIZE - 1)
      call remove(iname)
      }
   call remove(tname)
   return
   end
# delete - delete files from archive
   subroutine delete(dname)
   character dname(NAMESIZE)
   character name(NAMESIZE), in(MAXLINE)
   integer create, open, getent, filarg
   integer dfd, tfd, tapa, junk
   include ctarch
   string tname "ta.tmp"
 
   if (nfiles <= 0)   # protect innocents
      call error("delete by name only.")
   dfd = open(dname, READ)
   if (dfd == ERR)
      call cant(dname)
   tfd = create(tname, WRITE)
   if (tfd == ERR)
      call cant(tname)
   while (getent(dfd, in, name, tapa, junk, junk, junk) ^= EOF)
      if (filarg(name, YES) == YES) {
         if (verbos == YES)
            call show(LETD, name, tapa)
         }
      else {    # just copy existing version
         if (verbos == YES)
            call show(LETC, name, tapa)
         call putlin(in, tfd)
         }
   call notfnd
   call close(dfd)
   call close(tfd)
   if (errcnt == 0)
      call amove(tname, dname)
   else
      call remark("fatal errors - archive not altered.")
   call remove(tname)
   return
   end
# extrac - extract or print files from archive
   subroutine extrac(aname, dname, cmd)
   character aname(NAMESIZE), dname(NAMESIZE), ename(NAMESIZE), in(MAXLINE)
   integer create, filarg, getent, open, alldon
   integer afd, dfd, cmd, efd, tapa, junk
   include ctarch
 
   dfd = open(dname, READ)
   if (dfd == ERR)
      call cant(dname)
   if (cmd == PRINT)
      efd = STDOUT
   else
      efd = ERR
   while (getent(dfd, in, ename, tapa, junk, junk, junk) ^= EOF) {
      if (filarg(ename, YES) == YES) {
         if (efd ^= STDOUT)
            efd = create(ename, WRITE)
         if (efd == ERR) {
            call putlin(ename, ERROUT)
            call remark(": can't create.")
            errcnt = errcnt + 1
            }
         else {
            if (verbos == YES & cmd ^= PRINT)
               call show(LETX, ename, tapa)
            call addnam(ename, tapa)
            if (efd ^= STDOUT)
               call close(efd)
            }
         }
      if (alldon(junk) == YES)
         break
      }
   call notfnd
   call doio(aname, cmd, errcnt)
   return
   end
# fcheck - returns YES if  name  is newer than mdate, myear & mtime
   integer function fcheck(name, mdate, myear, mtime)
   character name(ARB)
   integer mdate, myear, mtime
   integer fstat, info(3)

   if (fstat(name, info, 3) == ERR)
      fcheck = NO
   else if (myear < info(2))
      fcheck = YES
   else if (myear == info(2) & mdate < info(1))
      fcheck = YES
   else if (myear == info(2) & mdate == info(1) & mtime < info(3))
      fcheck = YES
   else
      fcheck = NO
   return
   end
# filarg - check if name matches argument list
   integer function filarg(name, exact)
   character name(ARB)
   integer equal, indexs
   integer i, exact
   include ctarch
 
   if (nfiles <= 0) {
      filarg = YES
      return
      }
   if (exact == YES) {   # must match exactly
      for (i = 1; i <= nfiles; i = i + 1)
         if (equal(name, fname(1, i)) == YES) {
            fstat(i) = YES
            filarg = YES
            return
            }
      }
   else if (exact == NO) {   # permit partial match
      for (i = 1; i <= nfiles; i = i + 1)
         if (indexs(name, fname(1, i)) > 0) {
            fstat(i) = YES
            filarg = YES
            return
            }
      }
   else
      call error("filarg: can't happen.")
   filarg = NO
   return
   end
# getfns - get file names into fname, check for duplicates
   subroutine getfns
   integer equal, getarg
   integer i, j
   include ctarch
 
   errcnt = 0
   for (i = 1; i <= MAXFILES; i = i + 1)
      if (getarg(i+2, fname(1, i), NAMESIZE) == EOF)
         break
      else call fold(fname(1, i))
   nfiles = i - 1
   if (i > MAXFILES)
      if (getarg(i+2, j, 1) ^= EOF)
         call error("too many file names.")
   for (i = 1; i <= nfiles; i = i + 1)
      fstat(i) = NO
   for (i = 1; i < nfiles; i = i + 1)
      for (j = i + 1; j <= nfiles; j = j + 1)
         if (equal(fname(1, i), fname(1, j)) == YES) {
            call putlin(fname(1, i), ERROUT)
            call error(": duplicate file name.")
            }
   return
   end
# getent - get directory entry info from  fd
   integer function getent(fd, buf, name, tapa, mdate, mtime, myear)
   character buf(MAXLINE), name(NAMESIZE)
   integer ctoi, getlin, getwrd, equal
   integer fd, i, len, tapa, mdate, mtime, myear
   string hdr "-h-"
 
   if (getlin(buf, fd) == EOF) {
      getent = EOF
      return
      }
   getent = YES
   i = 1
   len = getwrd(buf, i, name)
   call fold(name)
   if (equal(name, hdr) == NO)
      call error("directory not in proper format.")
   len = getwrd(buf, i, name)
   tapa = ctoi(buf, i)
   myear = ctoi(buf, i)
   if (myear > 10000) {         # old yyyymmdd style date
      mdate = mod(myear, 10000)
      myear = myear/10000
      }
   else
      mdate = ctoi(buf, i)
   mtime = ctoi(buf, i)
   return
   end
# help - diagnostic printout
   subroutine help
 
   call error("usage: ta {dprtsux}[v] dirname [files].")
   return
   end
define(MAXCHARS,10)
# makent - make directory entry line for archive member
   subroutine makent(name, entry, tapa, year, date, time)
   character entry(MAXLINE), name(NAMESIZE)
   integer tapa, itoc, length, time, date, year
   integer i
   include ctarch
   string hdr "-h-"
 
   call scopy(hdr, 1, entry, 1)
   i = length(hdr) + 1
   entry(i) = BLANK
   call scopy(name, 1, entry, i+1)
   i = length(entry) + 1
   entry(i) = BLANK
   tapa = ntapa   # return tape address
   i = i + 1 + itoc(ntapa, entry(i+1), MAXCHARS)
   ntapa = ntapa + 1  # one more file
   entry(i) = BLANK
   i = i + 1 + itoc(year, entry(i+1), MAXCHARS)
   entry(i) = BLANK
   i = i + 1 + itoc(date, entry(i+1), MAXCHARS)
   entry(i) = BLANK
   i = i + 1 + itoc(time, entry(i+1), MAXCHARS)
   entry(i) = NEWLINE
   entry(i+1) = EOS
   return
   end
# notfnd - print "not found" message
   subroutine notfnd
   integer i
   include ctarch
 
   for (i = 1; i <= nfiles; i = i + 1)
      if (fstat(i) == NO) {
         call putlin(fname(1, i), ERROUT)
         call remark(": not in archive.")
         errcnt = errcnt + 1
         }
   return
   end
# replac - update or replace files
   subroutine replac(dfd, tfd, cmd, ecnt)
   character in(MAXLINE), uname(NAMESIZE)
   integer filarg, getent, fcheck
   integer dfd, cmd, ecnt, tapa, tfd, mdate, mtime, myear
   include ctarch
 
   while (getent(dfd, in, uname, tapa, mdate, mtime, myear) ^= EOF)
      if (filarg(uname, YES) == YES) {
         if (cmd == REPL | (cmd == UPD & nfiles > 0)) {
            if (verbos == YES)   # unconditionally add new one
               call show(cmd, uname, ntapa)   # use new tape address
            call addfil(uname, tfd, ecnt)
            }
         else if (cmd == UPD) {   # add new one if newer
            if (fcheck(uname, mdate, myear, mtime) == YES) {
               if (verbos == YES)
                  call show(LETU, uname, ntapa)
               call addfil(uname, tfd, ecnt)
               }
            else {    # just copy existing version
               if (verbos == YES)
                  call show(LETC, uname, tapa)
               call putlin(in, tfd)
               }
            }
         else
            call error("replac: can't happen.")
         }
      else {    # just copy existing version
         if (verbos == YES)
            call show(LETC, uname, tapa)
         call putlin(in, tfd)
         }
   return
   end
# show - print c tapa name for verbose output
   subroutine show(c, name, tapa)
   character c, name(NAMESIZE)
   integer tapa

   call putc(c)
   call putdec(tapa, 4)
   call putc(BLANK)
   call putlin(name, STDOUT)
   call putc(NEWLINE)
   return
   end
# table - print table of archive contents
   subroutine table(dname)
   character dname(NAMESIZE), in(MAXLINE), lname(NAMESIZE)
   integer filarg, getent, open
   integer dfd, tapa, junk, mdate, mtime, myear
 
   dfd = open(dname, READ)
   if (dfd == ERR)
      call cant(dname)
   while (getent(dfd, in, lname, tapa, mdate, mtime, myear) ^= EOF) {
      if (filarg(lname, NO) == YES)
         call tprint(lname, tapa, mdate, myear, mtime)
      }
   call notfnd
   return
   end
# tapend - scan directory  dname  to find next free tape address
   subroutine tapend(dname)
   character dname(NAMESIZE)
   character in(MAXLINE), name(NAMESIZE)
   integer getent, open
   integer dfd, tapa, junk
   include ctarch

   ntapa = 1
   dfd = open(dname, READ)
   if (dfd == ERR)
      return
   while (getent(dfd, in, name, tapa, junk, junk, junk) ^= EOF)
      if (tapa >= ntapa)
         ntapa = tapa + 1   # got a new one
   call close(dfd)
   return
   end
# tprint - print table entry for one member
   subroutine tprint(name, tapa, date, year, time)
   character name(ARB)
   integer tapa, date, year, time
   integer mod
   include ctarch
 
   if (verbos == YES) {   # the long message
      call putdec(date/100, 2)
      call putc(SLASH)
      call putdec(mod(date, 100), 2)
      call putc(SLASH)
      call putdec(mod(year, 100), 2)
      call putdec(time/100, 3)
      call putc(COLON)
      if (mod(time, 100) < 10)
         call putc(DIG0)
      call putdec(mod(time, 100), 0)
      call putdec(tapa, 6)
      call putc(BLANK)
      }
   call putlin(name, STDOUT)
   call putc(NEWLINE)
   return
   end
# update - update or replace existing files, add new ones at end
   subroutine update(aname, dname, cmd)
   character aname(NAMESIZE), dname(NAMESIZE), cmd
   integer create, getarg, open
   integer i, tfd, dfd
   include ctarch
   string tname "ta.tmp"

   call tapend(dname)   # set next free file
   dfd = open(dname, READ)
   if (dfd == ERR)    # if new archive, create directory
      dfd = create(dname, READ)
   if (dfd == ERR)
      call cant(dname)
   tfd = create(tname, WRITE)
   if (tfd == ERR)
      call cant(tname)
   call replac(dfd, tfd, cmd, errcnt)      # update or replace existing
   for (i = 1; i <= nfiles; i = i + 1)      # add new ones
      if (fstat(i) == NO) {
         if (verbos == YES)
            call show(LETA, fname(1, i), ntapa)
         call addfil(fname(1, i), tfd, errcnt)
         fstat(i) = YES
         }
   call close(dfd)
   call close(tfd)
   call doio(aname, cmd, errcnt)  # update the tape
   if (errcnt == 0)
      call amove(tname, dname)
   else
      call remark("fatal errors - archive not altered.")
   call remove(tname)
   return
   end

#========= Machine Dependent Tape Routines ==========

# doio - perform tape i/o as indicated by names in nbuf and  cmd
   subroutine doio(aname, cmd, err)
   character aname(NAMESIZE)
   integer cmd, err
   integer afd, nfd, create, open, i, np, mode, tapop, blksiz
   include ctarch

   if (cmd == PRINT | cmd == EXTR)
      mode = READ
   else
      mode = WRITE
   if (tapop(8%1006, aname, blksiz, 1) == ERR) {
      call printf("%n%s: can't read block size\n\0", ERROUT, aname)
      err = err + 1
      return
      }
   if (tapop(8%2006, aname, 128+1, 1) == ERR) {
      call printf("%n%s: can't set block size to 512 bytes\n\0", ERROUT,
         aname)
      err = err + 1
      return
      }
   afd = open(aname, mode)
   if (afd == ERR) {
      call printf("%n%s: can't open\n\0", ERROUT, aname)
      err = err + 1
      return
      }
   call rewind(aname, afd)
   for (i = 1; i <= nnames; i = i + 1) {
      np = nptrs(i)
      if (cmd == PRINT) {  # print the file
         call mtpos(nbuf(np), afd)
         call fcopy(afd, STDOUT)
         curpos = curpos + 1
         }
      else if (cmd == EXTR) {  # extract the file
         nfd = create(nbuf(np+1), WRITE)
         if (nfd == ERR) {
            call printf("%n%s: can't create\n\0", ERROUT, nbuf(np+1))
            err = err + 1
            next
            }
         call mtpos(nbuf(np), afd)
         call fcopy(afd, nfd)
         curpos = curpos + 1
         call close(nfd)
         }
      else if (cmd == UPD | cmd == REPL) {  # replace the file
         nfd = open(nbuf(np+1), READ)
         if (nfd == ERR) {
            call printf("%n%s: can't open\n\0", ERROUT, nbuf(np+1))
            err = err + 1
            break   # quit in this case
            }
         call mtpos(nbuf(np), afd)
         call fcopy(nfd, afd)
         curpos = curpos + 1
         call close(nfd)
         }
      else
         call error("doio: can't happen.")
      call close(afd)  # this is stupid
      afd = open(aname, mode)
      if (afd == ERR) {
         call printf("%n%s: can't re-open\n\0", ERROUT, aname)
         err = err + 1
         return
         }
      }
   call rewind(aname, afd)
   call close(afd)
   if (tapop(8%2006, aname, blksiz, 1) == ERR)
      call printf("%n%s: can't reset block size\n\0", ERROUT, aname)
   return
   end
# mtpos - position tape on afd to begin reading/writing at file  n
   subroutine mtpos(n, afd)
   integer n, afd
   include ctarch

   for ( ; curpos > n; curpos = curpos - 1)   # skip backwards
      call mtape(15, afd)
   for ( ; curpos < n; curpos = curpos + 1)   # skip forwards
      call mtape(14, afd)
   return
   end
# rewind - rewind the tape
   subroutine rewind(aname, afd)
   character aname(NAMESIZE)
   integer afd
   include ctarch

   call mtape(1, afd)
   curpos = 1
   return
   end
#-t-  ta                        18672  local   01/05/81  16:53:42
#-h-  trim                        580  local   01/05/81  16:53:46
# from the University of Arizona
#include ratdef
# trim - trim characters in argument from the ends of lines in STDIN
   character c, arg(MAXLINE), buf(MAXLINE)
   integer j, getlin, length, getarg, index

   if (getarg(1, arg, MAXLINE) == EOF) {
      arg(1) = BLANK    # default is blanks and tabs
      arg(2) = TAB
      arg(3) = EOS
      }
   while (getlin(buf, STDIN) ^= EOF) {
      for (j = length(buf) - 1; j > 0; j = j - 1)
         if (index(arg, buf(j)) == 0)
            break
      buf(j+1) = EOS
      call putlin(buf, STDOUT)
      call putc(NEWLINE)
      }
   end
#-t-  trim                        580  local   01/05/81  16:53:46
#-t-  tools                    164345  local   01/05/81  23:05:25
#-h-  library                  221308  local   01/05/81  23:05:50
#-h-  libdef                     5552  local   01/05/81  21:38:24
#  Defines for Software Tools Subsystem support library
#                 Version 7
                                                                                
# Defines for I/O routines:
define(MAXLSBUF,16384)
define(NFILES,128)
define(FD_SIZE,16)
define(BUF_SIZE,16)
define(DEV_TTY,1)
define(DEV_DSK,2)
define(DEV_NULL,3)
                                                                                
define(FD_READ,:100000)
define(FD_WRITE,:40000)
define(FD_EOF,:20000)
define(FD_ERR,:10000)
define(FD_COMP,:4000)
define(FD_OPENED,:2000)
define(FD_MBZ,:1770)
define(FD_TYP,:7)
                                                                                
define(FD_INITIAL,0)
define(FD_DSKRD,1)
define(FD_DSKWT,2)
define(FD_DSKGET,3)
define(FD_DSKPUT,4)
define(FD_TTYRD,5)
define(FD_TTYWT,6)
define(FD_TTYGET,7)
define(FD_TTYPUT,8)
                                                                                
define(calc_fd_offset(fd),(fd-1)*FD_SIZE+1)
                                                                                
# Defines for 'lopen$':
define(FTN,:100000) # Use FORTRAN forms control
define(EXP,:40000)  # Expand compressed listing
define(LNR,:20000)  # Generate line numbers in left margin
define(NHD,:10000)  # Suppress heading
define(NEJ,:4000)   # Suppress trailing page eject
define(RAW,:2000)   # Use no forms control
define(DEF,:400)    # Defer printing until defer_time
define(LOC,:200)    # Print on local printer only
define(ATL,:100)    # Print at the named location
define(COP,:20)     # Print the specified number of copies
                                                                                
# Defines for 'print' and 'input':
define(FORMATFLAG,'*'c)
define(ADDRFORM,'a'c)         # two-word address pointer
define(BOOLFORM,'b'c)         # boolean value
define(CHARFORM,'c'c)         # single character
define(DOUBLEFORM,'d'c)       # double precision floating point
define(FLOATFORM,'f'c)        # double precision floating point
define(GOTOFORM,'g'c)         # reset i/o list pointer
define(HOLLERITHFORM,'h'c)    # hollerith character string
define(INTFORM,'i'c)          # short integer signed representation
define(RCINTFORM,'j'c)        # short integer unsigned representation
define(SKIPFORM,'k'c)
define(LONGINTFORM,'l'c)      # long integer signed representation
define(RCLONGINTFORM,'m'c)    # long integer unsigned representation
define(NLINE,'n'c)            # newline
define(PACKEDSTRINGFORM,'p'c) # period-terminated packed string
define(REALFORM,'r'c)         # single precision floating point
define(STRINGFORM,'s'c)       # EOS-terminated string
define(TABFORM,'t'c)          # tab to absolute column number
define(DEFAULTFORM,'u'c)      # sets default parameters
define(VARYINGFORM,'v'c)      # PL/I character varying string
define(FILLFORM,'x'c)         # fill
define(YESNOFORM,'y'c)        # YES/NO value
                                                                                
# Defines for memory management routines:
define(DS_MEMEND,1)     # pointer to end of memory
define(DS_AVAIL,2)      # start of available space list
define(DS_CLOSE,8)      # threshhold for close-fitting blocks
define(DS_LINK,1)       # link field of storage block
define(DS_SIZE,0)       # size field of storage block
define(DS_OHEAD,2)      # total words of overhead per block
                                                                                
# Defines for symbol table routines:
define(ST_LINK,0)       # offset of link field in symbol table node
define(ST_DATA,1)       # offset of data field in symbol table node
define(ST_HTABSIZE,43)  # should be a prime number
                                                                                
# Definitions for template expander:
define(TEMP_HTABSIZE,37)
define(TEMP_MAXBUF,4059)   # 4096 - TEMP_HTABSIZE
define(TEMP_DATE,1)
define(TEMP_TIME,2)
define(TEMP_USER,3)
define(TEMP_PID,4)
define(TEMP_PASSWD,5)
define(TEMP_DAY,6)
                                                                                
# Miscellaneous definitions:
define(MAX_NAME, 7)
define(MAXINTEGER,8r77777)  # maximum positive integer
define(CHARS_PER_WORD,2)
define(NOTEXECUTABLE,1)
define(ISCIFILE,-4)
define(NOTFOUND,0)
define(FOUND,1)
define(DAM,1)
define(SAM,0)
define(INH,1)
define(ENB,0)
                                                                                
define(REATTACH,1)   # 'tscan$': attach to path on each call
define(PREORDER,2)   # 'tscan$': return entry for ufd before its contents
define(POSTORDER,4)  # 'tscan$': return entry for ufd after its contents
define(EODPAUSE,8)   # 'tscan$': return control at end of directory
define(EOD,0)        # 'tscan$': return code for end of directory
                     #           MUST be distinct from ERR, EOF & OK
                                                                                
                                                                                
# Math library:
                                                                                
define(BITS_PER_WORD,16)
define(BITS_PER_LONG_WORD,32)
                                                                                
define(LASTPRIME,78498)
                                                                                
define (PRESENT, 1)
define (NOT_PRESENT, 0)
                                                                                
define (WORDS(bits),((bits+BITS_PER_WORD-1)/BITS_PER_WORD))
      # (the number of words required to contain 'bits' bits)
#-t-  libdef                     5552  local   01/05/81  21:38:24
#-h-  ctod                       6072  local   01/05/81  21:38:25
#-h-  ctod.doc                   1301  local   01/05/81  21:28:42
.he 'CTOD'03/23/80'CTOD'
NAME
.sp
ctod - convert string to double precision real
.sp 2
SYNOPSIS
.sp
.nf
long_real function ctod (str, i)
character str (ARB)
integer i
.fi
.sp 2
DESCRIPTION
.sp
'Ctod' converts the character string in the array 'str',
starting at position 'i', to double precision floating point
representation and returns this value as the result of the
function. The variable 'i' is incremented to a point one character
beyond the string that was converted; the array 'str' is not
modified.
'Str' must be an EOS-terminated unpacked character string.
.sp
'Ctod' recognizes any valid Fortran constant;
in particular, leading signs are handled.
Leading blanks and tabs are ignored.
.sp 2
IMPLEMENTATION
.sp
'Ctod' accumulates the integer and fractional parts of the
number, throwing away leading zeros and insignificant digits
and computing scaling factors if necessary.
A straightforward Horner's method conversion translates each
portion of the constant to binary, and finally all portions
are combined and appropriately scaled.
Scaling is aided by using tables of powers-of-two exponents,
to preserve as much accuracy as possible.
.sp 2
ARGUMENTS MODIFIED
.sp
i
.sp 2
CALLS
.sp
ctoi
.sp 2
SEE ALSO
.sp
dtoc (2), ctor (2), rtoc (2), other conversion routines
('cto?*' and '?*toc') (2)
#-t-  ctod.doc                   1301  local   01/05/81  21:28:42
#-h-  ctod.r                     4507  local   01/05/81  21:28:43
# ctod --- convert string to double precision real
                                                                                
   longreal function ctod (str, i)
   character str (ARB)
   integer i
                                                                                
   define(MAXDIG,16)
   integer j, k, s, pe (28)      # size of pe and pv is machine dependent
   integer gctoi
   longreal v, e, pv (28)
   character dig (MAXDIG)
   bool neg
                                                                                
   data pv  / 1d    1, 1d    2, 1d    4, 1d    8, 1d   16,
              1d   32, 1d   64, 1d  128, 1d  256, 1d  512,
              1d 1024, 1d 2048, 1d 4096, 1d 8192,
                                                                                
              1d   -1, 1d   -2, 1d   -4, 1d   -8, 1d  -16,
              1d  -32, 1d  -64, 1d -128, 1d -256, 1d -512,
              1d-1024, 1d-2048, 1d-4096, 1d-8192 /
                                                                                
   data pe  /       1,       2,       4,       8,      16,
                   32,      64,     128,     256,     512,
                 1024,    2048,    4096,    8192,
                                                                                
                   -1,      -2,      -4,      -8,     -16,
                  -32,     -64,    -128,    -256,    -512,
                -1024,   -2048,   -4096,   -8192 /
                                                                                
                                                                                
   SKIPBL (str, i)      # ignore leading blanks
                                                                                
   neg = (str (i) == '-'c)    # check for sign
   if (str (i) == '+'c || str (i) == '-'c)
      i += 1
                                                                                
   while (str (i) == '0'c)    # ignore high-order zeros
      i += 1
                                                                                
   for (j = 1; j < MAXDIG && IS_DIGIT (str (i)); {j += 1; i += 1})
      dig (j) = str (i)       # collect significant integral digits
                                                                                
   for (s = 0; IS_DIGIT (str (i)); {s += 1; i += 1})
      ;                       # ignore the rest, adjusting scale factor
                                                                                
   if (str (i) == '.'c) {     # check for a fraction
      i += 1
      if (j == 1)    # special case to accurately handle 0.000ddd etc.
         while (str (i) == '0'c) {
            i += 1
            s -= 1
            }
      for (; j < MAXDIG && IS_DIGIT (str (i)); {j += 1; i += 1}) {
         dig (j) = str (i)
         s -= 1      # adjust scale factor
         }
      while (IS_DIGIT (str (i)))    # discard insig. fractional digits
         i += 1
      }
                                                                                
   while (j > 1 && dig (j - 1) == '0'c) {    # truncate trailing zeros
      s += 1   # increment the scale factor (multiply by 10)
      j -= 1   # truncate one trailing zero (divide by 10)
      }
                                                                                
   dig (j) = EOS     # terminate the digit string
                                                                                
   if (str (i) == 'e'c || str (i) == 'E'c) {    # check for exponent
      i += 1
      s += gctoi (str, i, 10)
      }
                                                                                
   v = 0.0           # now convert the mantissa bits
   for (j = 1; dig (j) ~= EOS; j += 1)
      v = v * 10.0 + (dig (j) - '0'c)
                                                                                
   e = 1.0
   select
      when (s > 0)
         for (j = 14; j > 0; j -= 1) {
            if (s >= pe (j)) {
               s -= pe (j)
               e *= pv (j)
               }
            }
      when (s < 0)
         for (j = 28; j > 14; j -= 1) {
            if (s <= pe (j)) {
               s -= pe (j)
               e *= pv (j)
               }
            }
   ifany
      ctod = v * e
   else
      ctod = v
                                                                                
   if (neg)
      ctod = -ctod
                                                                                
   return
   end
#-t-  ctod.r                     4507  local   01/05/81  21:28:43
#-t-  ctod                       6072  local   01/05/81  21:38:25
#-h-  ctop                       1993  local   01/05/81  21:38:26
#-h-  ctop.doc                   1011  local   01/05/81  21:30:01
.he 'CTOP'03/23/80'CTOP'
NAME
.sp
ctop - convert EOS-terminated string to packed string
.sp 2
SYNOPSIS
.sp
.nf
integer function ctop (str, i, pstr, len)
character str (ARB)
integer i, len
packed_char pstr (len)
.sp 2
.fi
DESCRIPTION
.sp
'Ctop' converts the EOS-terminated unpacked string in argument 'str',
starting at position 'i', to packed integer form in the array 'pstr'.
The argument 'len' gives the maximum length of the array 'pstr';
no more than 'len' words of this array will be modified by 'ctop'.
After conversion, 'i' points to the EOS at the end of 'str',
or one position past the last character packed if the maximum
length of 'pstr' is exceeded.
.sp
The function return is the number of characters transferred from
'str' to 'pstr'.
.sp 2
IMPLEMENTATION
.sp
'Ctop' picks up successive characters from 'str' and packs them into
'pstr' with the standard Subsystem macro 'spchar'.
.sp 2
ARGUMENTS MODIFIED
.sp
i, pstr
.sp 2
SEE ALSO
.sp
ptoc (2), other conversion routines ('cto?*' and '?*toc') (2)
#-t-  ctop.doc                   1011  local   01/05/81  21:30:01
#-h-  ctop.r                      718  local   01/05/81  21:30:01
# ctop --- convert EOS-terminated string to packed string
                                                                                
   integer function ctop (str, i, pstr, len)
   character str (ARB)
   integer i, pstr (ARB), len
                                                                                
   integer cp, max
                                                                                
   max = len * CHARS_PER_WORD
                                                                                
   for (ctop = 0; str (i) ~= EOS && ctop < max; i += 1)
      spchar (pstr, ctop, str (i))
                                                                                
   return
   end
#-t-  ctop.r                      718  local   01/05/81  21:30:01
#-t-  ctop                       1993  local   01/05/81  21:38:26
#-h-  ctor                       1833  local   01/05/81  21:38:27
#-h-  ctor.doc                   1077  local   01/05/81  21:30:27
.he 'CTOR'03/23/80'CTOR'
NAME
.sp
ctor - character to real conversion
.sp 2
SYNOPSIS
.sp
.nf
real function ctor (str, i)
character str (ARB)
integer i
.fi
.sp 2
DESCRIPTION
.sp
'Ctor' is similar in function to 'ctoi', except that it
converts floating point numbers as well as integers.
The character
string in 'str' is examined starting in position 'i'.
Conversion stops when a character is encountered
that cannot correctly appear in the number.
'I' is updated to point to the first character not
included in the converted number.
The value returned by the function is the real (single precision)
value of the character string.
.sp
The number in 'str' may contain a leading sign, a
decimal point, and an exponent.  A decimal point
is not required.
.sp 2
IMPLEMENTATION
.sp
'Ctod' is called to convert the character string into
a double precision value.  This value is converted to
single precision format and returned as
the value of 'ctor'.
.sp 2
ARGUMENTS MODIFIED
.sp
i
.sp 2
CALLS
.sp
ctod
.sp 2
SEE ALSO
.sp
input (2), other conversion routines ('cto?*' and '?*toc') (2)
#-t-  ctor.doc                   1077  local   01/05/81  21:30:27
#-h-  ctor.r                      492  local   01/05/81  21:30:28
# ctor --- convert string to single precision real
                                                                                
   real function ctor (str, i)
   character str (ARB)
   integer i
                                                                                
   longreal ctod
                                                                                
   return (ctod (str, i))
                                                                                
   end
#-t-  ctor.r                      492  local   01/05/81  21:30:28
#-t-  ctor                       1833  local   01/05/81  21:38:27
#-h-  ctov                       2677  local   01/05/81  21:38:28
#-h-  ctov.doc                   1535  local   01/05/81  21:30:38
.he 'CTOV'03/23/80'CTOV'
NAME
.sp
ctov - convert EOS-terminated string to PL/I varying string
.sp 2
SYNOPSIS
.sp
.nf
integer function ctov (str, i, var, len)
character str (ARB)
integer i, len
packed_char var (len)
.sp 2
.fi
DESCRIPTION
.sp
'Ctov' converts Software Tools style EOS-terminated strings
to PL/I style "character varying" strings.
Character varying strings consist of a one-word length field,
followed by up to 65535 words of packed character data.
.sp
The argument 'str' contains the EOS-terminated string to be
converted.
The integer 'i' gives the position of the first character in
the string to be converted, i.e. the starting point of the
substring to be packed.
'Var' is the array which is to receive the character varying
string, and 'len' is  the number of words in 'var' available
for holding characters  plus one (for the string length word).
Conversion starts at the 'i'th position in 'str' and continues
until an EOS is encountered in 'str' or 'var' is completely
filled.
The function return is the number of characters packed.
.sp 2
IMPLEMENTATION
.sp
'Ctov', like 'ctop', makes repeated calls on the standard macro
'spchar' to pack characters into the destination array.
Once all characters in the string have been packed, or no
room remains in the destination, 'ctov' sets the first word
of the destination array to the number of characters it
contains and returns this number as the function value.
.sp 2
ARGUMENTS MODIFIED
.sp
i, var
.sp 2
SEE ALSO
.sp
other conversion routines ('cto?*' and '?*toc') (2)
#-t-  ctov.doc                   1535  local   01/05/81  21:30:38
#-h-  ctov.r                      878  local   01/05/81  21:30:39
# ctov --- convert EOS-terminated string to PL/I varying string
                                                                                
   integer function ctov (str, i, var, len)
   character str (ARB)
   integer i, var (ARB), len
                                                                                
   integer max
                                                                                
   max = (len - 1) * CHARS_PER_WORD + CHARS_PER_WORD
                                                                                
   for (ctov = CHARS_PER_WORD; str (i) ~= EOS && ctov < max; i += 1)
      spchar (var, ctov, str (i))
                                                                                
   ctov -= CHARS_PER_WORD
   var (1) = ctov
                                                                                
   return
   end
#-t-  ctov.r                      878  local   01/05/81  21:30:39
#-t-  ctov                       2677  local   01/05/81  21:38:28
#-h-  decode                    31125  local   01/05/81  21:38:29
#-h-  decode.doc                 6497  local   01/05/81  21:30:51
.he 'DECODE'03/30/80'DECODE'
NAME
.sp
decode - perform formatted conversion from character
.sp 2
SYNOPSIS
.sp
.nf
integer function decode (str, sp, fmt, fp, ap, a1, ..., a10)
character str (ARB), fmt (ARB)
integer sp, fp, ap
untyped a1, ..., a10
.sp 2
.fi
DESCRIPTION
.sp
'Decode' is used to convert a character string to a number of
items in various internal formats (e.g. integer, double precision
floating point, address, etc.).
Its function is similar to the Fortran statement of the same name.
.sp
The argument 'str' is the character string to be decoded, and
'sp' indicates the position in 'str' at which decoding is to begin.
'Fmt' is a string of format control directives (discussed below),
and 'fp' indicates the position in 'fmt' of the first format control
directive to be used for decoding.
'A1' through 'a10' (at most) are variables to receive decoded data;
'a2' through 'a10' are optional, and any or all may be omitted.
'Ap' indicates the next variable in the list of 'a1' through 'a10'
to receive decoded data.
.sp
'Decode' performs the decoding operation until it either runs
out of string to decode or of format to control the decoding.
The arguments 'sp', 'fp', and 'ap' are always updated to point
to the next unused character in 'str', the next unused character
in 'fmt', and the next variable in the variable list, respectively.
.sp
The function return is OK if not all of the format string was
used, EOF if all of the format string was used, or ERR if
an input string was in error.
.sp
The format string consists of a series of "format control
directives."
Each directive controls the conversion of a segment of the character
string into some internal form.
A directive consists of the format flag character (an asterisk "*")
followed by up to three comma-separated option fields, and a single
character format specifier.
The option fields are normally designated the "width", "base", and
"delimiter character" fields.
The width field controls the maximum number of characters in the
input string to be converted.
The base field controls the radix representation assumed for
integer fields (and a few other miscellaneous options, discussed
below).
The delimiter character field specifies a character that may be
used to terminate the conversion process for a single variable if
it is encountered in the string.
.sp
The following format specifiers are available:
.in +5
.de F1
.ne 5
.sp
.ti -5
.bd
$1
.sp
.en F1
.F1 a
The input string must contain an address of the form
"<ring_number>.<segment_number>.<offset>".
The receiving variable must be a two-word address pointer.
.F1 "b or y"
The input string must contain a boolean constant, which may be
1 or 0, TRUE or FALSE, T or F, YES or NO, Y or N.
The receiving variable must be of type integer or type logical.
.F1 "d or f"
The input string must contain a standard Fortran representation
of a double-precision floating-point constant.
The receiving variable must be of type long_real or double_precision.
.F1 g
None of the input string is examined by this format code.
The argument pointer 'ap' is set to the value of the width field;
this allows input items to be re-filled or skipped entirely.
.F1 h
The input string must contain at least as many characters as are
specified by the width field.
The given number of characters are then packed into the receiving
variable, which must be an array of integers larger than
the number of characters divided by two (since there are two
characters per word on the Prime.)
The base field, if nonzero, specifies a limit on the number of
words of the receiving array that will be changed;
thus, if the width field is not specified, the entire input string
(possibly terminated by the delimiter character) will be packed
into the receiving array, but the array will be protected from
overrun by the specification of its size in the base field.
The code 'h' comes from the Fortran term "hollerith literal,"
which is the type of the receiving variable.
.F1 i
The input string must contain a representation of a short
(16-bit) integer constant.
If the base field is non-zero, it is assumed to be the radix used
for representation of the integer.
If zero, base 10 is assumed.
The base specified in the format directive may be overridden in the
input string by giving a radix followed by the letter "r" followed
by the desired value, e.g. "2r1001" or "16rA000".
The receiving variable must be of type integer.
.F1 l
The input string must contain a representation of a long
(32-bit) integer constant.
The syntax and semantics of this form are identical to
form 'i' above, with the exception that the receiving variable
must be of type long_int (integer*4).
.F1 n
The width field specifies the number of newlines in the input
string to be skipped.
If the end of the input string is encountered, the skipping stops.
This code is most often used by the 'input' routine.
.F1 p
The syntax and semantics of this form are identical to the 'h'
form above, with the exception that a period character (".")
will be placed at the end of the receiving array so that its
length may be determined at run time.
.F1 r
The input string must contain a standard Fortran representation
of a single-precision floating point number.
The receiving variable must be of type real.
.F1 s
As many characters as specified by the base field (unless the
delimiter character is encountered first) are copied from the
input string to the receiving variable, which must be an
array of characters.
.F1 t
The string pointer variable 'sp' is set to the value of the
width field, or to the length of the input string, whichever
is shorter.
.F1 u
The values of the width, base, and delimiter character fields
specified on this directive become the default values for the
remainder of the format directives in the format string.
.F1 v
The syntax and semantics of this directive are similar to the
'h' directive above, with the exception that the receiving variable
must be a PL/I-style character-varying array.
.F1 x
The number of characters specified by the width field
(unless the delimiter character is encountered first) are skipped;
that is, the specified portion of the input string is ignored.
.in -5
.sp 2
IMPLEMENTATION
.sp
Impossible to explain to the uninitiated reader.
Please see the code, and a system guru.
.sp 2
ARGUMENTS MODIFIED
.sp
sp, fp, ap, a1-a10
.sp 2
CALLS
.sp
ctoi, ctop, ctoc, length, ctoa, move$, ctov, gctoi,
gctol, ctor, ctod, remark
.sp 2
SEE ALSO
.sp
input (2), conversion routines ('cto?*') (2)
#-t-  decode.doc                 6497  local   01/05/81  21:30:51
#-h-  decode.r                  24364  local   01/05/81  21:30:53
# decode --- formatted memory-to-memory conversion routine
                                                                                
   integer function decode (str, sp, fmt, fp, ap,
               a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)
   character str (ARB)
   integer sp, fmt (ARB), fp, ap, a1 (ARB), a2 (ARB), a3 (ARB), a4 (ARB),
      a5 (ARB), a6 (ARB), a7 (ARB), a8 (ARB), a9 (ARB), a10 (ARB)
                                                                                
   integer cur_sp, cur_fp, cur_ap
   integer i, num, m, l, tp
   integer default_width, default_base, default_delim
   integer width, base, delim
   integer ctoi, gctoi
                                                                                
   longint ln
   longint ctoa, gctol
                                                                                
   character term, tmp (MAXDECODE)
                                                                                
   real lr
   real ctor
                                                                                
   longreal ld
   longreal ctod
                                                                                
   procedure interpret_format forward
   procedure get_num forward
   procedure convert_num forward
   procedure error_in_field forward
   procedure get_str forward
   procedure decode_packed forward
   procedure decode_string forward
   procedure decode_bool forward
   procedure decode_tab forward
   procedure decode_addr forward
   procedure decode_varying forward
   procedure decode_integer forward
   procedure decode_longint forward
   procedure decode_real forward
   procedure decode_double forward
   procedure decode_newline forward
   procedure decode_fill forward
   procedure too_many_args forward
                                                                                
   default_width = 0
   default_base = 0
   default_delim = ' 'c
                                                                                
   for (; fmt (fp) ~= EOS; fp += 1) {
                                                                                
      cur_fp = fp                      # for error recovery
      cur_sp = sp
      cur_ap = ap
                                                                                
      if (fmt (fp) ~= FORMATFLAG)
         ;                             # ignore the character
                                                                                
      else {
         interpret_format
         select (fmt (fp))
            when (GOTOFORM)
               ap = width
            when (DEFAULTFORM) {
               default_width = width
               default_base = base
               default_delim = delim
               }
            when (BOOLFORM)
               decode_bool
            when (YESNOFORM)
               decode_bool
            when (TABFORM)
               decode_tab
            when (ADDRFORM)
               decode_addr
            when (PACKEDSTRINGFORM) {
               term = '.'c
               decode_packed
               }
            when (HOLLERITHFORM) {
               term = EOS
               decode_packed
               }
            when (STRINGFORM)
               decode_string
            when (VARYINGFORM)
               decode_varying
            when (INTFORM)
               decode_integer
            when (LONGINTFORM)
               decode_longint
            when (REALFORM)
               decode_real
            when (FLOATFORM, DOUBLEFORM)
               decode_double
            when (NLINE)
               decode_newline
            when (FILLFORM)
               decode_fill
         }
      }
                                                                                
   return (EOF)
                                                                                
                                                                                
   # interpret_format --- interpret and set the flags for the format
      procedure interpret_format {
                                                                                
         fp +=1                        # Get width
         if (fmt (fp) == ','c)         # omitted, use default
            width = default_width
         elif (fmt (fp) ~= '#'c) {     # indirect
            convert_num
            width = num
            }
         else {
            get_num
            width = num
            fp += 1
            }
                                                                                
         if (fmt (fp) ~= ','c)         # Get base
            base = default_base
         else {
            fp += 1
            if (fmt (fp) ~= '#'c) {
               convert_num
               base = num
               }
            else {
               get_num
               base = num
               fp += 1
               }
            }
                                                                                
         if (fmt (fp) ~= ','c)         # Get delim
            delim = default_delim
         else if (fmt (fp + 1) ~= '#'c) {
            delim = fmt (fp + 1)
            fp += 2
            }
         else if (fmt (fp + 2) == '#'c) {
            delim = '#'c
            fp += 3
            }
         else {
            get_num
            delim = num
            fp += 2
            }
                                                                                
         }
                                                                                
                                                                                
   # get_num --- grab a number from the argument list; put in 'num'
      procedure get_num {
                                                                                
         select (ap)
            when ( 1)  num = a1 (1)
            when ( 2)  num = a2 (1)
            when ( 3)  num = a3 (1)
            when ( 4)  num = a4 (1)
            when ( 5)  num = a5 (1)
            when ( 6)  num = a6 (1)
            when ( 7)  num = a7 (1)
            when ( 8)  num = a8 (1)
            when ( 9)  num = a9 (1)
            when (10)  num = a10 (1)
         else
            too_many_args
                                                                                
         ap += 1
                                                                                
         }
                                                                                
   # convert_num --- grab a number from the format string; put in 'num'
      procedure convert_num {
                                                                                
         bool neg
                                                                                
         neg = (fmt (fp) == '-'c)
         if (fmt (fp) == '+'c || fmt (fp) == '-'c)
            fp += 1
                                                                                
         num = ctoi (fmt, fp)
         if (neg)
            num = - num
                                                                                
         }
                                                                                
                                                                                
   # error_in_field --- a field contains an error; return error status
   procedure error_in_field {
                                                                                
      fp = cur_fp
      sp = cur_sp
      ap = cur_ap
                                                                                
      return (ERR)
      }
                                                                                
                                                                                
   # get_str --- get a delimited string from the input string
   procedure get_str {
                                                                                
      if (width > 0) {        # delimited by size
         for (tp = 1; tp <= width && tp <= MAXDECODE; {tp += 1; sp += 1}) {
            if (str (sp) == NEWLINE || str (sp) == EOS)
               break
            tmp (tp) = str (sp)
            }
         for (; tp <= width && tp < MAXDECODE; tp += 1)
            tmp (tp) = ' 'c
         tmp (tp) = EOS
         }
                                                                                
      else {                  # delimited by delimiter
         if (delim == ' 'c)
            SKIPBL (str, sp)
                                                                                
         for (tp = 1; tp < MAXDECODE; {tp += 1; sp += 1}) {
            if (str (sp) == NEWLINE || str (sp) == EOS || str (sp) == delim)
               break
            tmp (tp) = str (sp)
            }
         tmp (tp) = EOS
                                                                                
         if (str (sp) == delim)     # bump over delimiter
            sp += 1
         }
                                                                                
      }
                                                                                
                                                                                
   # decode_packed --- decode a packed string
      procedure decode_packed {
                                                                                
         get_str
                                                                                
         if (base == 0)
            m = MAXLINE
         else
            m = base
                                                                                
         tmp (tp) = term
         tmp (tp + 1) = EOS
                                                                                
         i = 1
                                                                                
         select (ap)
            when ( 1)  call ctop (tmp, i, a1,  m)
            when ( 2)  call ctop (tmp, i, a2,  m)
            when ( 3)  call ctop (tmp, i, a3,  m)
            when ( 4)  call ctop (tmp, i, a4,  m)
            when ( 5)  call ctop (tmp, i, a5,  m)
            when ( 6)  call ctop (tmp, i, a6,  m)
            when ( 7)  call ctop (tmp, i, a7,  m)
            when ( 8)  call ctop (tmp, i, a8,  m)
            when ( 9)  call ctop (tmp, i, a9,  m)
            when (10)  call ctop (tmp, i, a10, m)
         else
            too_many_args
                                                                                
         ap += 1
         }
                                                                                
                                                                                
   # decode_string --- decode an EOS-terminated string
      procedure decode_string {
                                                                                
         get_str
                                                                                
         if (base == 0)
            m = MAXLINE
         else
            m = base
                                                                                
         select (ap)
            when ( 1)  call ctoc (tmp, a1,  m)
            when ( 2)  call ctoc (tmp, a2,  m)
            when ( 3)  call ctoc (tmp, a3,  m)
            when ( 4)  call ctoc (tmp, a4,  m)
            when ( 5)  call ctoc (tmp, a5,  m)
            when ( 6)  call ctoc (tmp, a6,  m)
            when ( 7)  call ctoc (tmp, a7,  m)
            when ( 8)  call ctoc (tmp, a8,  m)
            when ( 9)  call ctoc (tmp, a9,  m)
            when (10)  call ctoc (tmp, a10, m)
         else
            too_many_args
                                                                                
         ap += 1
                                                                                
         }
                                                                                
                                                                                
   # decode_bool --- decode a boolean value
      procedure decode_bool {
                                                                                
         get_str
                                                                                
         tp = 1
         SKIPBL (tmp, tp)
                                                                                
         select (tmp (tp))
            when (EOS)
               if (base == 0)
                  m = 0
               else
                  m = 1
            when ('t'c, 'T'c, 'y'c, 'Y'c, '1'c, 'o'c, 'O'c)
               m = 1
            when ('f'c, 'F'c, 'n'c, 'N'c, '0'c)
               m = 0
         else
            error_in_field
                                                                                
         select (ap)
            when ( 1)  a1 (1) = m
            when ( 2)  a2 (1) = m
            when ( 3)  a3 (1) = m
            when ( 4)  a4 (1) = m
            when ( 5)  a5 (1) = m
            when ( 6)  a6 (1) = m
            when ( 7)  a7 (1) = m
            when ( 8)  a8 (1) = m
            when ( 9)  a9 (1) = m
            when (10)  a10 (1) = m
         else
            too_many_args
                                                                                
         ap += 1
                                                                                
         }
                                                                                
                                                                                
   # decode_tab --- handle tab formats
      procedure decode_tab {
                                                                                
         m = length (str)
         if (width <= m)
            sp = width
         else
            sp = m
                                                                                
         }
                                                                                
                                                                                
   # decode_addr --- decode an address
      procedure decode_addr {
                                                                                
         get_str
                                                                                
         i = 1
         ln = ctoa (tmp, i)
         SKIPBL (tmp, i)
         if (tmp (i) ~= EOS)
            error_in_field
                                                                                
         select (ap)
            when ( 1)  call move$ (ln, a1,  2)
            when ( 2)  call move$ (ln, a2,  2)
            when ( 3)  call move$ (ln, a3,  2)
            when ( 4)  call move$ (ln, a4,  2)
            when ( 5)  call move$ (ln, a5,  2)
            when ( 6)  call move$ (ln, a6,  2)
            when ( 7)  call move$ (ln, a7,  2)
            when ( 8)  call move$ (ln, a8,  2)
            when ( 9)  call move$ (ln, a9,  2)
            when (10)  call move$ (ln, a10, 2)
         else
            too_many_args
                                                                                
         ap += 1
         }
                                                                                
                                                                                
   # decode_varying --- decode a PL/I varying string
      procedure decode_varying {
                                                                                
         get_str
                                                                                
         if (base == 0)
            m = MAXLINE
         else
            m = base
                                                                                
         i = 1
                                                                                
         select (ap)
            when ( 1)  call ctov (tmp, i, a1,  m)
            when ( 2)  call ctov (tmp, i, a2,  m)
            when ( 3)  call ctov (tmp, i, a3,  m)
            when ( 4)  call ctov (tmp, i, a4,  m)
            when ( 5)  call ctov (tmp, i, a5,  m)
            when ( 6)  call ctov (tmp, i, a6,  m)
            when ( 7)  call ctov (tmp, i, a7,  m)
            when ( 8)  call ctov (tmp, i, a8,  m)
            when ( 9)  call ctov (tmp, i, a9,  m)
            when (10)  call ctov (tmp, i, a10, m)
         else
            too_many_args
                                                                                
         ap += 1
                                                                                
         }
                                                                                
                                                                                
   # decode_integer --- decode a short integer
      procedure decode_integer {
                                                                                
         get_str
                                                                                
         if (base == 0)
            base = 10
                                                                                
         i = 1
         l = gctoi (tmp, i, base)
         SKIPBL (tmp, i)
                                                                                
         if (tmp (i) ~= EOS)
            error_in_field
                                                                                
         select (ap)
            when ( 1)  a1 (1) = l
            when ( 2)  a2 (1) = l
            when ( 3)  a3 (1) = l
            when ( 4)  a4 (1) = l
            when ( 5)  a5 (1) = l
            when ( 6)  a6 (1) = l
            when ( 7)  a7 (1) = l
            when ( 8)  a8 (1) = l
            when ( 9)  a9 (1) = l
            when (10)  a10 (1) = l
         else
            too_many_args
                                                                                
         ap += 1
         }
                                                                                
                                                                                
   # decode_longint --- decode a long integer
      procedure decode_longint {
                                                                                
         get_str
                                                                                
         if (base == 0)
            base = 10
                                                                                
         i = 1
         ln = gctol (tmp, i, base)
         SKIPBL (tmp, i)
                                                                                
         if (tmp (i) ~= EOS)
            error_in_field
                                                                                
         select (ap)
            when ( 1)  call move$ (ln, a1, 2)
            when ( 2)  call move$ (ln, a2, 2)
            when ( 3)  call move$ (ln, a3, 2)
            when ( 4)  call move$ (ln, a4, 2)
            when ( 5)  call move$ (ln, a5, 2)
            when ( 6)  call move$ (ln, a6, 2)
            when ( 7)  call move$ (ln, a7, 2)
            when ( 8)  call move$ (ln, a8, 2)
            when ( 9)  call move$ (ln, a9, 2)
            when (10)  call move$ (ln, a10, 2)
         else
            too_many_args
                                                                                
         ap += 1
                                                                                
         }
                                                                                
                                                                                
   # decode_real --- decode a single-precision floating point number
      procedure decode_real {
                                                                                
         get_str
                                                                                
         i = 1
         lr = ctor (tmp, i)
         SKIPBL (tmp, i)
         if (tmp (i) ~= EOS)
            error_in_field
                                                                                
         select (ap)
            when ( 1)  call move$ (lr, a1,  2)
            when ( 2)  call move$ (lr, a2,  2)
            when ( 3)  call move$ (lr, a3,  2)
            when ( 4)  call move$ (lr, a4,  2)
            when ( 5)  call move$ (lr, a5,  2)
            when ( 6)  call move$ (lr, a6,  2)
            when ( 7)  call move$ (lr, a7,  2)
            when ( 8)  call move$ (lr, a8,  2)
            when ( 9)  call move$ (lr, a9,  2)
            when (10)  call move$ (lr, a10, 2)
         else
            too_many_args
                                                                                
         ap += 1
                                                                                
         }
                                                                                
                                                                                
   # decode_double --- decode a double-precision floating point number
      procedure decode_double {
                                                                                
         get_str
                                                                                
         i = 1
         ld = ctod (tmp, i)
         SKIPBL (tmp, i)
         if (tmp (i) ~= EOS)
            error_in_field
                                                                                
         select (ap)
            when ( 1)  call move$ (ld, a1,  4)
            when ( 2)  call move$ (ld, a2,  4)
            when ( 3)  call move$ (ld, a3,  4)
            when ( 4)  call move$ (ld, a4,  4)
            when ( 5)  call move$ (ld, a5,  4)
            when ( 6)  call move$ (ld, a6,  4)
            when ( 7)  call move$ (ld, a7,  4)
            when ( 8)  call move$ (ld, a8,  4)
            when ( 9)  call move$ (ld, a9,  4)
            when (10)  call move$ (ld, a10, 4)
         else
            too_many_args
                                                                                
         ap += 1
         }
                                                                                
                                                                                
   # decode_fill --- skip a specified number of characters
      procedure decode_fill {
                                                                                
         get_str                 # just thrown them away
                                                                                
         }
                                                                                
                                                                                
   # decode_newline --- skip a specified number of NEWLINES
      procedure decode_newline {
                                                                                
         if (width <= 0) {       # skip one newline, if it's there
            if (str (sp) == NEWLINE)
               sp += 1
            }
         else {                  # skip 'width' newlines
            i = 1
            repeat {
               while (str (sp) ~= NEWLINE && str (sp) ~= EOS)
                  sp += 1
               if (str (sp) == NEWLINE)
                  sp += 1
               i += 1
               } until (i > width)
            }
         if (str (sp) == EOS && fmt (fp + 1) ~= EOS) {
            fp += 1
            return (OK)          # get new input line
            }
                                                                                
         }
                                                                                
                                                                                
   # too_many_args --- issue an error message for too many arguments
      procedure too_many_args {
                                                                                
         call remark ("in decode: attempt to use more than 10 fields"p)
         tmp (1) = EOS
                                                                                
         }
                                                                                
   end
#-t-  decode.r                  24364  local   01/05/81  21:30:53
#-t-  decode                    31125  local   01/05/81  21:38:29
#-h-  dtoc                      16749  local   01/05/81  21:38:34
#-h-  dtoc.doc                   2736  local   01/05/81  21:31:14
.he 'DTOC'03/23/80'DTOC'
NAME
.sp
dtoc - convert double precision value to ASCII string
.sp 2
SYNOPSIS
.sp
.nf
integer function dtoc (val, out, w, d)
long_real val
character out (ARB)
integer w, d
.sp 2
.fi
DESCRIPTION
.sp
'Dtoc' converts the double precision floating point value in 'val' to a
character string in 'out'.  The length of the string is returned
as the value of 'dtoc'.
.sp
The values of 'w' and 'd' control the format of the converted
string.
Generally speaking, 'd' controls the number of decimal positions
or significant digits, and 'w' specifies the maximum length
of the field.
The following table  explains the operation of
'dtoc' for different combinations of 'w' and 'd'.
(Fortran and Basic programmers take note:  d>12 corresponds
to Basic output, 12>=d>=0 corresponds to Fortran 'F' format,
and 0>d>=-12 corresponds to Fortran 'E' format)
.sp
.in +18
.ta 12 19
.tc \
.ti -18
.ul
'd'\  'w'\       Result
.sp
.ti -18
d>12\w>16\If the value is in the range 1e7>v>=1e-2, it is
converted
into a
BASIC-like fixed-point
with no trailing zeroes
after the decimal point.
Otherwise, it is converted into a
BASIC-like exponential format
with no trailing zeroes after the decimal point.
.sp
.ti -18
\w<=16\An error is returned.
.sp
.ti -18
12>=d>=0\-\If possible, the
value is converted to a fixed-point format with 'd'
positions after the decimal point.
Otherwise, it is converted to an exponential
format with as many significant digits as possible.
If 'w' is less than 8, an exponential conversion
is not possible and an error will be returned.
.sp
.ti -18
0>d>-12\w>d+6\The number is converted to an exponential
format with 'd' significant digits.
.sp
.ti -18
\w<=d+6\An error is returned.
.sp
.in -18
To return an error, 'dtoc' places a string consisting
of a single question mark in 'out'.
.sp
It should be noted that 'w' is roughly equivalent to the
'size' parameter in other conversion routines such as
'itoc' and 'ltoc'; 'w' specifies the maximum number of
digits that may be produced.  Thus, the maximum number
of characters returned in 'out' will never exceed
'w + 1'.
.sp 2
IMPLEMENTATION
.sp
'Dtoc' first scales the number into the range 1 > v >= .1.  It
then determines the format in which the number is to be printed
and rounds the value to the proper number of digits.  The
digits are then extracted in character form.  One of several
conversion routines is then entered to take the extracted
digits and add decimal points, signs, and exponents as
required by the 'd' and 'w' specifications.
.sp 2
ARGUMENTS MODIFIED
.sp
out
.sp 2
CALLS
.sp
itoc
.sp 2
BUGS
.sp
Has been thoroughly debugged, but has not stood the
test of time.
.sp 2
SEE ALSO
.sp
ctod (2), other conversion routines ('cto?*' and '?*toc') (2)
#-t-  dtoc.doc                   2736  local   01/05/81  21:31:14
#-h-  dtoc.r                    13749  local   01/05/81  21:31:15
# dtoc --- convert double precision real to string
                                                                                
   define(DEBUG1,#)  # list output and flags
   define(DEBUG2,#)  # list scaling operations
   define(MAX_DIGITS,14)
                                                                                
   integer function dtoc (val, out, w, d)
   longreal val
   character out (ARB)
   integer w, d
                                                                                
   longreal v, pv (26), round (MAX_DIGITS)
   integer pe (26), i, e, j, len, no_digits, max_size
   bool neg, small, exp_format, BASIC_format
   character digits (17)
   string dig "0123456789"
                                                                                
   data pv /            1d    2, 1d    4, 1d    8, 1d   16,
               1d   32, 1d   64, 1d  128, 1d  256, 1d  512,
               1d 1024, 1d 2048, 1d 4096, 1d 8192,
                                                                                
                        1d   -2, 1d   -4, 1d   -8, 1d  -16,
               1d  -32, 1d  -64, 1d -128, 1d -256, 1d -512,
               1d-1024, 1d-2048, 1d-4096, 1d-8192/
                                                                                
   data pe /                  2,       4,       8,      16,
                    32,      64,     128,     256,     512,
                  1024,    2048,    4096,    8192,
                                                                                
                             -2,      -4,      -8,     -16,
                   -32,     -64,    -128,    -256,    -512,
                 -1024,   -2048,   -4096,   -8192/
                                                                                
   data round /                .05d0,
                              .005d0,
                             .0005d0,
                            .00005d0,
                           .000005d0,
                          .0000005d0,
                         .00000005d0,
                        .000000005d0,
                       .0000000005d0,
                      .00000000005d0,
                     .000000000005d0,
                    .0000000000005d0,
                   .00000000000005d0,
                  .000000000000005d0/
                                                                                
                                                                                
DEBUG2 write (1, 1) val; 1 format ("input value ", E25.15)
                                                                                
                                                                                
   ### set flags indicating whether the number is greater or
   ### less that zero, and whether its absolute value is
   ### greater or less than 1
                                                                                
   v = dabs (val)
   neg = (val < 0.0)
   small = (v < 0.1)
                                                                                
                                                                                
   ### scale number to 0.01 <= v < 10.0
                                                                                
   e = -1
   if (small) {      # number is less than 0.1
      for (i = 26; i > 13; i -= 1)
         if (v < pv (i)) {
            v /= pv (i)
            e += pe (i)
DEBUG2      write (1, 2) e, v; 2 format ("scale ", I6, E25.15)
            }
      }
   else {
      for (i = 13; i > 0; i -= 1)
         if (v * 10.0 >= pv (i)) {
            v /= pv (i)
            e += pe (i)
DEBUG2      write (1, 3) e, v; 3 format ("scale ", I6, E25.15)
            }
      }
                                                                                
                                                                                
   ### scale number so that 0.1 <= v < 1.0
                                                                                
DEBUG2 write (1, 4) e, v; 4 format ("before last scale ", I6, E25.15)
                                                                                
   if (v >= 1.0) {   # be sure 0.1 <= v < 1.0
      v /= 10.0
      e += 1
      }
   elif (v < 0.1) {
      v *= 10.0
      e -= 1
      }
                                                                                
   if (v == 0.0)       # not likely, but possible
      e = 0
                                                                                
DEBUG2 write (1, 5) e, v; 5 format ("after last scale ", I6, E25.15)
                                                                                
                                                                                
   ### start tally for the maximum size of the number to
   ### determine if an error should be returned.
                                                                                
   if (neg)
      max_size = 1
   else
      max_size = 0
                                                                                
                                                                                
   ### determine exact format for printing
                                                                                
   BASIC_format = (d > MAX_DIGITS)
   if (BASIC_format) {                 # BASIC-like format
      exp_format = (e > 5 | e < -2)
      if (exp_format) {
         no_digits = 6
         max_size = max_size + 1 + 1 +   5   + 1 + 1 +  4
                    #          9   .   99999   e   +   9999
         }
      else {
         no_digits = 6 + min0 (0, e)   # in case e is negative
         max_size = max_size + 1 + 1 +   5
                    #          9   .   99999
         }
      }
                                                                                
   elif (d >= 0) {                     # Fortran 'F' format
      exp_format = (w < 1 + max0 (e, 1) + 1 + d)
      #                 +   eee...        .   ddd...
      if (exp_format) {    # is there too little space?
         no_digits = max0 (1, w - 1 - 1 -   6)
                     #            + 9 .  e+9999
         max_size = max_size + 1 + no_digits + 6
                    #          .    nnnnnn    e+9999
         }
      else {
         no_digits = e + d + 1   #  negative e is OK here
         max_size = max_size + max0 (e, 0) + 1 +   d
                    #            eee...      .   ddd...
         }
      }
                                                                                
   else {  # d < 0                     # Fortran 'E' format
      exp_format = TRUE
      no_digits = min0 (MAX_DIGITS, -d)  # remember, d < 0
      max_size = max_size + 1 + no_digits +  6
                 #          .    ddd...    e+9999
      }
                                                                                
                                                                                
   ### be sure the number of digits is in range
                                                                                
   no_digits = min0 (max0 (1, no_digits), MAX_DIGITS)
                                                                                
                                                                                
   ### round the number at digit (no_digits + 1)
                                                                                
   v += round (no_digits)
                                                                                
                                                                                
   ### handle the unusual situation of rounding from .999...
   ### up to 1.000...
                                                                                
   if (v >= 1.0) {
      v /= 10.0
      e += 1
      if (~ exp_format) {
         max_size += 1
         no_digits = min0 (MAX_DIGITS, no_digits + 1)
         }
      }
                                                                                
                                                                                
   ### see if the number will fit in 'w' characters
                                                                                
   if (max_size > w) {
      out (1) = '?'c
      out (2) = EOS
      dtoc = 1
DEBUG1 call print (ERROUT, "dtoc:*2i out:*s*n.", dtoc, out)
      return
      }
                                                                                
DEBUG2 write (1, 6) v; 6 format ("after rounding ", E25.15)
                                                                                
                                                                                
   ### extract the first <no_digits> digits
                                                                                
   do i = 1, no_digits; {
      v *= 10.0d0
      j = v    # truncate to integer
      v -= j   # lop off the integral part
      digits (i) = dig (j + 1)
      }
                                                                                
                                                                                
DEBUG1 integer db1
DEBUG1 call print (ERROUT, "w:*2i d:*2i .", w, d)
DEBUG1 call putlit ("small:.", '.'c, ERROUT)
DEBUG1 if (small)
DEBUG1    call putlit ("YES .", '.'c, ERROUT)
DEBUG1 else
DEBUG1    call putlit ("NO  .", '.'c, ERROUT)
DEBUG1 call putlit ("neg:.", '.'c, ERROUT)
DEBUG1 if (neg)
DEBUG1    call putlit ("YES .", '.'c, ERROUT)
DEBUG1 else
DEBUG1    call putlit ("NO  .", '.'c, ERROUT)
DEBUG1 call putlit ("exp_format:.", '.'c, ERROUT)
DEBUG1 if (exp_format)
DEBUG1    call putlit ("YES .", '.'c, ERROUT)
DEBUG1 else
DEBUG1    call putlit ("NO  .", '.'c, ERROUT)
DEBUG1 call print (ERROUT, "e:*6i no_digits:*2i .", e, no_digits)
DEBUG1 call putlit ("digits:.", '.'c, ERROUT)
DEBUG1 for (db1 = 1; db1 <= no_digits; db1 += 1)
DEBUG1    call putch (digits (db1), ERROUT)
DEBUG1 call putch (BLANK, ERROUT)
                                                                                
                                                                                
   ### take digit string and exponent and arrange into
   ### desired format, depending on 'exp_format' and 'BASIC_format'
                                                                                
   len = 1
   if (neg) {
      out (1) = '-'c
      len += 1
      }
                                                                                
   if (exp_format) {             # set up exponential format
      out (len) = digits (1)
      out (len + 1) = '.'c
      len += 2
      for (i = 2; i <= no_digits; i += 1) {
         out (len) = digits (i)
         len += 1
         }
      if (BASIC_format)          # if BASIC, skip trailing zeroes
         while (len > 2) {
            len -= 1
            if (out (len) == '.'c)
               break
            else if (out (len) ~= '0'c) {
               len += 1          # non-digit -- keep it
               break
               }
            }
      out (len) = 'e'c
      len += 1
      if (e < 0) {
         out (len) = '-'c
         len += 1
         e = -e
         }
      len += itoc (e, out (len), w - len)
      }
   elif (e < 0) {    # handle fixed numbers < 1
      ### special case numbers from .5000... to .9999...
      if (d == 0 && e == -1 && digits (1) >= '5'c)
         out (len) = '1'c
      else
         out (len) = '0'c
      out (len + 1) = '.'c
      len += 2
      for (i = 1; i < -e && i <= d; i += 1) {
         out (len) = '0'c
         len += 1
         }
      for (j = 1; j <= no_digits && i <= d; j += 1) {
         out (len) = digits (j)
         len += 1
         i += 1
         }
      if (BASIC_format)             # if BASIC, skip trailing zeroes
         while (len > 2) {
            len -= 1
            if (out (len) == '.'c)
               break
            else if (out (len) ~= '0'c) {
               len += 1             # non-digit -- keep it
               break
               }
            }
      else
         for  (i = 1; i < d + e - no_digits && i <= d; i += 1) {
            out (len) = '0'c
            len += 1
            }
      }
   elif (e >= no_digits) {    # handle numbers >= 1 with dp after figures
      for (i = 1; i <= no_digits; i += 1) {
         out (len) = digits (i)
         len += 1
         }
      for (i = no_digits; i <= e; i += 1) {
         out (len) = '0'c
         len += 1
         }
      if (~ BASIC_format) {         # no trailing dp or zeroes in BASIC
         out (len) = '.'c
         len += 1
         for (i = 1; i <= d; i += 1) {
            out (len) = '0'c
            len += 1
            }
         }
      }
   else {      # handle numbers > 1 with dp inside figures
      e += 1
      for (i = 1; i <= e; i += 1) {
         out (len) = digits (i)
         len += 1
         }
      out (len) = '.'c
      len += 1
      for (j = 1; i <= no_digits && j <= d; j += 1) {
         out (len) = digits (i)
         i += 1
         len += 1
         }
      if (BASIC_format)             # if BASIC, skip trailing zeroes
         while (len > 2) {
            len -= 1
            if (out (len) == '.'c)
               break
            elif (out (len) ~= '0'c) {
               len += 1             # non-digit -- keep it
               break
               }
            }
      else
         for (i = 1; i <= e + d - no_digits && i <= d; i += 1) {
            out (len) = '0'c
            len += 1
            }
      }
                                                                                
   out (len) = EOS
   dtoc = len - 1
DEBUG1 call print (ERROUT, "dtoc:*2i out:*s*n.", dtoc, out)
   return
   end
#-t-  dtoc.r                    13749  local   01/05/81  21:31:15
#-t-  dtoc                      16749  local   01/05/81  21:38:34
#-h-  encode                    41899  local   01/05/81  21:38:37
#-h-  encode.doc                10906  local   01/05/81  21:31:31
.he 'ENCODE'03/23/80'ENCODE'
NAME
.sp
encode - formatted memory-to-memory conversion routine
.sp 2
SYNOPSIS
.sp
.nf
integer function encode (str, max, fmt, a1, a2, ..., a10)
integer max
character str (max), fmt (ARB)
untyped a1, a2, ..., a10
.fi
.sp 2
DESCRIPTION
.sp
'Encode' is a memory-to-memory data format conversion routine,
patterned after the Fortran statement of the same name.
It takes a number of data items, converts them to character form
under the control of a format, and places the results in a
designated character string.
.sp
The first argument to 'encode' is the string to receive the converted
data, and the second argument is the maximum length of that string.
The third argument is the format which controls conversion (discussed
below).
The remaining arguments are data items to be converted.
The function return is the number of characters actually transferred
to the receiving string.
.sp
The format consists of a number of literal characters (to be inserted
into the receiving string without interpretation) and format codes
(which control conversion of data items).
Format codes are paired left-to-right with successive arguments that
are to be converted, just as in Fortran formatted I/O.
Format codes have the following general form:
.sp
.ti +10
* @[width] @[, @[base] @[, @[fill] ] ]  form
.sp
'Width' is a decimal integer whose absolute value is the minimum
number of character positions
in the receiving string that will be used to store the result
of the conversion.
If the value is zero, or insufficiently large to accomodate the
representation of the data item, as many character positions as
necessary, and no more, will be used.
If 'width' has a positive value, the converted string is given default
justification within the specified field width: numeric items
are right justified, and string items are left justified.  If 'width'
is negative, reverse justification is used.
.sp
'Fill' is a single character (blank by default) to be used to pad the
converted string to the desired width.  Depending on the justification
mode, enough instances of the
fill character are either prepended or appended
to the converted string to make up the difference between its width
and the specified field width.
.sp
'Base' is a decimal integer that is
interpreted differently according to whether the
item being converted is an integer or a string:
for integers, the absolute value of 'base' indicates the conversion
radix (in the range 2 to 16), and its sign indicates whether
the item being converted is to be treated as signed or unsigned
(negative values of 'base' yield unsigned conversions);
for character strings, 'base' indicates the maximum number of
characters that will be extracted from the string item and placed
into the receiving string.
.sp
'Form' is a single-letter format code that indicates the type of
conversion to be performed.
Since the interpretation of the other fields depends critically on
the form, each form will be discussed individually.
.sp
All three of the parameters 'width', 'base' and 'fill' may
be represented either
explicitly in the format string, or by the character "#", which
indicates that the value is to be taken from the current item
in the argument list.  This allows for a limited form of
run-time format specification.
.sp 2
.tc \
.in +10
.ta 6 8
.ne 5
.ti -7
.ul
Form\\Function
.sp
.ti -5
a\Interpret the corresponding argument as an address pointer with the
following format:
.sp
.ti +5
fr.ssss.wwwwww.bb
.sp
where 'f' is present if the pointer is invalid (i.e., would generate
a fault if referenced through), 'r' is the protection ring (0-3)
associated with the address, 'ssss' is the segment number
(0-7777 octal) of the address, 'wwwwww' is the word number
(0-177777 octal) of the address, and 'bb', if present, is the
bit offset (0-17 octal) of the address.
For more information on the significance of the various fields
of an address pointer, see Prime publication FDR-3059:
.ul
'Assembly Language Programmer's Guide'.
.sp
.ti -5
b\Interpret the corresponding argument as a Boolean (Fortran LOGICAL)
value.  The possible results are the strings "TRUE" and "FALSE",
where the number of characters transferred from the result to the
receiving string is determined by 'base'.  If 'base' is less than
1, only the "T" or the "F" is transferred.
.sp
.ti -5
c\The argument to be converted is an ASCII character, right-justified
and zero-filled in its word.
The 'base' specifier does not apply.
"*<width>c" is equivalent to "*<width>,1s".
.sp
.ti -5
d\Interpret the corresponding argument as a double-precision
floating-point number.
The 'base' specifier controls the output format.
If 'base' is greater than 14, the converted text will resemble
BASIC output:  up to six significant digits and no trailing zeros.
This is the default.
If 'base' is between 14 and 0, inclusive, the text will resemble
Fortran "F"-format output:  'base' digits to the right of the decimal
point.
If 'base' is negative, the text will resemble Fortran "E"-format
output:  scientific notation with "-'base'" digits to the right
of the decimal point.
(See the conversion routine 'dtoc' for further information on
real-to-character conversion.)
.sp
.ti -5
g\Change the current argument list pointer to 'width'.  This form
allows argument list elements to be reused for interpretation by
multiple format codes.
It is particularly useful when 'width' is specified as "#",
allowing the binding of argument list elements to format codes
to be deferred until run-time.
.sp
.ti -5
h\Interpret the current argument list element as a Hollerith
character string containing ASCII characters packed two-per-word.
The 'base' parameter determines the number of characters to
be extracted from the Hollerith string.
.sp
.ti -5
i\Interpret the corresponding argument as a single-precision integer.
The absolute value of the 'base' specifier gives the radix to be
used for conversion:  2 for binary, 3 for ternary, 16 for hexadecimal, etc.
If 'base' is positive, the integer is treated as a signed,
two's-complement number with 15 bits of precision, plus a sign bit,
with possible values in the range -32768 to +32767.
If 'base' is negative, the integer is treated as an unsigned binary
number with 16 bits of precision with possible values in the range
0 to 65535.
.sp
.ti -5
l\The corresponding argument is a double-precision (long) integer.
See the comments under "i" for an explanation of the action of
the 'base' specifier.
.sp
.ti -5
n\Insert 'width' NEWLINEs into the receiving string.
None of the arguments in the argument list is referenced.
If 'width' is less than 1, a single NEWLINE is inserted.
.sp
.ti -5
p\Interpret the corresponding argument as a period-terminated
packed character string (such as that generated by the Ratfor
"string"p construct).
The 'base' specifier is used as the maximum number of characters
to be copied.
.sp
.ti -5
r\Interpret the corresponding argument as a single-precision
floating-point number.
The comments under "d" above also apply to this form.
.sp
.ti -5
s\Interpret the corresponding argument as an unpacked EOS-terminated
character string (such as generated by "string"s in Ratfor, or as
returned by 'getlin').
The 'base' specifier gives the maximum number of characters to be
transferred.
.sp
.ti -5
t\Tab to the character position in the receiving string specified
by 'width'.  If the position is beyond the current end of the string,
pad the string to that position with instances of the 'fill' character.
The 'base' parameter is not used.
.sp
.ti -5
u\Set default values for the 'width', 'base' and 'fill' parameters.
Subsequent formatting codes that do not specify these values
will be interpreted as if the values specified here had been used.
.sp
.ti -5
v\Interpret the corresponding argument as a PL/I-style
varying character string.
The 'base' specifier once again gives the maximum number of characters
that will be transferred to the receiving string.
.sp
.ti -5
x\Transfer an entire field of fill characters to the receiving
string.
The 'base' specifier is unused.
The 'fill' specifier gives the character to be used for filling
the field; the default is a blank.
.sp
.ti -5
y\Interpret the corresponding argument as a YES/NO value such as those
used frequently throughout the Subsystem.  The possible results
are the strings "YES" and "NO".  The interpretation of the 'base'
parameter is similar to that used with the "b" form.
.sp 2
.in -10
The following forms are supported for compatibility with an
earlier version of the 'print' subroutine.
They should not be used in new code.
.sp 2
.in +10
.ti -5
f\Treat the argument as a double-precision floating-point number.
"F" is equivalent to "d" in every way.
.sp
.ti -5
j\The corresponding argument is a single-precision integer.
"*<width>,<base>j" is equivalent to "*<width>,-<base>i".
.sp
.ti -5
m\The corresponding argument is a long integer.
"*<width>,<base>m" is equivalent to "*<width>,-<base>l".
.sp 2
.in -10
Since 'encode' is a complex routine, a few samples may be helpful
in getting the hang of its use.
For example, the following call will convert two integers to decimal
free-form, with a comma and space between them:
.sp
.ti +5
len = encode (str, MAXLINE, "*i, *i"s, xcoord, ycoord)
.sp
These calls will print an "address" and the contents of the array 'memory'
at that address, in base 16 with zero fill:
.sp
.ti +5
len = encode (str, MAXLINE, "(*4,-16,0i)  *4,-16,0i*n"s,
.br
.ti +8
address, memory (address))
.br
.ti +5
call putlin (str, STDOUT)
.sp
A typical line of output from the above might be
.sp
.ti +5
(A000)  0002
.sp
A filename for use by 'open' might be composed like this:
.sp
.ti +5
call encode (name, MAXPATH, "=temp=/*s*2,,0i"s,
.br
.ti +8
username, sequence_number)
.sp
If 'username' was a string containing "SYSTEM" and 'sequence_number'
contained the integer 1, the previous call would set 'name' to the
string "=temp=/SYSTEM01".
.sp 2
IMPLEMENTATION
.sp
Since Fortran passes arguments to subroutines by reference,
'encode' does not need to declare the actual type of its arguments.
The type is determined by scanning the format string and associating
arguments with forms, left-to-right.
'Encode' calls various "something-to-character" conversion routines
to translate data from internal form to character string, which it
then simply places in the receiving string (checking to make sure
the length of the receiver is not exceeded).
'Encode' is not simple, and a reading of the code is necessary if
full understanding of its implementation is required.
.sp 2
ARGUMENTS MODIFIED
.sp
str
.sp 2
CALLS
.sp
atoc, gctoi, ctoc, ptoc, vtoc, gitoc, gltoc, rtoc, dtoc, remark
.sp 2
BUGS
.sp
No more than ten items may be encoded.
This routine is highly dependent on the ability of Prime's Fortran
to handle calls with varying numbers of arguments.
.sp 2
SEE ALSO
.sp
input (2), print (2), conversion routines ('cto?*' and '?*toc') (2)
#-t-  encode.doc                10906  local   01/05/81  21:31:31
#-h-  encode.r                  30729  local   01/05/81  21:31:34
# encode --- formatted memory-to-memory conversion routine
                                                                                
   integer function encode (str, max, fmt,
               a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)
   character str (ARB)
   integer max, fmt (ARB), a1 (ARB), a2 (ARB), a3 (ARB), a4 (ARB),
      a5 (ARB), a6 (ARB), a7 (ARB), a8 (ARB), a9 (ARB), a10 (ARB)
                                                                                
   integer i, arg, cur, max_cur, num, m, l,
      default_width, default_base, default_fill
   integer width, rjust, base, fill
   integer ptoc, ctoc, gitoc, gltoc, rtoc, dtoc, gctoi, vtoc, atoc, ctoi
   character term, tmp (MAXLINE)
                                                                                
   procedure interpret_format forward
   procedure get_num forward
   procedure convert_num forward
   procedure fill_field (len) forward
   procedure putstr forward
   procedure encode_packed forward
   procedure encode_string forward
   procedure encode_bool forward
   procedure encode_yesno forward
   procedure encode_tab forward
   procedure encode_addr forward
   procedure encode_varying forward
   procedure encode_integer forward
   procedure encode_longint forward
   procedure encode_real forward
   procedure encode_double forward
   procedure encode_newline forward
   procedure too_many_args forward
                                                                                
   define (putchar (x), {str (cur) = x; cur += 1})
                                                                                
   arg = 1
   cur = 1
   max_cur = 1
   default_width = 0
   default_base = 0
   default_fill = ' 'c
                                                                                
   for (i = 1; fmt (i) ~= EOS && cur < max; i += 1) {
                                                                                
      if (fmt (i) ~= FORMATFLAG)
         putchar (fmt (i))
                                                                                
      else {
         interpret_format
         select (fmt (i))
            when (GOTOFORM)
               arg = width
            when (DEFAULTFORM) {
               default_width = width
               default_base = base
               default_fill = fill
               }
            when (BOOLFORM)
               encode_bool
            when (YESNOFORM)
               encode_yesno
            when (TABFORM)
               encode_tab
            when (ADDRFORM)
               encode_addr
            when (PACKEDSTRINGFORM) {
               term = '.'c
               encode_packed
               }
            when (HOLLERITHFORM) {
               term = EOS
               encode_packed
               }
            when (STRINGFORM)
               encode_string
            when (CHARFORM) {          # compatibility only
               base = 1
               encode_string
               }
            when (VARYINGFORM)
               encode_varying
            when (INTFORM)
               encode_integer
            when (RCINTFORM) {         # compatibility only
               base = -base
               encode_integer
               }
            when (LONGINTFORM)
               encode_longint
            when (RCLONGINTFORM) {     # compatibility only
               base = -base
               encode_longint
               }
            when (REALFORM)
               encode_real
            when (FLOATFORM, DOUBLEFORM)
               encode_double
            when (NLINE)
               encode_newline
            when (FILLFORM)
               fill_field (width)
         else
            putchar (fmt (i))
         }
      }
                                                                                
   if (max_cur > cur)
      cur = max_cur
   str (cur) = EOS
   return (cur - 1)
                                                                                
                                                                                
   # interpret_format --- interpret and set the flags for the format
      procedure interpret_format {
                                                                                
         ### Get width:
         i += 1
         if (fmt (i) == ','c || IS_LETTER (fmt (i)))  # default
            width = default_width
         else if (fmt (i) == '#'c) {                  # indirect
            get_num
            i += 1
            width = num
            }
         else {                                       # specified
            convert_num
            width = num
            }
                                                                                
         if (width >= 0)               # Get rjust
            rjust = NO
         else {
            rjust = YES
            width = -width
            }
                                                                                
         ### Get base:
         if (fmt (i) ~= ','c)          # no more format specs
            base = default_base
         else {
            i += 1
            if (fmt (i) == ','c || IS_LETTER (fmt (i)))  # default
               base = default_base
            else if (fmt (i) == '#'c) {                  # indirect
               get_num
               i += 1
               base = num
               }
            else {                                       # specified
               convert_num
               base = num
               }
            }
                                                                                
         ### Get fill character:
         if (fmt (i) ~= ','c)          # no more format specs
            fill = default_fill
         elif (fmt (i + 1) ~= '#'c) {  # not indirect
            fill = fmt (i + 1)
            i += 2
            }
         elif (fmt (i + 2) == '#'c) {  # double "#"
            fill = '#'c
            i += 3
            }
         else {                        # indirect
            get_num
            fill = num
            i += 2
            }
                                                                                
         }
                                                                                
                                                                                
   # get_num --- grab a number from the argument list; put in 'num'
      procedure get_num {
                                                                                
         select (arg)
            when ( 1)  num = a1 (1)
            when ( 2)  num = a2 (1)
            when ( 3)  num = a3 (1)
            when ( 4)  num = a4 (1)
            when ( 5)  num = a5 (1)
            when ( 6)  num = a6 (1)
            when ( 7)  num = a7 (1)
            when ( 8)  num = a8 (1)
            when ( 9)  num = a9 (1)
            when (10)  num = a10 (1)
         else
            too_many_args
                                                                                
         arg += 1
                                                                                
         }
                                                                                
   # convert_num --- grab a number from the format string; put in 'num'
      procedure convert_num {
                                                                                
         bool neg
                                                                                
         neg = (fmt (i) == '-'c)
         if (fmt (i) == '+'c || fmt (i) == '-'c)
            i += 1
                                                                                
         num = ctoi (fmt, i)
         if (neg)
            num = - num
                                                                                
         }
                                                                                
                                                                                
   # putstr --- put the string in 'tmp' into 'str' at 'cur'
      procedure putstr {
                                                                                
         cur += ctoc (tmp, str (cur), max - cur + 1)
                                                                                
         }
                                                                                
                                                                                
   # fill_field --- output 'len' fill character, but don't overflow 'str'
      procedure fill_field (len) {
      integer len
                                                                                
         local i
         integer i
                                                                                
         for (i = 1; i <= len && cur < max; {cur += 1; i += 1})
            str (cur) = fill
                                                                                
         }
                                                                                
                                                                                
   # encode_packed --- encode a packed string
      procedure encode_packed {
                                                                                
         if (rjust == NO) {
            m = max - cur + 1
            if (base ~= 0 && base + 1 < m)
               m = base + 1
                                                                                
            select (arg)
               when ( 1)  l = ptoc (a1,  term, str (cur), m)
               when ( 2)  l = ptoc (a2,  term, str (cur), m)
               when ( 3)  l = ptoc (a3,  term, str (cur), m)
               when ( 4)  l = ptoc (a4,  term, str (cur), m)
               when ( 5)  l = ptoc (a5,  term, str (cur), m)
               when ( 6)  l = ptoc (a6,  term, str (cur), m)
               when ( 7)  l = ptoc (a7,  term, str (cur), m)
               when ( 8)  l = ptoc (a8,  term, str (cur), m)
               when ( 9)  l = ptoc (a9,  term, str (cur), m)
               when (10)  l = ptoc (a10, term, str (cur), m)
            else
               too_many_args
                                                                                
            cur += l
            fill_field (width - l)
            }
                                                                                
         else {
            if (base == 0 || base + 1 >= MAXLINE)
               m = MAXLINE
            else
               m = base + 1
                                                                                
            select (arg)
               when ( 1)  l = ptoc (a1,  term, tmp, m)
               when ( 2)  l = ptoc (a2,  term, tmp, m)
               when ( 3)  l = ptoc (a3,  term, tmp, m)
               when ( 4)  l = ptoc (a4,  term, tmp, m)
               when ( 5)  l = ptoc (a5,  term, tmp, m)
               when ( 6)  l = ptoc (a6,  term, tmp, m)
               when ( 7)  l = ptoc (a7,  term, tmp, m)
               when ( 8)  l = ptoc (a8,  term, tmp, m)
               when ( 9)  l = ptoc (a9,  term, tmp, m)
               when (10)  l = ptoc (a10, term, tmp, m)
            else
               too_many_args
                                                                                
            fill_field (width - l)
            putstr
            }
                                                                                
         arg += 1
                                                                                
         }
                                                                                
                                                                                
   # encode_string --- encode an EOS-terminated string
      procedure encode_string {
                                                                                
         if (rjust == NO) {
            m = max - cur + 1
            if (base ~= 0 && base + 1 < m)
               m = base + 1
                                                                                
            select (arg)
               when ( 1)  l = ctoc (a1,  str (cur), m)
               when ( 2)  l = ctoc (a2,  str (cur), m)
               when ( 3)  l = ctoc (a3,  str (cur), m)
               when ( 4)  l = ctoc (a4,  str (cur), m)
               when ( 5)  l = ctoc (a5,  str (cur), m)
               when ( 6)  l = ctoc (a6,  str (cur), m)
               when ( 7)  l = ctoc (a7,  str (cur), m)
               when ( 8)  l = ctoc (a8,  str (cur), m)
               when ( 9)  l = ctoc (a9,  str (cur), m)
               when (10)  l = ctoc (a10, str (cur), m)
            else
               too_many_args
                                                                                
            cur += l
            fill_field (width - l)
            }
                                                                                
         else {
            if (base == 0 || base + 1 >= MAXLINE)
               m = MAXLINE
            else
               m = base + 1
                                                                                
            select (arg)
               when ( 1)  l = ctoc (a1,  tmp, m)
               when ( 2)  l = ctoc (a2,  tmp, m)
               when ( 3)  l = ctoc (a3,  tmp, m)
               when ( 4)  l = ctoc (a4,  tmp, m)
               when ( 5)  l = ctoc (a5,  tmp, m)
               when ( 6)  l = ctoc (a6,  tmp, m)
               when ( 7)  l = ctoc (a7,  tmp, m)
               when ( 8)  l = ctoc (a8,  tmp, m)
               when ( 9)  l = ctoc (a9,  tmp, m)
               when (10)  l = ctoc (a10, tmp, m)
            else
               too_many_args
                                                                                
            fill_field (width - l)
            putstr
            }
                                                                                
         arg += 1
                                                                                
         }
                                                                                
                                                                                
   # encode_bool --- encode a boolean value
      procedure encode_bool {
                                                                                
         select (arg)
            when ( 1)  l = a1 (1)
            when ( 2)  l = a2 (1)
            when ( 3)  l = a3 (1)
            when ( 4)  l = a4 (1)
            when ( 5)  l = a5 (1)
            when ( 6)  l = a6 (1)
            when ( 7)  l = a7 (1)
            when ( 8)  l = a8 (1)
            when ( 9)  l = a9 (1)
            when (10)  l = a10 (1)
         else
            too_many_args
                                                                                
         if (rjust == NO) {
            m = max - cur + 1
            if (base ~= 0 && base + 1 < m)
               m = base + 1
                                                                                
            if (l ~= 0)    # true
               l = ctoc ("TRUE"s, str (cur), m)
            else
               l = ctoc ("FALSE"s, str (cur), m)
                                                                                
            cur += l
            fill_field (width - l)
            }
                                                                                
         else {
            if (base == 0 || base + 1 >= MAXLINE)
               m = MAXLINE
            else
               m = base + 1
                                                                                
            if (l == 1)    # true
               l = ctoc ("TRUE"s, tmp, m)
            else
               l = ctoc ("FALSE"s, tmp, m)
                                                                                
            fill_field (width - l)
            putstr
            }
                                                                                
         arg += 1
                                                                                
         }
                                                                                
                                                                                
   # encode_yesno --- encode a YES/NO value
      procedure encode_yesno {
                                                                                
         select (arg)
            when ( 1)  l = a1 (1)
            when ( 2)  l = a2 (1)
            when ( 3)  l = a3 (1)
            when ( 4)  l = a4 (1)
            when ( 5)  l = a5 (1)
            when ( 6)  l = a6 (1)
            when ( 7)  l = a7 (1)
            when ( 8)  l = a8 (1)
            when ( 9)  l = a9 (1)
            when (10)  l = a10 (1)
         else
            too_many_args
                                                                                
         if (rjust == NO) {
            m = max - cur + 1
            if (base ~= 0 && base + 1 < m)
               m = base + 1
                                                                                
            if (l == YES)
               l = ctoc ("YES"s, str (cur), m)
            elif (l == NO)
               l = ctoc ("NO"s, str (cur), m)
            else
               l = ctoc ("?"s, str (cur), m)
                                                                                
            cur += l
            fill_field (width - l)
            }
                                                                                
         else {
            if (base == 0 || base + 1 >= MAXLINE)
               m = MAXLINE
            else
               m = base + 1
                                                                                
            if (l == YES)
               l = ctoc ("YES"s, tmp, m)
            elif (l == NO)
               l = ctoc ("NO"s, tmp, m)
            else
               l = ctoc ("?"s, tmp, m)
                                                                                
            fill_field (width - l)
            putstr
            }
                                                                                
         arg += 1
                                                                                
         }
                                                                                
                                                                                
   # encode_tab --- handle tab formats
      procedure encode_tab {
                                                                                
         if (cur > max_cur)
            max_cur = cur
         for ( ; max_cur < width && max_cur < max; max_cur += 1)
            str (max_cur) = fill
         cur = width
                                                                                
         }
                                                                                
                                                                                
   # encode_addr --- encode an address
      procedure encode_addr {
                                                                                
         select (arg)
            when ( 1)  l = atoc (a1,  tmp, MAXLINE)
            when ( 2)  l = atoc (a2,  tmp, MAXLINE)
            when ( 3)  l = atoc (a3,  tmp, MAXLINE)
            when ( 4)  l = atoc (a4,  tmp, MAXLINE)
            when ( 5)  l = atoc (a5,  tmp, MAXLINE)
            when ( 6)  l = atoc (a6,  tmp, MAXLINE)
            when ( 7)  l = atoc (a7,  tmp, MAXLINE)
            when ( 8)  l = atoc (a8,  tmp, MAXLINE)
            when ( 9)  l = atoc (a9,  tmp, MAXLINE)
            when (10)  l = atoc (a10, tmp, MAXLINE)
         else
            too_many_args
                                                                                
         if (rjust == NO) {
            fill_field (width - l)
            putstr
            }
         else {
            putstr
            fill_field (width - l)
            }
         arg += 1
                                                                                
         }
                                                                                
                                                                                
   # encode_varying --- encode a PL/I varying string
      procedure encode_varying {
                                                                                
         if (rjust == NO) {
            m = max - cur + 1
            if (base ~= 0 && base + 1 < m)
               m = base + 1
                                                                                
            select (arg)
               when ( 1)  l = vtoc (a1,  str (cur), m)
               when ( 2)  l = vtoc (a2,  str (cur), m)
               when ( 3)  l = vtoc (a3,  str (cur), m)
               when ( 4)  l = vtoc (a4,  str (cur), m)
               when ( 5)  l = vtoc (a5,  str (cur), m)
               when ( 6)  l = vtoc (a6,  str (cur), m)
               when ( 7)  l = vtoc (a7,  str (cur), m)
               when ( 8)  l = vtoc (a8,  str (cur), m)
               when ( 9)  l = vtoc (a9,  str (cur), m)
               when (10)  l = vtoc (a10, str (cur), m)
            else
               too_many_args
                                                                                
            cur += l
            fill_field (width - l)
            }
                                                                                
         else {
            if (base == 0 || base + 1 >= MAXLINE)
               m = MAXLINE
            else
               m = base + 1
                                                                                
            select (arg)
               when ( 1)  l = vtoc (a1,  tmp, m)
               when ( 2)  l = vtoc (a2,  tmp, m)
               when ( 3)  l = vtoc (a3,  tmp, m)
               when ( 4)  l = vtoc (a4,  tmp, m)
               when ( 5)  l = vtoc (a5,  tmp, m)
               when ( 6)  l = vtoc (a6,  tmp, m)
               when ( 7)  l = vtoc (a7,  tmp, m)
               when ( 8)  l = vtoc (a8,  tmp, m)
               when ( 9)  l = vtoc (a9,  tmp, m)
               when (10)  l = vtoc (a10, tmp, m)
            else
               too_many_args
                                                                                
            fill_field (width - l)
            putstr
            }
                                                                                
         arg += 1
                                                                                
         }
                                                                                
                                                                                
   # encode_integer --- encode and justify an integer
      procedure encode_integer {
                                                                                
         select (arg)
            when ( 1)  l = gitoc (a1,  tmp, MAXLINE, base)
            when ( 2)  l = gitoc (a2,  tmp, MAXLINE, base)
            when ( 3)  l = gitoc (a3,  tmp, MAXLINE, base)
            when ( 4)  l = gitoc (a4,  tmp, MAXLINE, base)
            when ( 5)  l = gitoc (a5,  tmp, MAXLINE, base)
            when ( 6)  l = gitoc (a6,  tmp, MAXLINE, base)
            when ( 7)  l = gitoc (a7,  tmp, MAXLINE, base)
            when ( 8)  l = gitoc (a8,  tmp, MAXLINE, base)
            when ( 9)  l = gitoc (a9,  tmp, MAXLINE, base)
            when (10)  l = gitoc (a10, tmp, MAXLINE, base)
         else
            too_many_args
                                                                                
         if (rjust == NO) {
            fill_field (width - l)
            putstr
            }
         else {
            putstr
            fill_field (width - l)
            }
         arg += 1
                                                                                
         }
                                                                                
                                                                                
   # encode_longint --- encode and justify an long integer
      procedure encode_longint {
                                                                                
         select (arg)
            when ( 1)  l = gltoc (a1,  tmp, MAXLINE, base)
            when ( 2)  l = gltoc (a2,  tmp, MAXLINE, base)
            when ( 3)  l = gltoc (a3,  tmp, MAXLINE, base)
            when ( 4)  l = gltoc (a4,  tmp, MAXLINE, base)
            when ( 5)  l = gltoc (a5,  tmp, MAXLINE, base)
            when ( 6)  l = gltoc (a6,  tmp, MAXLINE, base)
            when ( 7)  l = gltoc (a7,  tmp, MAXLINE, base)
            when ( 8)  l = gltoc (a8,  tmp, MAXLINE, base)
            when ( 9)  l = gltoc (a9,  tmp, MAXLINE, base)
            when (10)  l = gltoc (a10, tmp, MAXLINE, base)
         else
            too_many_args
                                                                                
         if (rjust == NO) {
            fill_field (width - l)
            putstr
            }
         else {
            putstr
            fill_field (width - l)
            }
         arg += 1
                                                                                
         }
                                                                                
                                                                                
   # encode_real --- encode a single-precision floating point number
      procedure encode_real {
                                                                                
         if (base == 0)
            base = 100
                                                                                
         if (base > 14 || base < 0 || width == 0)
            m = MAXLINE - 1
         else
            m = base + 20
                                                                                
         select (arg)
            when ( 1)  l = rtoc (a1,  tmp, m, base)
            when ( 2)  l = rtoc (a2,  tmp, m, base)
            when ( 3)  l = rtoc (a3,  tmp, m, base)
            when ( 4)  l = rtoc (a4,  tmp, m, base)
            when ( 5)  l = rtoc (a5,  tmp, m, base)
            when ( 6)  l = rtoc (a6,  tmp, m, base)
            when ( 7)  l = rtoc (a7,  tmp, m, base)
            when ( 8)  l = rtoc (a8,  tmp, m, base)
            when ( 9)  l = rtoc (a9,  tmp, m, base)
            when (10)  l = rtoc (a10, tmp, m, base)
         else
            too_many_args
                                                                                
         if (rjust == YES) {
             if (base < 0 && tmp (1) ~= '-'c) {
               putchar (fill)
               l += 1
               }
            putstr
            fill_field (width - l)
            }
         else if (base >= 0) {
            fill_field (width - l)
            putstr
            }
         else {
            fill_field (width + base - 8)
            if (tmp (1) ~= '-'c) {
               putchar (fill)
               l += 1
               }
            putstr
            fill_field (-base + 7 - l)
            }
         arg += 1
                                                                                
         }
                                                                                
                                                                                
   # encode_double --- encode a double-precision floating point number
      procedure encode_double {
                                                                                
         if (base == 0)
            base = 100
                                                                                
         if (base > 14 || base < 0 || width == 0)
            m = MAXLINE - 1
         else
            m = base + 20
                                                                                
         select (arg)
            when ( 1)  l = dtoc (a1,  tmp, m, base)
            when ( 2)  l = dtoc (a2,  tmp, m, base)
            when ( 3)  l = dtoc (a3,  tmp, m, base)
            when ( 4)  l = dtoc (a4,  tmp, m, base)
            when ( 5)  l = dtoc (a5,  tmp, m, base)
            when ( 6)  l = dtoc (a6,  tmp, m, base)
            when ( 7)  l = dtoc (a7,  tmp, m, base)
            when ( 8)  l = dtoc (a8,  tmp, m, base)
            when ( 9)  l = dtoc (a9,  tmp, m, base)
            when (10)  l = dtoc (a10, tmp, m, base)
         else
            too_many_args
                                                                                
         if (rjust == YES) {
             if (base < 0 && tmp (1) ~= '-'c) {
               putchar (fill)
               l += 1
               }
            putstr
            fill_field (width - l)
            }
         else if (base >= 0) {
            fill_field (width - l)
            putstr
            }
         else {
            fill_field (width + base - 8)
            if (tmp (1) ~= '-'c) {
               putchar (fill)
               l += 1
               }
            putstr
            fill_field (-base + 7 - l)
            }
         arg += 1
                                                                                
         }
                                                                                
                                                                                
   # encode_newline --- insert a specified number of NEWLINES
      procedure encode_newline {
                                                                                
         repeat {
            putchar (NEWLINE)
            width -= 1
            } until (width <= 0 || cur >= max)
                                                                                
         }
                                                                                
                                                                                
   # too_many_args --- issue an error message for too many arguments
      procedure too_many_args {
                                                                                
         call remark ("in encode: attempt to use more than 10 fields"p)
         tmp (1) = EOS
                                                                                
         }
                                                                                
   undefine (putchar)
                                                                                
   end
#-t-  encode.r                  30729  local   01/05/81  21:31:34
#-t-  encode                    41899  local   01/05/81  21:38:37
#-h-  gcd                        1841  local   01/05/81  21:38:43
#-h-  gcd.doc                     537  local   01/05/81  21:31:51
.he 'GCD'03/23/80'GCD'
NAME
.sp
gcd - determine greatest common divisor of two integers
.sp 2
SYNOPSIS
.sp
.nf
long_int function gcd (x0, x1)
long_int x0, x1
.sp 2
.fi
DESCRIPTION
.sp
'Gcd' determines the greatest common divisor of the two long integers
specified as arguments.
The function return is the GCD (always positive).
.sp 2
IMPLEMENTATION
.sp
'Gcd' is a straightforward implementation of Euclid's algorithm.
.sp 2
BUGS
.sp
Behavior with nonpositive arguments may be considered irrational
by some.
.sp 2
SEE ALSO
.sp
invmod (4)
#-t-  gcd.doc                     537  local   01/05/81  21:31:51
#-h-  gcd.r                      1040  local   01/05/81  21:31:52
# gcd --- determine the greatest common divisor of two long integers
                                                                                
   long_int function gcd (x0, x1)
   long_int x0, x1
                                                                                
   long_int x_i, x_im1, x_im2       # for Euclid's algorithm
   long_int max0, min0, iabs
                                                                                
   x_im2 = max0 (x0, x1)
   x_im1 = min0 (x0, x1)
                                                                                
   repeat {
      if (x_im2 > x_im1)
         x_i = mod (x_im2, x_im1)
      else
         x_i = mod (x_im1, x_im2)
                                                                                
      x_im2 = x_im1
      x_im1 = x_i
                                                                                
      } until (x_i == 0)
                                                                                
   return (iabs (x_im2))
   end
#-t-  gcd.r                      1040  local   01/05/81  21:31:52
#-t-  gcd                        1841  local   01/05/81  21:38:43
#-h-  input                      6193  local   01/05/81  21:38:44
#-h-  input.doc                  3613  local   01/05/81  21:32:02
.he 'INPUT'03/30/80'INPUT'
NAME
.sp
input - easy to use formatted input routine
.sp 2
SYNOPSIS
.sp
.nf
integer function input (fd, fmt, a1, a2, ...)
file_des fd
packed_char fmt (ARB)   -or-   character fmt (ARB)
untyped a1, a2, ...
.fi
.sp 2
DESCRIPTION
.sp
'Input' is an input routine designed for ease of use.  It allows the
user to specify a file from which to read, a format to control input
from the file, and any number of items to be read.  The first argument
is the file descriptor of the file to be used for input.  The second
argument is a format string (discussed below).  The remaining
arguments (zero or more) are items to be input according to format
control.
The function return is the number of items set as a result of
the input request, or EOF if end-of-file was encountered.
.sp
The format string is a PERIOD-terminated packed character string
(such as that generated by the Ratfor "string"p  construct)
or an unpacked, EOS-terminated string
(such as that generated by the "string"s construct).
The format string
contains literal characters which will be output on
the user's terminal if the given input file refers to the terminal
device, and
format control directives consisting of an asterisk
(*) followed by a single lower-case letter describing the input
format for the next item in the argument list.
For a complete description of format control directives, please
see the Reference Manual entry for 'decode'.
.sp
Note that each call to 'input' causes one call to 'getlin' to
read the input text;
the text read is used to fill as many items as possible,
but any remaining text is lost.
This corresponds to BASIC and FORTRAN input procedures.
.sp
When erroneous input is detected, 'input' outputs the incorrect value
to the terminal, discards the rest of the input line,
and requests reentry of the incorrect value from the the terminal.
The user may type in the corrected item and continue normally.
.sp
Literal characters in the format will be ignored if
the file specified by 'fd' is not directed to the terminal.
This feature allows a program to prompt for input from
the terminal, but suppress the prompt for input from a
file.  Note that if no prompting at the terminal is
desired, literal characters should not be included
in the format string.
.sp
A few short examples may clarify the operation of 'input'.
To input two integers, with a prompt, one might use
.sp
.nf
.ti +5
junk = input (STDIN, "Enter i and j:  *i*i"s, i, j)
.fi
.sp
To input an array of double-precision floating point numbers,
one might use
.sp
.nf
.in +5
i = 1
while (input (file, "*d"s, array (i)) ~= EOF) {
   i += 1
   if (i > ARRAY_SIZE)
      call error ("too many numbers to handle"p)
   }
.sp
.fi
.in -5
.sp 2
IMPLEMENTATION
.sp
'Input' outputs prompt characters as it finds them in the format string,
calls 'getlin' to obtain a string of input from the proper file,
and then calls 'decode' to do the actual conversion of as many items
as possible.
Since the design of 'decode' was heavily influenced by the requirements
of 'input', careful reading of the code for both routines is
recommended.
.sp 2
ARGUMENTS MODIFIED
.sp
a1, a2, ....
.sp 2
CALLS
.sp
ptoc, ctoc, putch, getlin, decode, index, print, mapsu
.sp 2
BUGS
.sp
At most ten items may be input.
'Input' depends heavily on the ability of Prime's Fortran to handle
subroutines with varying numbers of arguments.
The ability to buffer some input text to satisfy later calls would
be nice, but is difficult without some static storage.
.sp 2
SEE ALSO
.sp
print (2), encode (2), decode (2), getlin (2),
conversion routines ('cto?*' and '?*toc') (2)
#-t-  input.doc                  3613  local   01/05/81  21:32:02
#-h-  input.r                    2316  local   01/05/81  21:32:03
# input --- semi-formatted input routine
                                                                                
   integer function input (fd, fmt, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)
   file_des fd
   character fmt (ARB)
   integer a1 (ARB), a2 (ARB), a3 (ARB), a4 (ARB), a5 (ARB),
           a6 (ARB), a7 (ARB), a8 (ARB), a9 (ARB), a10 (ARB)
                                                                                
   integer ap, sp, fp, ret, i
   integer getlin, decode, index
   file_des tf
   character str (MAXDECODE), tfmt (MAXDECODE)
   logical psw
                                                                                
   if (and (fmt (1), :177400) ~= 0)
      call ptoc (fmt, '.'c, tfmt, MAXDECODE)
   else
      call ctoc (fmt, tfmt, MAXDECODE)
                                                                                
   fp = 1
   ap = 1
                                                                                
   psw = (isatty (fd) ~= NO)
   tf = fd
                                                                                
   repeat {
      while (tfmt (fp) ~= FORMATFLAG) {
         if (psw)
            call putch (tfmt (fp), TTY)
         fp += 1
         }
                                                                                
      if (tfmt (fp) == EOS)
         break
                                                                                
      if (getlin (str, tf, MAXDECODE) == EOF)
         return (EOF)
                                                                                
      sp = 1
                                                                                
      select (decode (str, sp, tfmt, fp, ap,
                           a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
         when (OK)      # there's more format left
            tf = fd
         when (EOF)     # end of format
            break
         when (ERR) {   # error in field
            i = index (str (sp), NEWLINE)    # print only to first NEWLINE
            if (i ~= 0)
               str (sp + i - 1) = EOS
            call print (TTY, "Error: '*s' retype: "s, str (sp))
            tf = TTY
            }
         }
                                                                                
   return (ap - 1)
   end
#-t-  input.r                    2316  local   01/05/81  21:32:03
#-t-  input                      6193  local   01/05/81  21:38:44
#-h-  invmod                     2934  local   01/05/81  21:38:45
#-h-  invmod.doc                  616  local   01/05/81  21:32:33
.he 'INVMOD'03/23/80'INVMOD'
NAME
.sp
invmod - find inverse of an integer modulo another integer
.sp 2
SYNOPSIS
.sp
.nf
long_int function invmod (x1, x0)
long_int x1, x0
.sp 2
.fi
DESCRIPTION
.sp
'Invmod' is used to find the inverse of 'x1' in the ring of
integers modulo 'x0'.
The function return is the inverse if it could be found, or
ERR if 'x1' and 'x0' are not relatively prime.
.sp 2
IMPLEMENTATION
.sp
'Invmod' uses a variant of Euclid's greatest common divisor
algorithm.
.sp 2
BUGS
.sp
Rational behavior for nonpositive arguments has not been established.
.sp
Locally supported.
.sp 2
SEE ALSO
.sp
gcd (4)
#-t-  invmod.doc                  616  local   01/05/81  21:32:33
#-h-  invmod.r                   2054  local   01/05/81  21:32:34
# invmod --- find the inverse of an integer modulo another integer
#     ERR is returned if the given integers are not relatively prime
                                                                                
   long_int function invmod (x1, x0)
   long_int x1, x0
                                                                                
   long_int x_i, x_im1, x_im2       # for Euclid's algorithm
   long_int a_i, a_im1, a_im2,
            b_i, b_im1, b_im2       # for inverse determination
   long_int factor
                                                                                
   x_im2 = x0; a_im2 = 1; b_im2 = 0
   x_im1 = x1; a_im1 = 0; b_im1 = 1
                                                                                
   repeat {
                                                                                
      if (x_im2 > x_im1) {
         factor = x_im2 / x_im1     # integer division, remember
         x_i = mod (x_im2, x_im1)
         a_i = a_im2 - factor * a_im1
         b_i = b_im2 - factor * b_im1
         }
                                                                                
      else if (x_im1 > x_im2) {
         factor = x_im1 / x_im2
         x_i = mod (x_im1, x_im2)
         a_i = a_im1 - factor * a_im2
         b_i = b_im1 - factor * b_im2
         }
                                                                                
      else                          # egad, they're not relatively prime
         return (ERR)
                                                                                
      x_im2 = x_im1; a_im2 = a_im1; b_im2 = b_im1
      x_im1 = x_i; a_im1 = a_i; b_im1 = b_i
                                                                                
      } until (x_i == 1)
                                                                                
   if (b_i <= 0)
      return (b_i + x0)     # always return positive result
   return (b_i)
                                                                                
   end
#-t-  invmod.r                   2054  local   01/05/81  21:32:34
#-t-  invmod                     2934  local   01/05/81  21:38:45
#-h-  page                       7285  local   01/05/81  21:38:46
#-h-  page.doc                   2186  local   01/05/81  21:32:43
.he 'PAGE'05/01/80'PAGE'
NAME
.sp
page - display file on CRT terminal a page at a time
.sp 2
SYNOPSIS
.sp
.nf
subroutine page (fd, prompt, eprompt, lines)
file_des fd
character prompt (ARB), eprompt (ARB)
integer lines
.fi
.sp 2
DESCRIPTION
.sp
'Page' is used to display the contents of a disk file
on a CRT terminal, one screenful at a time.
In addition, it gives the user the ability to review or skip
any part of the file if desired.
.sp
The first argument is the file descriptor of a disk file to
be displayed.
The second argument is a format string (c.f. 'print', 'encode')
to be used for prompting the user after each screen.
If this format string contains a format code for an integer
(e.g. "*i") then the current page number will replace it in
the actual prompt.
The third argument is a format string to be used for prompting
the user when end-of-file is reached;
it may also contain a format code for the current page number.
The final argument is the number of lines on the CRT screen
being used;
if the value 0 is supplied, no pagination will be performed.
.sp
'Page' prompts the user after each screenful of output, then
awaits a command.
The following commands may be entered.
(Note that alphabetic commands may be entered in upper or lower
case.)
.sp
.in +15
.ta 11
.tc \
.ti -10
n\Exit immediately.
.ti -10
q\Exit immediately.
.ti -10
ctrl-c\Exit immediately.
.ti -10
y\Advance to the next page.
.ti -10
newline\Advance to the next page.
.ti -10
l<lines>\Set screen size to specified number of lines.
"l" or "l0" causes paging to end and continuous listing to
begin.
.ti -10
.\Redisplay current page.
.ti -10
^\Redisplay previous page.
.ti -10
<page>\Display specified page number.
.ti -10
+<pages>\Advance given number of pages (default 1).
.ti -10
-<pages>\Back up given number of pages (default 1).
.sp
.in -15
'Page' handles long lines correctly and does
not generate multiple prompts for files whose lengths are
integral multiples of the screen size.
.sp 2
CALLS
.sp
open, getlin, print, ctoi, putlin, rewind, close
.sp 2
BUGS
.sp
There is no easy way to change the page alignment, or to
scan for the first page containing a given pattern.
.sp 2
SEE ALSO
.sp
pg (1)
#-t-  page.doc                   2186  local   01/05/81  21:32:43
#-h-  page.r                     4835  local   01/05/81  21:32:44
# page --- display file on CRT terminal one page at a time
                                                                                
   integer function page (fd, prompt, eprompt, lines)
   file_des fd
   character prompt (ARB), eprompt (ARB)
   integer lines
                                                                                
   file_des tty
   file_des open
                                                                                
   integer len, pg, lpp, i
   integer getlin, ctoi
                                                                                
   character line (MAXLINE), resp (MAXLINE)
                                                                                
   procedure scan (disp) forward
   procedure goback (status) forward
   procedure reach (pnum) forward
                                                                                
   tty = open ("/dev/tty"s, READWRITE)
                                                                                
   pg = 0
   lpp = lines
                                                                                
   len = getlin (line, fd, 80)
   if (len == EOF)
      goback (OK)
                                                                                
   repeat {
      scan (YES)
      if (len == EOF) {
         if (lpp == 0)
            goback (OK)
         call print (tty, eprompt, pg)
         }
      else
         call print (tty, prompt, pg)
      if (getlin (resp, tty) == EOF) {
         call putch (NEWLINE, tty)
         goback (EOF)
         }
      for (i = 1; resp (i) == ' 'c; i += 1)
         ;
      select (resp (i))
         when ('n'c, 'q'c, 'N'c, 'Q'c)
            goback (OK)
         when ('y'c, 'Y'c, NEWLINE)
            if (len == EOF)
               goback (OK)
         when ('l'c, 'L'c) {
            i += 1
            lpp = ctoi (resp, i)
            }
         when ('.'c)
            reach (pg)
         when ('^'c)
            reach (pg - 1)
         when (SET_OF_DIGITS)
            reach (ctoi (resp, i))
         when ('+'c) {
            i += 1
            reach (pg + max0 (ctoi (resp, i), 1))
            }
         when ('-'c) {
            i += 1
            reach (pg - max0 (ctoi (resp, i), 1))
            }
      else
         reach (pg + 1)
      }
                                                                                
                                                                                
  # scan --- move over one page in the file, displaying it if desired
                                                                                
      procedure scan {
         integer disp
                                                                                
         local lc
         integer lc
                                                                                
         lc = 0
         if (disp == YES)
            call putlin (line, tty)
         lc += 1
         repeat {
            len = getlin (line, fd, 80)
            if (len == EOF)
               break
            if (lpp ~= 0) {
               if (lc + 1 > lpp)
                  break
               if (disp == YES)
                  call putlin (line, tty)
               lc += 1
               }
            else {
               if (disp == YES)
                  call putlin (line, tty)
               }
            }
         pg += 1
         }
                                                                                
                                                                                
  # reach --- get to a particular page in the file
      procedure reach {
         integer pnum
                                                                                
         local i
         integer i
                                                                                
         pnum = max0 (pnum, 0)
         if (pnum <= pg) {
            call rewind (fd)
            pg = 0
            len = getlin (line, fd, 80)
            for (i = 1; i < pnum && len ~= EOF; i += 1)
               scan (NO)
            }
         else
            for (i = pg + 1; i < pnum && len ~= EOF; i += 1)
               scan (NO)
         }
                                                                                
                                                                                
  # goback --- clean up tty file and return status to caller
      procedure goback (status) {
      integer status
                                                                                
         call close (tty)
         return (status)
         }
                                                                                
                                                                                
   end
#-t-  page.r                     4835  local   01/05/81  21:32:44
#-t-  page                       7285  local   01/05/81  21:38:46
#-h-  parscl                    11790  local   01/05/81  21:38:48
#-h-  parscl.doc                 4602  local   01/05/81  21:32:55
.he 'PARSCL'03/20/80'PARSCL'
NAME
.sp
parscl - parse command line arguments
.sp 2
SYNOPSIS
.sp
.nf
integer function parscl (str, buf)
character str (ARB), buf (MAXARGBUF)
.fi
.sp 2
DESCRIPTION
.sp
'Parscl' is used to parse most standard Subsystem command line
formats automatically.
It examines the command line, parses it according to instructions
present in its arguments, and makes the result available to the
user for further processing.
This processing is normally done with the aid of a set of standard
Subsystem macros, described below.
All arguments handled by 'parscl' are deleted from the command
line, so any remaining special cases may be handled by the user.
.sp
The argument 'str' is a string describing the syntax of the command
line.
The argument 'buf' is a one-dimensional array of characters
normally declared with the standard Subsystem macro 'ARG_DECL'.
The function return is OK if the command line parsed successfully,
ERR if an illegal option was seen or a required parameter was missing.
.sp
'Parscl' handles several types of arguments.
"Flag" arguments are single-letter flags, preceded by a hyphen or dash,
that have no parameters and may be grouped together in a single
argument; for example, "-a" or "-acq".
Arguments with parameters may have a string or integer value following
the single-letter, or present in the next argument in the command
line.
For example, "-p1", "-p 1", "-nfilename", or "-n filename".
Parameters for such arguments may be optional or required.
Finally, some arguments may be ignored entirely, while others may
not be allowable at all.
.sp
The argument 'str' contains a specification of allowable arguments
and their types.
Each specification consists of an option letter (case is ignored)
followed by a type in angle brackets.
The following types are allowable: 'f' or 'flag' for flag arguments,
'ign' or 'ignored' for ignorable arguments, 'na' for arguments
that are not allowable, 'oi' or 'opt int' for arguments with an
optional integer parameter, 'os' or 'opt str' for arguments with
an optional string parameter, 'ri' or 'req int' for arguments with
a required integer parameter, and 'rs' or 'req str' for arguments
with a required string parameter.
For example, a command with the syntax
.sp
.nf
.ti +5
-u <integer> [-l <integer>] [-i [<string>]]
.sp
.fi
would pass the following string to 'parscl':
.sp
.nf
.ti +5
u<req int> l<req int> i<opt str>
.sp
.fi
Order of arguments on the command line is unimportant, as well
as the case of the option letter used.
.sp
The command line is typically parsed and then examined with
a number of standard Subsystem macros.
'ARG_DECL' is used to declare the buffer required by 'parscl'.
'PARSE_COMMAND_LINE(str,msg)' is used to invoke 'parscl';
'str' is passed to 'parscl' as its first argument, and 'msg'
is passed to 'error' to be printed if the command line could
not be parsed.
For example, one might use
.sp
.nf
.in +5
PARSE_COMMAND_LINE ("u<ri>l<ri>i<os>"s,
   "usage:  cmd -u<upper> [-l<lower>] [-i[<file>]]"p)
.sp
.fi
.in -5
Once 'parscl' has been called in this manner, default values
for optional parameters may be supplied with 'ARG_DEFAULT_INT'
and 'ARG_DEFAULT_STR':
.sp
.nf
.in +5
ARG_DEFAULT_STR(i,"/dev/stdin1"s)
.sp
.fi
.in -5
One may test for the presence of an argument on the command line
with 'ARG_PRESENT', and retrieve argument values with
'ARG_VALUE' and 'ARG_TEXT':
.sp
.in +5
.nf
if (ARG_PRESENT (l))
   lower = ARG_VALUE (l)
else
   lower = 1
.sp
.in -5
.fi
Once as much as possible of this kind of argument parsing is
complete, the user may examine any remaining arguments by
fetching them with 'getarg'.
.sp 2
IMPLEMENTATION
.sp
'Parscl' scans the specification string and builds a 26 element
array.  Each element of the array corresponds to a letter A - Z
and contains an integer describing the type of argument expected
when that letter is encounterd.
.sp
Then 'parscl' scans the command line arguments, skipping those
that do not begin with a hyphen or have a letter as the
second character.  Arguments that begin with hyphens are
examined further.  If the letter in the second position of the
argument is to be
ignored, it is skipped.
Flag arguments are simply marked "present" in the argument buffer.
Values for string parameters are stored in the argument buffer for
later retrieval.
Values for integer parameters are converted with 'gctoi'
(thus allowing arbitrary radix representation) then stored in
the argument buffer.
.sp 2
CALLS
.sp
ctoc, delarg, gctoi, getarg, mapdn, strbsr
.sp 2
ARGUMENTS MODIFIED
.sp
buf
.sp 2
SEE ALSO
.sp
delarg (2), getarg (2), gfnarg (2)
#-t-  parscl.doc                 4602  local   01/05/81  21:32:55
#-h-  parscl.r                   6924  local   01/05/81  21:32:56
# parscl --- parse command line arguments
                                                                                
   integer function parscl (str, buf)
   character str (ARB), buf (MAXARGBUF)
                                                                                
   integer ap, bp, cp, sp, lc, i, l, k, v, at, status
   integer argtype (26)
   integer getarg, gctoi, ctoc, strbsr
   character arg (MAXARG)
   character mapdn
                                                                                
   string_table atx, att,
      / ARG_FLAG,             "f" _
      / ARG_FLAG,             "flag" _
      / ARG_IGNORED,          "ign" _
      / ARG_IGNORED,          "ignored" _
      / ARG_NOT_ALLOWED,      "na" _
      / ARG_OPT_INT,          "oi" _
      / ARG_OPT_INT,          "opt int" _
      / ARG_OPT_STR,          "opt str" _
      / ARG_OPT_STR,          "os" _
      / ARG_REQ_INT,          "req int" _
      / ARG_REQ_STR,          "req str" _
      / ARG_REQ_INT,          "ri" _
      / ARG_REQ_STR,          "rs"
                                                                                
   procedure get_argtype forward
   procedure next_argument forward
                                                                                
   do i = 1, 26
      argtype (i) = ARG_NOT_ALLOWED
                                                                                
  ### Parse the command string
   for (sp = 1; str (sp) ~= EOS; sp += 1)
      if (IS_LETTER (str (sp))) {
         lc = mapdn (str (sp)) - 'a'c + 1
         get_argtype
         argtype (lc) = at
         }
                                                                                
   ### Initialize the argument buffer
   do i = 1, 26
      buf (i) = ARG_NOT_SEEN
   do i = 27, 52
      buf (i) = 0
                                                                                
   ### Examine the argument list
   bp = 54
   ap = 1
   next_argument
   while (status ~= EOF) {
                                                                                
      l = mapdn (arg (cp)) - 'a'c + 1
      if (l < 1 || l > 26)
         return (ERR)
                                                                                
      buf (l) = ARG_LETTER_SEEN
                                                                                
      select (argtype (l))
                                                                                
         when (ARG_NOT_ALLOWED)
            return (ERR)
                                                                                
         when (ARG_IGNORED) {
            if (cp ~= 2)         # ignored args can only be first letters
               return (ERR)
            ap += 1
            next_argument
            }
                                                                                
         when (ARG_REQ_INT, ARG_OPT_INT)
            if (arg (cp + 1) == EOS) {
               call delarg (ap)
               if (getarg (ap, arg, MAXARG) ~= EOF
                     && arg (1) ~= '-'c && IS_DIGIT (arg (1))) {
                  cp = 1
                  buf (l + 26) = gctoi (arg, cp, 10)
                  if (arg (cp) ~= EOS)
                     return (ERR)
                  buf (l) = ARG_VALUE_SEEN
                  call delarg (ap)
                  }
               else if (argtype (l) == ARG_REQ_INT)
                  return (ERR)
               next_argument
               }
            else {
               cp += 1
               k = cp
               buf (l + 26) = gctoi (arg, cp, 10)
               if (k == cp && argtype (l) == ARG_REQ_INT) # no number here!
                  return (ERR)
               buf (l) = ARG_VALUE_SEEN
               }
                                                                                
         when (ARG_REQ_STR, ARG_OPT_STR)
            if (arg (cp + 1) == EOS) {
               call delarg (ap)
               if (getarg (ap, arg, MAXARG) ~= EOF && arg (1) ~= '-'c ) {
                  buf (l + 26) = bp
                  bp += 1 + ctoc (arg, buf (bp), MAXARGBUF - bp + 1)
                  call delarg (ap)
                  buf (l) = ARG_VALUE_SEEN
                  }
               else if (argtype (l) == ARG_REQ_STR)
                  return (ERR)
               next_argument
               }
            else {
               buf (l + 26) = bp
               bp += 1 + ctoc (arg (cp + 1), buf (bp), MAXARGBUF - bp + 1)
               buf (l) = ARG_VALUE_SEEN
               call delarg (ap)
               next_argument
               }
                                                                                
         when (ARG_FLAG)
            cp += 1
                                                                                
      if (arg (cp) == EOS) {  # bump the argument pointer if necessary
         call delarg (ap)
         next_argument
         }
                                                                                
      }
                                                                                
   buf (53) = bp
   return (OK)
                                                                                
   # get_argtype --- get and parse an argument type
      procedure get_argtype {
                                                                                
      local tbuf, tp, x
      character tbuf (MAXLINE)
      integer tp, x
                                                                                
      at = ARG_FLAG
                                                                                
      while (str (sp + 1) ~= '<'c && ~ IS_LETTER (str (sp + 1))
               && str (sp + 1) ~= EOS)
         sp += 1
                                                                                
      if (str (sp + 1) == '<'c) {
         tp = 1
         sp += 1
         while (str (sp + 1) ~= '>'c && str (sp + 1) ~= EOS) {
            tbuf (tp) = str (sp + 1)
            sp += 1
            tp += 1
            }
         tbuf (tp) = EOS
         x = strbsr (atx, att, 1, tbuf)
         if (x ~= EOF)
            at = att (atx (x))
         }
     }
                                                                                
                                                                                
   # next_argument --- obtain the next argument to parse
                                                                                
      procedure next_argument {
                                                                                
      status = getarg (ap, arg, MAXARG)
      while (status ~= EOF && (arg (1) ~= '-'c || ~ IS_LETTER (arg (2)))) {
         ap += 1
         status = getarg (ap, arg, MAXARG)
         }
      cp = 2
                                                                                
      }
   end
#-t-  parscl.r                   6924  local   01/05/81  21:32:56
#-t-  parscl                    11790  local   01/05/81  21:38:48
#-h-  prime                      2253  local   01/05/81  21:38:50
#-h-  prime.doc                  1074  local   01/05/81  21:33:06
.he 'PRIME'03/23/80'PRIME'
NAME
.sp
prime - retrieve the 'i'th prime number
.sp 2
SYNOPSIS
.sp
.nf
long_int function prime (i)
long_int i
.sp 2
.fi
DESCRIPTION
.sp
'Prime' is used to retrieve a specified prime number.
The argument is the ordinal of the prime number desired.
The function return is the specified prime.
For example, if 'i' is 1, the function return is 2;
if 'i' is 3, the function return is 5, etc.
.sp
'Prime' uses the table of prime numbers in the file
"=aux=/primes".
This file contains the prime numbers up to one million in
long-integer binary format.
If =aux=/primes is unreadable or if 'i' is less than one
or greater than 78498, the function return is zero.
.sp 2
IMPLEMENTATION
.sp
The file "=aux=/primes" is opened for reading.
The read/write pointer for the file is then moved to the
desired location and the prime number read.
The file is then closed.
.sp 2
CALLS
.sp
open, close, mapfd, Primos prwf$$
.sp 2
BUGS
.sp
Should probably raise cain if the prime numbers file is not
available, rather than meekly returning zero.
.sp
Locally supported.
#-t-  prime.doc                  1074  local   01/05/81  21:33:06
#-h-  prime.r                     915  local   01/05/81  21:33:07
# prime --- get the ith prime number (from a file of primes)
                                                                                
   long_int function prime (i)
   long_int i
                                                                                
   integer fd, junk
   integer open, mapfd
                                                                                
   if (i < 1 || i > LASTPRIME)
      return (0)
                                                                                
   fd = open ("=aux=/primes"s, READ)
   if (fd == ERR)
      return (0)
                                                                                
   call prwf$$ (KREAD + KPREA, mapfd (fd), loc (prime), 2, (i-1)*2,
      junk, junk)       # straight binary seek-and-read
   call close (fd)
                                                                                
   return
   end
#-t-  prime.r                     915  local   01/05/81  21:33:07
#-t-  prime                      2253  local   01/05/81  21:38:50
#-h-  print                      3879  local   01/05/81  21:38:51
#-h-  print.doc                  2565  local   01/05/81  21:33:16
.he 'PRINT'03/23/80'PRINT'
NAME
.sp
print - easy to use formatted output routine
.sp 2
SYNOPSIS
.sp
.nf
subroutine print (fd, fmt, a1, a2, ...)
file_des fd
character fmt (ARB)
untyped a1, a2, ...
.sp 2
.fi
DESCRIPTION
.sp
'Print' is an output routine designed for ease of use.
It allows the
user to specify a file on which to write, a format to control output to
the file, and any number of items to be printed.
The first argument is
the file descriptor of the file to be used for output.
The second argument
is a format string (discussed below).
The remaining arguments (zero or more)
are items to be output according to format control.
.sp
The format string is a EOS-terminated character string.  It contains
literal characters to be printed, as well as formatting control structures.
Formatting control structures consist of an asterisk (*) followed by a single
lower-case letter describing the action to be performed on the next argument
in the argument list.
For a complete list of the available formats, see the documentation
for the subroutine 'encode'.
.sp
Characters in the format string that are not associated with a format control
construct are output to the file without change.
.sp
A few examples may clarify the use of 'print'.
The following call will print two real numbers along with some
text for identification, followed by a newline, on standard output:
.sp
.nf
.ti +3
call print (STDOUT, "x = *r, y = *r*n"s, xcoord, ycoord)
.sp
.fi
This example shows how a line of output may be built up by successive
calls:
.sp
.nf
.in +5
call print (STDOUT, "absolute value = "s)
if (x < 0)
.ti +3
call print (STDOUT, "*i*n"s, -i)
else
.ti +3
call print (STDOUT, "*i*n"s, i)
.sp
.fi
.in -5
Further examples of formats may be found in the documentation for
'encode'.
.sp
Note:  an older version of 'print' accepted a packed, period-terminated
character string for the output format.
For the lifetime of Version 7, packed strings will still be accepted,
but all new code should use standard EOS-terminated strings.
.sp 2
IMPLEMENTATION
.sp
Since Fortran passes arguments to subroutines by reference, 'print' does not
need to know the actual type of its printable arguments.
A local character buffer is declared and passed along with the arguments
to 'encode', which does the actual work of conversion.
A call to 'putlin' then writes the result to the specified file.
.sp 2
CALLS
.sp
encode, ptoc, putlin
.sp 2
BUGS
.sp
At most ten items may be printed.
.sp 2
SEE ALSO
.sp
encode (2), input (2), putlin (2), other conversion routines
('?*toc' and 'cto?*') (2)
#-t-  print.doc                  2565  local   01/05/81  21:33:16
#-h-  print.r                    1050  local   01/05/81  21:33:17
# print --- easy-to-use semi-formatted print routine
                                                                                
   subroutine print (fd, fmt, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)
   integer fd, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10
   character fmt (ARB)
                                                                                
   character str (MAXPRINT), fmt1 (MAXLINE)
                                                                                
   if (and (fmt (1), :177400) == 0)
      call encode (str, MAXPRINT, fmt,
         a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)
                                                                                
   else {
      call ptoc (fmt, '.'c, fmt1, MAXLINE)
      call encode (str, MAXPRINT, fmt1,
         a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)
      }
                                                                                
   call putlin (str, fd)
                                                                                
   return
   end
#-t-  print.r                    1050  local   01/05/81  21:33:17
#-t-  print                      3879  local   01/05/81  21:38:51
#-h-  ptoc                       2940  local   01/05/81  21:38:52
#-h-  ptoc.doc                   1774  local   01/05/81  21:33:25
.he 'PTOC'03/23/80'PTOC'
NAME
.sp
ptoc - convert packed string to EOS-terminated string
.sp 2
SYNOPSIS
.sp
.nf
integer function ptoc (pstr, term, str, len)
packed_char pstr (ARB)
integer len
character term, str (len)
.sp 2
.fi
DESCRIPTION
.sp
'Ptoc' is used to convert packed character strings (e.g., Fortran
Hollerith literals) into the EOS-terminated unpacked form normally
used by all Subsystem routines.
The argument 'pstr' is the packed array to be converted.
'Term' is a "termination character"; if the termination character
appears unescaped in the packed string, then the unpacking operation
will be terminated.
(For example, most uses of packed strings in
.ul
Software Tools
included a period as a termination character, since in general
there is no other way for a subprogram to tell where a Hollerith
literal ends.)
The argument 'str' is an array to receive the unpacked string;
its maximum length is specified by the argument 'len'.
.sp
The function return is the length of the string in 'str'
(as usual, excluding the EOS character).
.sp
A note on a rather common use of 'ptoc':
Many Primos routines return packed character strings that do
not have a termination character, but do have a maximum
length.
When using 'ptoc' to convert the output of these routines, one
may use EOS as the termination character to obtain a fixed-length
result.
.sp 2
IMPLEMENTATION
.sp
'Ptoc' uses the standard Subsystem macro 'fpchar' to pull
successive characters from the packed array.
These are simply copied into the receiving string until the
string is full or an unescaped instance of the termination
character is found.
.sp 2
ARGUMENTS MODIFIED
.sp
str
.sp 2
SEE ALSO
.sp
other conversion routines ('cto?*' and '?*toc'), particularly
'ctop' (2), 'vtoc' (2), and 'ctov' (2)
#-t-  ptoc.doc                   1774  local   01/05/81  21:33:25
#-h-  ptoc.r                      902  local   01/05/81  21:33:26
# ptoc --- convert packed string to EOS-terminated string
                                                                                
   integer function ptoc (pstr, term, str, len)
   integer pstr (ARB), len
   character term, str (ARB)
                                                                                
   integer cp, i
                                                                                
   cp = 0
   for (i = 1; i < len; i += 1) {
      fpchar (pstr, cp, str (i))
      if (str (i) == ESCCHAR)
         fpchar (pstr, cp, str (i))
      elif (str (i) == term)
         break
      }
                                                                                
   str (i) = EOS
                                                                                
   return (i - 1)
                                                                                
   end
#-t-  ptoc.r                      902  local   01/05/81  21:33:26
#-t-  ptoc                       2940  local   01/05/81  21:38:52
#-h-  pwrmod                     1867  local   01/05/81  21:38:53
#-h-  pwrmod.doc                  743  local   01/05/81  21:33:56
.he 'PWRMOD'03/23/80'PWRMOD'
NAME
.sp
pwrmod - calculate an exponential modulo a given modulus
.sp 2
SYNOPSIS
.sp
.nf
long_int function pwrmod (p, e, n)
long_int p, e, n
.sp 2
.fi
DESCRIPTION
.sp
'Pwrmod' is used to perform an integer exponentiation in the ring of
integers modulo a given modulus.
The argument 'p' is the base of the expression, 'e' is the exponent,
and 'n' the modulus.
The function return is p**E (mod n).
.sp 2
IMPLEMENTATION
.sp
'Pwrmod' examines the exponent a bit a time,
squaring the intermediate result accumulated so far and
multiplying it by the base whenever the selected bit is a 1.
Each operation is performed modulo 'n', so that intermediate
results don't become excessively large.
.sp 2
SEE ALSO
.sp
invmod (4)
#-t-  pwrmod.doc                  743  local   01/05/81  21:33:56
#-h-  pwrmod.r                    860  local   01/05/81  21:33:56
# pwrmod --- calculate an exponential, modulo a given modulus
#     (function result is p ** E mod n)
                                                                                
   long_int function pwrmod (p, E, n)
   long_int p, E, n
                                                                                
   integer i
   long_int result
   define(bit_i,rt (rs (E, BITS_PER_LONG_WORD - i), 1)) # i'th bit of E
      # 'rt' is right-truncate, 'rs' is right-shift
                                                                                
   result = 1
   for (i = 1; i <= BITS_PER_LONG_WORD; i += 1)
      if (bit_i == 0)
         result = mod (result * result, n)
      else
         result = mod (mod (result * result, n) * p, n)
                                                                                
   return (result)
   end
#-t-  pwrmod.r                    860  local   01/05/81  21:33:56
#-t-  pwrmod                     1867  local   01/05/81  21:38:53
#-h-  rtoc                       3259  local   01/05/81  21:38:54
#-h-  rtoc.doc                   2404  local   01/05/81  21:34:05
.he 'RTOC'02/25/80'RTOC'
NAME
.sp
rtoc - convert real value to ASCII string
.sp 2
SYNOPSIS
.sp
.nf
integer function rtoc (v, str, w, d)
real v
character str (ARB)
integer w, d
.sp 2
.fi
DESCRIPTION
.sp
'Rtoc' converts the (single precision) real value in 'v' to a
character string in 'str'.  The length of the string is returned
as the value of 'rtoc'.
.sp
The values of 'w' and 'd' control the format of the converted
string.
Generally speaking, 'd' controls the number of decimal positions
or significant digits, and 'w' specifies the maximum length
of the field.
The following table explains the operation of
'rtoc' for different combinations of 'w' and 'd'.
(Fortran and Basic programmers take note:  d>12 corresponds
to Basic output, 12>=d>=0 corresponds to Fortran 'F' format,
and 0>d>=12 corresponds to Fortran 'E' format)
.sp
.in +18
.ta 12 19
.tc \
.ti -18
.ul
'd'\  'w'\       Result
.sp
.ti -18
d>12\w>16\If the value is in the range 1e7>v>=1e-2, it is
converted into a
BASIC-like fixed-point
with no trailing zeroes
after the decimal point.
Otherwise, it is converted into a
BASIC-like exponential format
with no trailing zeroes after the decimal point.
.sp
.ti -18
\w<=16\An error is returned.
.sp
.ti -18
12>=d>=0\-\If  possible, the
value
is converted to a fixed-point format with 'd'
positions after the decimal point.
Otherwise, it is converted to an exponential
format with as many significant digits as possible.
If 'w' is less than 8, an exponential conversion
is not possible and an error will be returned.
.sp
.ti -18
0>d>-12\w>d+6\The number is converted to an exponential
format with 'd' siginificant digits.
.sp
.ti -18
\w<=d+6\An error is returned.
.sp
.in -18
To return an error, 'rtoc' places a string consisting
of a single question mark in 'str'.
.sp
It should be noted that 'w' is roughly equivalent
to the 'size' parameter
in other conversion routines such as 'itoc' and 'ltoc';
'w' specifies
the maximum number of digits that may be produced.  Thus the
maximum number of characters returned in 'str' will never
exceed 'w + 1'.
.sp 2
IMPLEMENTATION
.sp
'Rtoc' converts the number to double precision and then
calls 'dtoc'.
'Rtoc' then returns whatever 'dtoc' returns.
.sp 2
ARGUMENTS MODIFIED
.sp
str
.sp 2
CALLS
.sp
dtoc
.sp 2
BUGS
.sp
Has been thoroughly tested, but has not stood the
test of time.
.sp 2
SEE ALSO
.sp
other conversion routines ('cto?*' and '?*toc') (2)
#-t-  rtoc.doc                   2404  local   01/05/81  21:34:05
#-h-  rtoc.r                      591  local   01/05/81  21:34:06
# rtoc --- convert single precision real to string
                                                                                
   integer function rtoc (val, str, w, d)
   real val
   character str (ARB)
   integer w, d
                                                                                
   integer dtoc
   longreal fval
                                                                                
   fval = val     # convert to double precision
   return (dtoc (fval, str, w, d))
                                                                                
   end
#-t-  rtoc.r                      591  local   01/05/81  21:34:06
#-t-  rtoc                       3259  local   01/05/81  21:38:54
#-h-  setcopy                    2086  local   01/05/81  21:38:55
#-h-  setcopy.doc                1112  local   01/05/81  21:34:14
.he 'SET_COPY'03/23/80'SET_COPY'
NAME
.sp
set_copy - make a copy of one set in another
.sp 2
SYNOPSIS
.sp
.nf
subroutine set_copy (source, destination)
pointer source, destination
.sp 2
.fi
DESCRIPTION
.sp
'Set_copy' duplicates one set in another.
For proper operation, the source set should be larger than or
equivalent in size to the destination set.
The source set is not altered by the copy operation.
.sp
All set manipulation routines make use of dynamic storage,
which must be initialized before use.
See 'dsinit' for further information.
.sp
Note that all set manipulation routines have long names.
To avoid unique name conflicts with other routines, any Ratfor
program using the set routines should include the following
statement:
.sp
.ti +5
include "=src=/lcl/lib/swtmlb.u/swtmlb_link.r.i"
.sp 2
IMPLEMENTATION
.sp
'Set_copy' uses the size field encoded in the first word of
each set to determine the number of words in the bit vector
to be copied.
A simple loop implements the copy.
.sp 2
BUGS
.sp
Should handle sets of different sizes properly.
.sp 2
SEE ALSO
.sp
other set operations ('set_?*') (4)
#-t-  setcopy.doc                1112  local   01/05/81  21:34:14
#-h-  setcopy.r                   710  local   01/05/81  21:34:15
# set_copy --- make a copy of one set in another
                                                                                
   subroutine set_copy (source, destination)
   pointer source, destination
                                                                                
   DS_DECL (Mem, ARB)
                                                                                
   integer i, size
                                                                                
   size = WORDS (min0 (Mem (source), Mem (destination)))
   do i = 1, size
      Mem (destination + i) = Mem (source + i)
                                                                                
   return
   end
#-t-  setcopy.r                   710  local   01/05/81  21:34:15
#-t-  setcopy                    2086  local   01/05/81  21:38:55
#-h-  setcreate                  2195  local   01/05/81  21:39:34
#-h-  setcreate.doc              1261  local   01/05/81  21:34:24
.he 'SET_CREATE'03/23/80'SET_CREATE'
NAME
.sp
set_create - generate a new, initially empty set
.sp 2
SYNOPSIS
.sp
.nf
pointer function set_create (set, size)
pointer set
integer size
.sp 2
.fi
DESCRIPTION
.sp
'Set_create' is used to create a Pascal-style bit vector representation
for a set of integers from 1 to 'size'.
The function return and the variable 'set' are set to the address
in dynamic storage of the newly-created set.
.sp
All set manipulation routines make use of dynamic storage,
which must be initialized before use.
See 'dsinit' for further information.
.sp
Note that all set manipulation routines have long names.
To avoid unique name conflicts with other routines, any Ratfor
program using the set routines should include the following
statement:
.sp
.ti +5
include "=src=/lcl/lib/swtmlb.u/swtmlb_link.r.i"
.sp 2
IMPLEMENTATION
.sp
'Set_create' calls 'dsget' to obtain a contiguous array of 16-bit
words that is large enough to represent a bit vector with 'size'
elements.
The first word of this array is set to 'size' for use by other
set manipulation routines.
A call to 'set_init' then insures that the new set is empty.
.sp 2
ARGUMENTS MODIFIED
.sp
set
.sp 2
CALLS
.sp
dsget, set_init
.sp 2
SEE ALSO
.sp
other set routines ('set_?*') (4)
#-t-  setcreate.doc              1261  local   01/05/81  21:34:24
#-h-  setcreate.r                 670  local   01/05/81  21:34:25
# set_create --- generate a new initially empty set
                                                                                
   pointer function set_create (set, size)
   pointer set
   integer size
                                                                                
   DS_DECL (Mem, ARB)
                                                                                
   pointer dsget
                                                                                
   set = dsget (WORDS (size) + 1)
   Mem (set) = size
   call set_init (set)
   return (set)
                                                                                
   end
#-t-  setcreate.r                 670  local   01/05/81  21:34:25
#-t-  setcreate                  2195  local   01/05/81  21:39:34
#-h-  setdelete                  2335  local   01/05/81  21:39:35
#-h-  setdelete.doc              1186  local   01/05/81  21:34:33
.he 'SET_DELETE'03/23/80'SET_DELETE'
NAME
.sp
set_delete - remove given element from a set
.sp 2
SYNOPSIS
.sp
.nf
subroutine set_delete (element, set)
integer element
pointer set
.sp 2
.fi
DESCRIPTION
.sp
'Set_delete' is used to remove a given element from a set.
The first argument is the element (an integer between one and
the maximum set size, inclusive), and the second is the set
from which it is to be removed.
.sp
All set manipulation routines make use of dynamic storage,
which must be initialized before use.
See 'dsinit' for further information.
.sp
Note that all set manipulation routines have long names.
To avoid unique name conflicts with other routines, any Ratfor
program using the set routines should include the following
statement:
.sp
.ti +5
include "=src=/lcl/lib/swtmlb.u/swtmlb_link.r.i"
.sp 2
IMPLEMENTATION
.sp
The element selected is compared to the size field of the set;
if invalid, 'set_delete' prints an error message and terminates
the program.
Otherwise, the position of the element in the bit vector is calculated,
and the bit is reset by straightforward logical operations.
.sp 2
CALLS
.sp
error
.sp 2
SEE ALSO
.sp
other set operations ('set_?*') (4)
#-t-  setdelete.doc              1186  local   01/05/81  21:34:33
#-h-  setdelete.r                 885  local   01/05/81  21:34:34
# set_delete --- remove given element from a set
                                                                                
   subroutine set_delete (element, set)
   integer element
   pointer set
                                                                                
   DS_DECL (Mem, ARB)
                                                                                
   integer word
   integer and, not, ls # ls is left-shift
                                                                                
   if (element > Mem (set) || element < 1)
      call error ("in set_delete:  element out of range.")
   word = set + (element - 1) / BITS_PER_WORD + 1
   Mem (word) = and (Mem (word),
      not (ls (1, BITS_PER_WORD - 1 - mod (element - 1, BITS_PER_WORD))))
                                                                                
   return
   end
#-t-  setdelete.r                 885  local   01/05/81  21:34:34
#-t-  setdelete                  2335  local   01/05/81  21:39:35
#-h-  setelemnt                  2403  local   01/05/81  21:39:36
#-h-  setelemnt.doc              1218  local   01/05/81  21:34:57
.he 'SET_ELEMENT'03/23/80'SET_ELEMENT'
NAME
.sp
set_element - see if a given element is in a set
.sp 2
SYNOPSIS
.sp
.nf
integer function set_element (element, set)
integer element
pointer set
.sp 2
.fi
DESCRIPTION
.sp
'Set_element' returns 1 if 'element' is a member of the set 'set',
0 otherwise.
The argument 'element' must be
an integer from 1 to the maximum size of the set, inclusive.
The argument 'set' must have been created beforehand with 'set_create'.
.sp
All set manipulation routines make use of dynamic storage,
which must be initialized before use.
See 'dsinit' for further information.
.sp
Note that all set manipulation routines have long names.
To avoid unique name conflicts with other routines, any Ratfor
program using the set routines should include the following
statement:
.sp
.ti +5
include "=src=/lcl/lib/swtmlb.u/swtmlb_link.r.i"
.sp 2
IMPLEMENTATION
.sp
If 'element' is not in the range of allowable set elements for the
given set, the program is terminated by a call to 'error'.
Otherwise, the location of the element in the bit vector is calculated,
and the function returns the value of the bit at that position.
.sp 2
CALLS
.sp
error
.sp 2
SEE ALSO
.sp
other set routines ('set_?*') (4)
#-t-  setelemnt.doc              1218  local   01/05/81  21:34:57
#-h-  setelemnt.r                 921  local   01/05/81  21:34:58
# set_element --- see if a given element is in a set
                                                                                
   integer function set_element (element, set)
   integer element
   pointer set
                                                                                
   DS_DECL (Mem, ARB)
                                                                                
   integer word
   integer and, ls   # ls is left-shift
                                                                                
   if (element > Mem (set) || element < 1)
      call error ("in set_element:  element out of range"p)
   word = set + (element - 1) / BITS_PER_WORD + 1
   if (and (Mem (word),
     ls (1, BITS_PER_WORD - 1 - mod (element - 1, BITS_PER_WORD))) ~= 0)
      return (PRESENT)
   return (NOT_PRESENT)
                                                                                
   end
#-t-  setelemnt.r                 921  local   01/05/81  21:34:58
#-t-  setelemnt                  2403  local   01/05/81  21:39:36
#-h-  setequal                   1776  local   01/05/81  21:39:37
#-h-  setequal.doc                965  local   01/05/81  21:35:06
.he 'SET_EQUAL'03/23/80'SET_EQUAL'
NAME
.sp
set_equal - return TRUE if two sets contain the same members
.sp 2
SYNOPSIS
.sp
.nf
logical function set_equal (set1, set2)
pointer set1, set2
.sp
.fi
DESCRIPTION
.sp
'Set_equal' determines if two sets contain the same members.
The sets need not be of equal length.
.sp
All set manipulation routines make use of dynamic storage,
which must be initialized before use.
See 'dsinit' for further information.
.sp
Note that all set manipulation routines have long names.
To avoid unique name conflicts with other routines, any Ratfor
program using the set routines should include the following
statement:
.sp
.ti +5
include "=src=/lcl/lib/swtmlb.u/swtmlb_link.r.i"
.sp 2
IMPLEMENTATION
.sp
'Set_equal' makes two calls on 'set_subset'.
The function return is true if 'set1' is a subset of 'set2'
and 'set2' is a subset of 'set1', false otherwise.
.sp 2
CALLS
.sp
set_subset
.sp 2
SEE ALSO
.sp
other set routines ('set_?*') (4)
#-t-  setequal.doc                965  local   01/05/81  21:35:06
#-h-  setequal.r                  547  local   01/05/81  21:35:07
# set_equal --- return .true. if two sets contain the same members
                                                                                
   logical function set_equal (set1, set2)
   pointer set1, set2
                                                                                
   logical set_subset
                                                                                
   return (set_subset (set1, set2) & set_subset (set2, set1))
                                                                                
   end
#-t-  setequal.r                  547  local   01/05/81  21:35:07
#-t-  setequal                   1776  local   01/05/81  21:39:37
#-h-  setinit                    1744  local   01/05/81  21:39:38
#-h-  setinit.doc                 864  local   01/05/81  21:35:16
.he 'SET_INIT'03/23/80'SET_INIT'
NAME
.sp
set_init - cause a set to be empty
.sp 2
SYNOPSIS
.sp
.nf
subroutine set_init (set)
pointer set
.sp 2
.fi
DESCRIPTION
.sp
'Set_init' initializes a set created by 'set_create'.
An initialized set is empty, i.e. contains no members.
.sp
All set manipulation routines make use of dynamic storage,
which must be initialized before use.
See 'dsinit' for further information.
.sp
Note that all set manipulation routines have long names.
To avoid unique name conflicts with other routines, any Ratfor
program using the set routines should include the following
statement:
.sp
.ti +5
include "=src=/lcl/lib/swtmlb.u/swtmlb_link.r.i"
.sp 2
IMPLEMENTATION
.sp
'Set_init' simply clears all elements of the bit vector
portion of the data structure addressed by its first
argument.
.sp 2
SEE ALSO
.sp
other set routines ('set_?*') (4)
#-t-  setinit.doc                 864  local   01/05/81  21:35:16
#-h-  setinit.r                   616  local   01/05/81  21:35:16
# set_init --- cause a set to be empty
                                                                                
   subroutine set_init (set)
   pointer set
                                                                                
   DS_DECL (Mem, ARB)
                                                                                
   integer i, size
                                                                                
   size = WORDS (Mem (set))
   do i = 1, size
      Mem (set + i) = 0
                                                                                
   return
   end
#-t-  setinit.r                   616  local   01/05/81  21:35:16
#-t-  setinit                    1744  local   01/05/81  21:39:38
#-h-  setinsert                  2407  local   01/05/81  21:39:39
#-h-  setinsert.doc              1271  local   01/05/81  21:35:25
.he 'SET_INSERT'03/23/80'SET_INSERT'
NAME
.sp
set_insert - place given element in a set
.sp 2
SYNOPSIS
.sp
.nf
subroutine set_insert (element, set)
integer element
pointer set
.sp 2
.fi
DESCRIPTION
.sp
'Set_insert' is the primary means of placing a given element
in a set.
'Element' must be an integer between one and the maximum size
of the set, inclusive;
'set' must be a pointer to a set data structure created by
'set_create'.
If it is within range, the given element is marked "present"
in the bit vector associated with the set.
.sp
All set manipulation routines make use of dynamic storage,
which must be initialized before use.
See 'dsinit' for further information.
.sp
Note that all set manipulation routines have long names.
To avoid unique name conflicts with other routines, any Ratfor
program using the set routines should include the following
statement:
.sp
.ti +5
include "=src=/lcl/lib/swtmlb.u/swtmlb_link.r.i"
.sp 2
IMPLEMENTATION
.sp
If the element is out of range, a call to 'error' is made to
inform the user and terminate the program.
Otherwise, the location of the element in the bit vector is determined
and a few logical operations are employed to set the selected bit.
.sp 2
CALLS
.sp
error
.sp 2
SEE ALSO
.sp
other set routines ('set_?*') (4)
#-t-  setinsert.doc              1271  local   01/05/81  21:35:25
#-h-  setinsert.r                 872  local   01/05/81  21:35:26
# set_insert --- place given element in a set
                                                                                
   subroutine set_insert (element, set)
   integer element
   pointer set
                                                                                
   DS_DECL (Mem, ARB)
                                                                                
   integer word
   integer or, ls    # ls is left-shift
                                                                                
   if (element > Mem (set) || element < 1)
      call error ("in set_insert:  element out of range"p)
   word = set + (element - 1) / BITS_PER_WORD + 1
   Mem (word) = or (Mem (word),
      ls (1, BITS_PER_WORD - 1 - mod (element - 1, BITS_PER_WORD)))
                                                                                
   return
   end
#-t-  setinsert.r                 872  local   01/05/81  21:35:26
#-t-  setinsert                  2407  local   01/05/81  21:39:39
#-h-  setinters                  2162  local   01/05/81  21:39:40
#-h-  setinters.doc              1110  local   01/05/81  21:35:35
.he 'SET_INTERSECT'03/23/80'SET_INTERSECT'
NAME
.sp
set_intersect - place intersection of two sets in a third
.sp 2
SYNOPSIS
.sp
.nf
subroutine set_intersect (set1, set2, destination)
pointer set1, set2, destination
.sp 2
.fi
DESCRIPTION
.sp
'Set_intersect' determines the intersection of the sets given as
its first two arguments and places that intersection in the set
specified by the third.
For proper operation, all three sets should be equal in size.
.sp
All set manipulation routines make use of dynamic storage,
which must be initialized before use.
See 'dsinit' for further information.
.sp
Note that all set manipulation routines have long names.
To avoid unique name conflicts with other routines, any Ratfor
program using the set routines should include the following
statement:
.sp
.ti +5
include "=src=/lcl/lib/swtmlb.u/swtmlb_link.r.i"
.sp 2
IMPLEMENTATION
.sp
Does a word-by-word logical 'and' of the bit vectors for the
first two sets, placing the result in the third.
.sp 2
BUGS
.sp
Should be fixed to work with sets of differing lengths.
.sp 2
SEE ALSO
.sp
other set routines ('set_?*') (4)
#-t-  setinters.doc              1110  local   01/05/81  21:35:35
#-h-  setinters.r                 788  local   01/05/81  21:35:36
# set_intersect --- place intersection of two sets in a third
                                                                                
   subroutine set_intersect (set1, set2, destination)
   pointer set1, set2, destination
                                                                                
   DS_DECL (Mem, ARB)
                                                                                
   integer i, size
   integer and
                                                                                
   size = WORDS (min0 (Mem (destination), min0 (Mem (set1), Mem (set2))))
   do i = 1, size
      Mem (destination + i) = and (Mem (set1 + i), Mem (set2 + i))
                                                                                
   return
   end
#-t-  setinters.r                 788  local   01/05/81  21:35:36
#-t-  setinters                  2162  local   01/05/81  21:39:40
#-h-  setremove                  1795  local   01/05/81  21:39:41
#-h-  setremove.doc              1068  local   01/05/81  21:36:10
.he 'SET_REMOVE'03/23/80'SET_REMOVE'
NAME
.sp
set_remove - remove a set that is no longer needed
.sp 2
SYNOPSIS
.sp
.nf
subroutine set_remove (set)
pointer set
.sp 2
.fi
DESCRIPTION
.sp
'Set_remove' reclaims the dynamic storage space used by
a set data structure.
It is the inverse of 'set_create'.
To prevent dynamic storage space from becoming irretrievably lost,
sets should always be removed by a call to 'set_remove' when they
are no longer needed.
.sp
All set manipulation routines make use of dynamic storage,
which must be initialized before use.
See 'dsinit' for further information.
.sp
Note that all set manipulation routines have long names.
To avoid unique name conflicts with other routines, any Ratfor
program using the set routines should include the following
statement:
.sp
.ti +5
include "=src=/lcl/lib/swtmlb.u/swtmlb_link.r.i"
.sp 2
IMPLEMENTATION
.sp
Calls 'dsfree' to throw away the storage space used by the
internal data structure.
.sp 2
CALLS
.sp
dsfree
.sp 2
SEE ALSO
.sp
other set routines ('set_?*') (4), dsinit (2), dsget (2), dsfree (2)
#-t-  setremove.doc              1068  local   01/05/81  21:36:10
#-h-  setremove.r                 463  local   01/05/81  21:36:11
# set_remove --- remove a set that is no longer needed
                                                                                
   subroutine set_remove (set)
                                                                                
   pointer set
                                                                                
   call dsfree (set)
                                                                                
   return
   end
#-t-  setremove.r                 463  local   01/05/81  21:36:11
#-t-  setremove                  1795  local   01/05/81  21:39:41
#-h-  setsubset                  2936  local   01/05/81  21:39:42
#-h-  setsubset.doc              1223  local   01/05/81  21:36:20
.he 'SET_SUBSET'03/23/80'SET_SUBSET'
NAME
.sp
set_subset - return TRUE if set1 is a subset of set2
.sp 2
SYNOPSIS
.sp
.nf
logical function set_subset (set1, set2)
pointer set1, set2
.sp 2
.fi
DESCRIPTION
.sp
'Set_subset' returns the logical value '.true.' if and only if
its first argument points to a set that is a subset of or equal
to the set pointed to by its second argument.
The sets need not be of equal length.
.sp
All set manipulation routines make use of dynamic storage,
which must be initialized before use.
See 'dsinit' for further information.
.sp
Note that all set manipulation routines have long names.
To avoid unique name conflicts with other routines, any Ratfor
program using the set routines should include the following
statement:
.sp
.ti +5
include "=src=/lcl/lib/swtmlb.u/swtmlb_link.r.i"
.sp 2
IMPLEMENTATION
.sp
If one set is larger than the other, it is checked to make sure
that none of the higher-order elements is present.
The subset condition is then true if and only if every element
of 'set1' is also an element of 'set2', a statement which can
be checked a word at a time with the proper logical operations.
.sp 2
CALLS
.sp
set_element
.sp 2
SEE ALSO
.sp
other set routines ('set_?*') (4)
#-t-  setsubset.doc              1223  local   01/05/81  21:36:20
#-h-  setsubset.r                1449  local   01/05/81  21:36:21
# set_subset --- return .true. if set1 is a subset of set2
                                                                                
   logical function set_subset (set1, set2)
   pointer set1, set2
                                                                                
   DS_DECL (Mem, ARB)
                                                                                
   integer i, size, size1, size2
   integer and, not, set_element
                                                                                
   size1 = Mem (set1)
   size2 = Mem (set2)
                                                                                
   if (size1 > size2)      # must have all larger elements NOT_PRESENT
      for (i = size2 + 1; i <= size1; i += 1)
         if (set_element (i, set1) == PRESENT)
            return (.false.)
                                                                                
   if (size2 > size1)      # same if right-hand set is larger
      for (i = size1 + 1; i <= size2; i += 1)
         if (set_element (i, set2) == PRESENT)
            return (.false.)
                                                                                
   size = WORDS (min0 (size1, size2))
   do i = 1, size
      if (and (Mem (set1 + i), not (Mem (set2 + i))) ~= 0)
         return (.false.)
                                                                                
   return (.true.)
   end
#-t-  setsubset.r                1449  local   01/05/81  21:36:21
#-t-  setsubset                  2936  local   01/05/81  21:39:42
#-h-  setsubtr                   2214  local   01/05/81  21:39:43
#-h-  setsubtr.doc               1155  local   01/05/81  21:36:29
.he 'SET_SUBTRACT'03/23/80'SET_SUBTRACT'
NAME
.sp
set_subtract - place difference of two sets in a third
.sp 2
SYNOPSIS
.sp
.nf
subroutine set_subtract (set1, set2, destination)
pointer set1, set2, destination
.sp 2
.fi
DESCRIPTION
.sp
'Set_subtract' performs the set subtraction operation, i.e.
places in the set 'destination' those elements of 'set1' that are
not in 'set2'.
For proper operation, all three sets should be the same size.
.sp
All set manipulation routines make use of dynamic storage,
which must be initialized before use.
See 'dsinit' for further information.
.sp
Note that all set manipulation routines have long names.
To avoid unique name conflicts with other routines, any Ratfor
program using the set routines should include the following
statement:
.sp
.ti +5
include "=src=/lcl/lib/swtmlb.u/swtmlb_link.r.i"
.sp 2
IMPLEMENTATION
.sp
Since sets are represented as bit vectors, the subtraction operation
is performed by logically 'and'ing the elements of the first set
with the negation of the elements of the second set.
.sp 2
BUGS
.sp
Should work with sets of differing sizes.
.sp 2
SEE ALSO
.sp
other set routines ('set_?*') (4)
#-t-  setsubtr.doc               1155  local   01/05/81  21:36:29
#-h-  setsubtr.r                  795  local   01/05/81  21:36:30
# set_subtract --- place difference of two sets in a third
                                                                                
   subroutine set_subtract (set1, set2, destination)
   pointer set1, set2, destination
                                                                                
   DS_DECL (Mem, ARB)
                                                                                
   integer i, size
   integer and, not
                                                                                
   size = WORDS (min0 (Mem (destination), min0 (Mem (set1), Mem (set2))))
   do i = 1, size
      Mem (destination + i) = and (Mem (set1 + i), not (Mem (set2 + i)))
                                                                                
   return
   end
#-t-  setsubtr.r                  795  local   01/05/81  21:36:30
#-t-  setsubtr                   2214  local   01/05/81  21:39:43
#-h-  setunion                   2033  local   01/05/81  21:39:44
#-h-  setunion.doc                998  local   01/05/81  21:36:39
.he 'SET_UNION'03/23/80'SET_UNION'
NAME
.sp
set_union - place union of two sets in a third
.sp 2
SYNOPSIS
.sp
.nf
subroutine set_union (set1, set2, destination)
pointer set1, set2, destination
.sp 2
.fi
DESCRIPTION
.sp
'Set_union' computes the union of 'set1' and 'set2', placing
the result in 'destination'.
For proper operation, all three sets should be the same size.
.sp
All set manipulation routines make use of dynamic storage,
which must be initialized before use.
See 'dsinit' for further information.
.sp
Note that all set manipulation routines have long names.
To avoid unique name conflicts with other routines, any Ratfor
program using the set routines should include the following
statement:
.sp
.ti +5
include "=src=/lcl/lib/swtmlb.u/swtmlb_link.r.i"
.sp 2
IMPLEMENTATION
.sp
The set union is computed by logically 'or'ing the bit vectors
associated with 'set1' and 'set2'.
.sp 2
BUGS
.sp
Should work with sets of differing sizes.
.sp 2
SEE ALSO
.sp
other set routines ('set_?*') (4)
#-t-  setunion.doc                998  local   01/05/81  21:36:39
#-h-  setunion.r                  771  local   01/05/81  21:36:40
# set_union --- place union of two sets in a third
                                                                                
   subroutine set_union (set1, set2, destination)
   pointer set1, set2, destination
                                                                                
   DS_DECL (Mem, ARB)
                                                                                
   integer i, size
   integer or
                                                                                
   size = WORDS (min0 (Mem (destination), min0 (Mem (set1), Mem (set2))))
   do i = 1, size
      Mem (destination + i) = or (Mem (set1 + i), Mem (set2 + i))
                                                                                
   return
   end
#-t-  setunion.r                  771  local   01/05/81  21:36:40
#-t-  setunion                   2033  local   01/05/81  21:39:44
#-h-  ssolve                     3457  local   01/05/81  21:39:45
#-h-  ssolve.doc                  161  local   01/05/81  21:36:48
.he 'SSOLVE'08/24/80'SSOLVE'
NAME
.sp
ssolve - solve systems of simultaneous linear equations
.sp 2
DESCRIPTION
.sp
Unavailable at present; please see the code.
#-t-  ssolve.doc                  161  local   01/05/81  21:36:48
#-h-  ssolve.r                   3032  local   01/05/81  21:36:49
# ssolve --- Gauss-Jordan elimination method for solving linear systems
                                                                                
#     Solves the set of simultaneous equations ax = b with N variables
#        (N must be less than or equal to 100)
#     Returns solution in x, determinant of a as function value
#     a and b are destroyed
                                                                                
#     From Hawgood, Numerical Methods in Algol, McGraw-Hill, 1965,
#        pp 87-88
                                                                                
   define (MAXN, 100)
                                                                                
   long_real function ssolve (a, upba, b, x, N)
   integer upba, N
   long_real a (upba, upba), b (N), x (N)
                                                                                
   integer pivrow (MAXN), pivcol (MAXN), i, j, I, J, ic, jc, io, jo, n
                                                                                
   long_real pivot, pivprod, mult, comp
                                                                                
   pivprod = 1.0d0
                                                                                
   for (i = 1; i <= N; i += 1) {
      pivrow (i) = i
      pivcol (i) = i
      }
                                                                                
   for (n = 1; n <= N; n += 1) {
                                                                                
      pivot = a (pivrow (n), pivcol (n))
      io = n
      jo = n
      I = pivrow (n)
      J = pivcol (n)
      for (i = n; i <= N; i += 1)
         for (j = n; j <= N; j += 1) {
            ic = pivrow (i)
            jc = pivcol (j)
            comp = a (ic, jc)
            if (dabs (comp) > dabs (pivot)) {
               pivot = comp
               I = ic
               io = i
               J = jc
               jo = j
               }
            }
      pivrow (io) = pivrow (n)
      pivcol (jo) = pivcol (n)
      pivrow (n) = I
      pivcol (n) = J
                                                                                
      if (pivot == 0.0d0)
         return (0.0d0)       # singular!
                                                                                
      b (I) /= pivot
      pivprod *= pivot
      for (j = n + 1; j <= N; j += 1) {
         jc = pivcol (j)
         a (I, jc) /= pivot
         }
      for (i = 1; i <= N; i += 1)
         if (i ~= I) {
            mult = a (i, J)
            b (i) -= b (I) * mult
            for (j = n + 1; j <= N; j += 1) {
               jc = pivcol (j)
               a (i, jc) -= a (I, jc) * mult
               }
         }
      }
                                                                                
   for (i = 1; i <= N; i += 1)
      x (pivcol (i)) = b (pivrow (i))
                                                                                
   return (pivprod)
   end
#-t-  ssolve.r                   3032  local   01/05/81  21:36:49
#-t-  ssolve                     3457  local   01/05/81  21:39:45
#-h-  vtoc                       2156  local   01/05/81  21:39:46
#-h-  vtoc.doc                    970  local   01/05/81  21:36:58
.he 'VTOC'03/23/80'VTOC'
NAME
.sp
vtoc - convert PL/I varying string to EOS-terminated string
.sp 2
SYNOPSIS
.sp
.nf
integer function vtoc (var, str, len)
integer var (ARB), len
character str (ARB)
.sp 2
.fi
DESCRIPTION
.sp
'Vtoc' is used to convert a PL/I character-varying string into a
standard Subsystem EOS-terminated string.
The first argument is the character-varying string to be converted;
the second is a string to receive the result;
the third is the maximum length of the result string.
The function return is the number of characters in the result string
after the conversion.
.sp 2
IMPLEMENTATION
.sp
'Vtoc' uses the standard Subsystem macro 'fpchar' to pull characters
from the PL/I string one at a time, and place them in the result
string.
Conversion stops when the result string fills or when all the
characters in the PL/I string have been moved.
.sp 2
ARGUMENTS MODIFIED
.sp
str
.sp 2
SEE ALSO
.sp
other conversion routines ('cto?*' and '?*toc') (2)
#-t-  vtoc.doc                    970  local   01/05/81  21:36:58
#-h-  vtoc.r                      922  local   01/05/81  21:36:59
# vtoc --- convert varying string to EOS-terminated string
                                                                                
   integer function vtoc (var, str, len)
   integer var (ARB), len
   character str (ARB)
                                                                                
   integer cp, max, i
                                                                                
   cp = CHARS_PER_WORD
   max = var (1) + 1
   if (len < max)
      max = len
                                                                                
   for (i = 1; i < max; i += 1)
      fpchar (var, cp, str (i))
                                                                                
   str (i) = EOS
                                                                                
   return (i - 1)
                                                                                
   end
#-t-  vtoc.r                      922  local   01/05/81  21:36:59
#-t-  vtoc                       2156  local   01/05/81  21:39:46
#-h-  argudefs                   2376  local   01/05/81  21:39:46
# arg_def.r.i --- defines for use with the command line parser
                                                                                
   define (ARG_NOT_ALLOWED,1)
   define (ARG_FLAG,2)
   define (ARG_OPT_INT,3)
   define (ARG_REQ_INT,4)
   define (ARG_OPT_STR,5)
   define (ARG_REQ_STR,6)
   define (ARG_IGNORED,7)
                                                                                
   define (ARG_NOT_SEEN,0)
   define (ARG_LETTER_SEEN,1)
   define (ARG_VALUE_SEEN,2)
                                                                                
   define (MAXARGBUF, 200)
   define (ARG_BUF, a$buf)
   define (ARG_DECL, integer ARG_BUF (MAXARGBUF))
                                                                                
   define (ARG_BPTR, ARG_BUF (53))
   define (ARG_VALUE (ch), ARG_BUF ('ch'c - 'a'c + 27))
   define (ARG_VALUE_I (i), ARG_BUF (i + 26))
   define (ARG_TEXT (ch), ARG_BUF (ARG_BUF ('ch'c - 'a'c + 27)))
   define (ARG_TEXT_I (i), ARG_BUF (ARG_BUF (i + 26)))
                                                                                
   define (ARG_PRESENT (ch), (ARG_BUF ('ch'c - 'a'c + 1) ~= ARG_NOT_SEEN))
   define (ARG_PRESENT_I (i), (ARG_BUF (i) ~= ARG_NOT_SEEN))
                                                                                
   define (ARG_DEFAULT_INT (ch, val), {
      if (ARG_BUF ('ch'c - 'a'c + 1) ~= ARG_VALUE_SEEN)
         ARG_VALUE (ch) = val
      })
   define (ARG_DEFAULT_INT_I (i, val), {
      if (ARG_BUF (i) ~= ARG_VALUE_SEEN)
         ARG_VALUE_I (i) = val
      })
                                                                                
   define (ARG_DEFAULT_STR (ch, str),{
         integer ctoc
         if (ARG_BUF ('ch'c - 'a'c + 1) ~= ARG_VALUE_SEEN) {
            ARG_VALUE (ch) = ARG_BPTR
            ARG_BPTR += 1 + ctoc (str, ARG_BUF (ARG_BPTR), MAXARGBUF)
            }
         })
   define (ARG_DEFAULT_STR_I (i, str),{
         integer ctoc
         if (ARG_BUF (i) ~= ARG_VALUE_SEEN) {
            ARG_VALUE_I (i) = ARG_BPTR
            ARG_BPTR += 1 + ctoc (str, ARG_BUF (ARG_BPTR), MAXARGBUF)
            }
         })
                                                                                
   define (PARSE_COMMAND_LINE (str, msg), {
         integer parscl
         if (parscl (str, ARG_BUF) == ERR)
            call error (_msg)})
#-t-  argudefs                   2376  local   01/05/81  21:39:46
#-h-  math.lbl                  20851  local   01/05/81  21:41:09
#-h-  math.doc                   7522  local   01/05/81  17:30:47
.pl 61
.bp 1
.in 0
.rm 70
.he 'DTOC'08/31/79'DTOC'
.fo ''-#-''
.in 8
.ti -8
.bd
NAME
.br
dtoc - convert double precision number to character string
.sp
.ti -8
.bd
SYNOPSIS
.br
stat = dtoc (dbl, str, p, w)
.sp
.ti -8
.bd
DESCRIPTION
.br
This routine converts a double precision floating point number to
a string of characters.  'w' is the maximum length of the
output string not including the EOS.  'p' specifies the number of digits
to the right of the decimal point on output.  If 'p' is negative the output
is forced to exponential notation with '|p|' significant digits.
If more than 'w' characters are needed,
the output string is truncated and rounded to fit,
forced to exponential notation, or filled
with 'w' asterisks (to indicate overflow), in that order.
The function returns the length of the output string on sucessful
conversions and "ERR" otherwise.
.sp
.ti -8
.bd
SEE ALSO
.br
ctod, ctoi, putdbl
.sp
.ti -8
.bd
DIAGNOSTICS
.br
If space required for the output string exceeds given space ('w'), a
string of 'w' asterisks is returned.
.sp
.ti -8
.bd
AUTHOR
.br
John Chong, Lawrence Berkeley Laboratory
.sp
.ti -8
.bd
BUGS
.br
The 15th significant digit may not be correct due to floating point
arithmetic inaccuracy.
.pl 61
.bp 1
.in 0
.rm 70
.he 'CTOD'08/31/79'CTOD'
.fo ''-#-''
.in 8
.ti -8
.bd
NAME
.br
ctod - convert character string to double precision number
.sp
.ti -8
.bd
SYNOPSIS
.br
stat = ctod (str, dbl)
.sp
.ti -8
.bd
DESCRIPTION
.br
This routine converts a string of digits into a double precision
number.  'str' is the input string containing the digits.  The
input may be of the form  (12.34),  (12.34E35), or  (12.34D35).
'dbl' is the converted numeric output.  All leading and trailing
blanks are ignored; the first illegal character (i.e., not 0-9,
decimal point, E, D, +, or -) seen terminates the scan of string
'str'.  The function returns "YES" on sucessful conversions and
"ERR" otherwise.  The number 'dbl' returned is meaningless on
"ERR" conditions and should be ignored.
.sp
.ti -8
.bd
SEE ALSO
.br
dtoc, itoc, ctoi
.sp
.ti -8
.bd
DIAGNOSTICS
.br
"ERR" is returned if 'str' does not represent a legitimate number
(e.g., 67.88.66) or on exponent overflow / underflow.
.sp
.ti -8
.bd
AUTHOR
.br
John Chong, Lawrence Berkeley Laboratory
.sp
.ti -8
.bd
BUGS
.br
The 15th significant digit may not be correct due to floating point
arithmetic inaccuracy.
.pl 61
.bp 1
.in 0
.rm 70
.he 'PUTDBL'08/31/79'PUTDBL'
.fo ''-#-''
.in 8
.ti -8
.bd
NAME
.br
putdbl - write double precision floating point number to file
.sp
.ti -8
.bd
SYNOPSIS
.br
call putdbl (d, p, w, fc)
.sp
.ti -8
.bd
DESCRIPTION
.br
This routine writes onto the file 'fc' the double precision floating point
number 'd' as a string of characters.  'w' is the maximum length of the
output string not including the EOS.  'p' specifies the number of digits
to the right of the decimal point on output.  If 'p' is negative the output
is forced to exponential notation with '|p|' significant digits.
When fewer than 'w' characters are needed, blanks are inserted to the left
to make up the count.  However if more than 'w' characters are needed,
the output string is truncated and rounded to fit,
forced to exponential notation, or filled
with 'w' asterisks (to indicate overflow), in that order.
'fc' is the logical unit identifier
for the output file (usually returned from a call to OPEN).
.sp
.ti -8
.bd
SEE ALSO
.br
dtoc, ctod, putdec
.sp
.ti -8
.bd
DIAGNOSTICS
.br
If space required for the output string exceeds given space ('w'), a
string of 'w' asterisks is written.
.sp
.ti -8
.bd
AUTHOR
.br
John Chong, Lawrence Berkeley Laboratory
.sp
.ti -8
.bd
BUGS
.br
The 15th significant digit may not be correct due to floating point
arithmetic inaccuracy.
.pl 61
.bp 1
.in 0
.rm 70
.he 'RTOC'08/31/79'RTOC'
.fo ''-#-''
.in 8
.ti -8
.bd
NAME
.br
rtoc - convert single precision number to character string
.sp
.ti -8
.bd
SYNOPSIS
.br
stat = rtoc (real, str, p, w)
.sp
.ti -8
.bd
DESCRIPTION
.br
This routine converts a single precision floating point number to
a string of characters.  'w' is the maximum length of the
output string not including the EOS.  'p' specifies the number of digits
to the right of the decimal point on output.  If 'p' is negative the output
is forced to exponential notation with '|p|' significant digits.
If more than 'w' characters are needed,
the output string is truncated and rounded to fit,
forced to exponential notation, or filled
with 'w' asterisks (to indicate overflow), in that order.
The function returns the length of the output string on sucessful
conversions and "ERR" otherwise.
.sp
.ti -8
.bd
SEE ALSO
.br
dtoc, itoc, putreal, putdbl
.sp
.ti -8
.bd
DIAGNOSTICS
.br
If space required for the output string exceeds given space ('w'), a
string of 'w' asterisks is returned.
.sp
.ti -8
.bd
AUTHOR
.br
John Chong, Lawrence Berkeley Laboratory
.sp
.ti -8
.bd
BUGS
.br
The 7th significant digit may not be correct due to floating point
arithmetic inaccuracy.
.pl 61
.bp 1
.in 0
.rm 70
.he 'CTOR'08/31/79'CTOR'
.fo ''-#-''
.in 8
.ti -8
.bd
NAME
.br
ctor - convert character string to single precision number
.sp
.ti -8
.bd
SYNOPSIS
.br
stat = ctor (str, real)
.sp
.ti -8
.bd
DESCRIPTION
.br
This routine converts a string of digits into a single precision
number.  'str' is the input string containing the digits.  The
input may be of the form  (12.34),  (12.34E35), or  (12.34D35).
'real' is the converted numeric output.  All leading and trailing
blanks are ignored; the first illegal character (i.e., not 0-9,
decimal point, E, D, +, or -) seen terminates the scan of string
'str'.  The function returns "YES" on sucessful conversions and
"ERR" otherwise.  The number 'real' returned is meaningless on
"ERR" conditions and should be ignored.
.sp
.ti -8
.bd
SEE ALSO
.br
ctod, dtoc, ctoi
.sp
.ti -8
.bd
DIAGNOSTICS
.br
"ERR" is returned if 'str' does not represent a legitimate number
(e.g., 67.88.66) or on an exponent overflow/underflow.
.sp
.ti -8
.bd
AUTHOR
.br
John Chong, Lawrence Berkeley Laboratory
.sp
.ti -8
.bd
BUGS
.br
The 7th significant digit may not be correct due to floating point
arithmetic inaccuracy.
.pl 61
.bp 1
.in 0
.rm 70
.he 'PUTREAL'08/31/79'PUTREAL'
.fo ''-#-''
.in 8
.ti -8
.bd
NAME
.br
putreal - write single precision floating point number to file
.sp
.ti -8
.bd
SYNOPSIS
.br
call putreal (r, p, w, fc)
.sp
.ti -8
.bd
DESCRIPTION
.br
This routine writes onto the file 'fc' the single precision floating point
number 'r' as a string of characters.  'w' is the maximum length of the
output string not including the EOS.  'p' specifies the number of digits
to the right of the decimal point on output.  If 'p' is negative the output
is forced to exponential notation with '|p|' significant digits.
When fewer than 'w' characters are needed, blanks are inserted to the left
to make up the count.  However if more than 'w' characters are needed,
the output string is truncated and rounded to fit,
forced to exponential notation, or filled
with 'w' asterisks (to indicate overflow), in that order.
'fc' is the logical unit identifier
for the output file (usually returned from a call to OPEN).
.sp
.ti -8
.bd
SEE ALSO
.br
dtoc, rtoc, putdec, putdbl
.sp
.ti -8
.bd
DIAGNOSTICS
.br
If space required for the output string exceeds given space ('w'), a
string of 'w' asterisks is returned.
.sp
.ti -8
.bd
AUTHOR
.br
John Chong, Lawrence Berkeley Laboratory
.sp
.ti -8
.bd
BUGS
.br
The 7th significant digit may not be correct due to floating point
arithmetic inaccuracy.
#-t-  math.doc                   7522  local   01/05/81  17:30:47
#-h-  math.pak                  13065  local   01/05/81  17:27:39
#S#
# ----------------------------------------------------------------------------
#
#       DTOC.F   --  double precision floating point to character string
#
#       01  AUGUST  1979     --     JOHN CHONG, Lawrence Berkeley Laboratory
#
#
        integer function dtoc (dblx, outs, p, size) 
        integer asize, size, p, npos, sign, ext, ext1, fext, rndup, decpt
        integer decloc, digpos, iloc, mleng, esign, zero, mleng1, ovfl
        double precision d, dtst, dblx, mant
        character outs (22), 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/
        define (DTEN, 1.0D+01)
        define (DZERO, 0.0D+00)
        define (DONE, 1.0D+00)
        define (DHALF, 5.0D-01)
#C   define MAXDIG to be the number of digits of significance.
        define (MAXDIG, 15)
#C   LITTLEBIT is used to make-up for floating point inaccuracies.
#C   example :  when 2.345 is represented by 2.3449999999999999
        define (LITTLEBIT, 2.0D-16)
#C   define DINT to be system's double precision truncation (int) routine.
        define (DINT, dint)
#C   check for zero length output string.
        if (size <= 0)
                {
                outs (1) = EOS
                dtoc = ERR
                return
                }
#C   check for zero as double precision input.
#C   if zero, set flag and process as double precision one.
        zero = 0
        if (dblx == DZERO) 
                {
                zero = 1
                dblx = DONE
                }
        repeat
                {
                asize = size 
#C   limit output size to 21 characters.
#C   15 -mantissa field, 4 -exponent field, 1 -decimal, 1 -negative sign.
                if (asize > 21)
                        asize = 21
#C   check the sign of mantissa.
                sign = 0
                if (dblx < 0) 
                        {
                        dblx = -dblx
                        sign = 1
                        }
#C   get the characteristic of the number.
                ext = int (log10 (dblx) + 100) - 100
                ext1 = ext
                if (ext >= 0)
                        ext1 = ext + 1
#C   allow space for decimal point.
                if (p != 0)
                        asize = asize - 1
#C   allow space for negative sign.
                asize = asize - sign
                decpt = 1
#C   determine the maximum allowable length for mantissa.
                mleng = ext1 + p
                if (ext < 0 | p < 0) 
                        {
                        mleng = abs (p) 
                        if (mleng == 0)
                                mleng = 1
                        }
#C   force 'mleng' to maximum available size.
#C   if  desired length > asize >= minimum required length
                if (mleng > asize & ext1 <= asize)
                        mleng = asize
#C   drop the decimal point if only whole number will fit.
                if (mleng > asize & ext >= 0 & ext1 <= asize + 1 & p > 0)
                        {
                        asize = asize + 1
                        mleng = asize
                        decpt = 0
                        }
#C   check for absence of significant digits in case :  0 < dblx < 1
                ovfl = 1
                if (ext >= 0 | p <= 0 | (p >= abs (ext) & asize >= abs (ext) ) )
                        ovfl = 0
#C   determine if exponential notation is needed.
                fext = 0
                if (p < 0 | abs (ext1) > MAXDIG | mleng > asize | ovfl == 1)
                        {
                        decpt = 1
                        mleng = abs (p)
                        asize = asize - 4
                        if (p == 0) 
                                asize = asize - 1
                        if (p >= 0 | mleng > asize) 
                                mleng = asize
                        fext = 1
                        }
#C   do not let mantissa length go over 15 decimal places.
                if (mleng > MAXDIG)
                        mleng = MAXDIG
                mleng1 = mleng
                if (p == 0 & ext < 0)
                        mleng1 = 0
#C   check for insufficient size.
                if (asize < 1) 
                        {
                        call aster (size, outs) 
                        dtoc = ERR
                        return
                        }
                if (p == 0 & fext == 0)
                        decpt = 0
#C   determine the round off position.
                rndup = mleng - 1
                if (ext < 0 & fext == 0)
                        rndup = mleng1 + ext
                mant = dblx * (DTEN ** (-ext) ) + LITTLEBIT
#C   use 'rndup' and round off the number.
                d = DINT (mant * (DTEN ** rndup) + DHALF) 
#C   check if rounding overflows to next power.
#C   on overflow add one to exponent 'ext' and repeat proceedure.
                dtst = d * (DTEN ** (-rndup) ) 
                if (dtst < DTEN)
                        break
                ext = ext + 1
                dblx = DTEN ** ext
                }
#C   determine the location of decimal point.
        decloc = ext1 + 1
        if (ext < 0 | fext == 1)
                decloc = 1
        if (sign == 1)
                decloc = decloc + 1
        ext = ext + 1
#C   get sign of the exponent.
        esign = 0
        if (ext < 0) 
                {
                esign = 1
                ext = -ext
                }
#C  if input was zero, restore it.
        if (zero == 1)
                {
                d = DZERO
                ext = 0
                }
#C   clear the output string.
        for (npos = 1; npos <= 23; npos = npos + 1)
                outs (npos) = EOS
#C   put in the negative sign.
        npos = 0
        if (sign == 1) 
                {
                npos = npos + 1
                outs (npos) = MINUS
                }
#C   put in the mantissa and decimal point.
        for (iloc = mleng1 - 1; iloc - mleng1 >= -mleng & iloc > mleng - (MAXDIG + 1); iloc = iloc - 1) 
                {
                npos = npos + 1
                if (npos == decloc & decpt == 1)
                        {
                        outs (npos) = PERIOD
                        npos = npos + 1
                        }
                digpos = DINT (d * (DTEN ** (-iloc) ) ) 
                outs (npos) = digits (digpos + 1) 
                d = d - DINT (digpos * (DTEN ** iloc) ) 
                }
#C   last chance to put in the decimal point.
        if (outs (decloc) != PERIOD & decpt == 1)
                {
                outs (decloc) = PERIOD
                npos = npos + 1
                }
#C   check if output is in exponential notation.
        if (fext == 1) 
                {
                npos = npos + 1
#C   put in the  'E'.
                outs (npos) = BIGE
                npos = npos + 1
#C   put in the PLUS or MINUS sign in exponent.
                outs (npos) = PLUS
                if (esign == 1) 
                        outs (npos) = MINUS
#C   put in the digits of the exponent.
                for (iloc = 1; iloc >= 0; iloc = iloc - 1)
                        {
                        npos = npos + 1
                        digpos = int (ext * (DTEN ** (-iloc) ) ) 
                        outs (npos) = digits (digpos + 1) 
                        ext = ext - int (digpos * (DTEN ** iloc) ) 
                        }
                }
#C   put in the EOS.
        outs (npos + 1) = EOS
#C   return the length of output string.
        dtoc = npos
        return
        end
#S#
# ----------------------------------------------------------------------------
#
#       ASTER.S   --  fill with asterisks on overflow of string.
#
#
        subroutine aster (arg1, arg2) 
        integer arg1
        character arg2 (22) 
        arg1 = abs (arg1)
        for (idx = 1; idx <= arg1; idx = idx + 1) 
                arg2 (idx) = STAR
        arg2 (arg1 + 1) = EOS
        return
        end
#S#
# ----------------------------------------------------------------------------
#
#
#       CTOD.F   --   character string to double precision floating point
#
#       15  AUGUST  1979     --     JOHN CHONG
#
#
        integer function ctod (stri, d)
        integer mant2, expo, expm, exp1, exp2, ileng, npos, pos, decloc
        integer esign, sign, nzero, i, first, mid, last
        integer length, alldig, index
        character mants (MAXLINE), exps (MAXLINE), stri (MAXLINE), digits (MAXLINE)
        character mantstr (MAXLINE), str (MAXLINE), expstr (MAXLINE)
        double precision d, mant
        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/
        define (DZERO, 0.0D+00)
        define (DTEN, 1.0D+01)
#C   LITTLEBIT is used to make-up for floating point inaccuracies.
#C   example :  when 2.345 is represented by 2.344999999999999
        define (LITTLEBIT, 1.0D-17)
#C   STOPDIG is the maximum number of significant digits.
        define (STOPDIG, 17)
        define (DHALF, 5.0D-01)
#C   EXPMAXLEN is the maximum length of the exponent.
        define (EXPMAXLEN, 2)
#C   EXPMAXVAL is the value of the largest exponent the system can handle.
        define (EXPMAXVAL, 37)
#C   define DINT to be system's double precision truncation (int) routine.
        define (DINT, dint)
#C   MAXVAL is the largest floating point number the system will allow.
        define (MAXVAL, 9.999999999999D+EXPMAXVAL)
#C   clear all the character strings.
        for (i = 1; i <= MAXLINE; i = i + 1)
                {
                mants (i) = EOS
                exps (i) = EOS
                mantstr (i) = EOS
                expstr (i) = EOS
                str (i) = EOS
                }
        mant = 0
        expo = 0
        sign = 1
        esign = 1
#C   get length of input string.
        ileng = length (stri)
#C   check for bad string length.
        if (ileng < 1)
                {
                ctod = ERR
                d = DZERO
                return
                }
#C   get the first and last non-blank character.
        first = -2
        last = -2
        for (pos = 1; pos <= ileng; pos = pos + 1)
                {
                if (stri (pos) != BLANK & first == -2)
                        first = pos
                mid = ileng - pos + 1
                if (stri (mid) != BLANK & last == -2)
                        last = mid
                }
#C   check to see if entire string is blank.
        if (first == -2)
                {
                d = DZERO
                ctod = ERR
                return
                }
#C   remove the blanks  (copy out the non-blank portion)
        npos = 0
        for (pos = first; pos <= last; pos = pos + 1)
                {
                npos = npos + 1
                str (npos) = stri (pos)
                }
#C   get the new length.
        ileng = last
        pos = 1
#C   check the mantissa's sign.
        if (str (pos) == MINUS | str (pos) == PLUS)
                {
                if (str (pos) == MINUS)
                        sign = -1
                pos = pos + 1
                }
        exp1 = 0
        npos = 0
        decloc = -2
#C   check the string for decimal point, EOS, E or D, and other bad stuff.
#C   if bad stuff is detected use the string up to this point.
        for ( ; ; pos = pos + 1)
                {
                if ( (str (pos) < DIG0 | str (pos) > DIG9) & str (pos) != PERIOD)
                        {
#C   get the length of the mantissa.
                        mant2 = npos
                        if (str (pos) == BIGE | str (pos) == BIGD)
                                exp1 = pos + 1
                        break
                        }
#C   store position of first detected decimal point.
                if (str (pos) == PERIOD & decloc == -2)
                        decloc = npos - 1
                else
#C   store the digits of the mantissa.
                        {
                        npos = npos + 1
                        mants (npos) = str (pos)
                        }
                }
#C   last chance to store the decimal point's position.
        if (decloc == -2)
                decloc = npos - 1
        mants (mant2 + 1) = EOS
#C   check for existance of exponent.
        if (exp1 != 0)
                {
#C   get the sign of the exponent.
                if (str (exp1) == MINUS | str (exp1) == PLUS)
                        {
                        if (str (exp1) == MINUS)
                                esign = -1
                        exp1 = exp1 + 1
                        }
                npos = 0
#C   store the digits of the exponent.
                for (pos = exp1; pos <= ileng & (str (pos) >=DIG0 & str (pos) <= DIG9); pos = pos + 1)
                        {
                        npos = npos + 1
                        exps (npos) = str (pos)
                        }
#C   put length of exponent string in 'exp2'
                exp2 = npos
                exps (npos + 1) = EOS
                }
#C   check the mantissa and exponent strings for non-numerics.
        if (alldig (mants) == NO | (alldig (exps) == NO & exp1 != 0) )
                {
                ctod = ERR
                d = DZERO
                return
                }
#C   check and remove leading zeroes in mantissa.
        for (npos = 1; npos <= mant2; npos = npos + 1)
                {
                if (mants (npos) != DIG0)
                        break
                }
#C   check for all zeroes in mantissa.
        if (npos > mant2)
                {
                d = DZERO
                ctod = YES
                return
                }
#C   save the number of zeroes in 'nzero'.
        nzero = npos - 1
        call scopy (mants, npos, mantstr, 1)
#C   get new length of mantissa.
        mant2 = length (mantstr)
#C   check for all zeroes in exponent.
        for (npos = 1; npos <= exp2; npos = npos + 1)
                {
                if (exps (npos) != DIG0)
                        break
                }
#C   if all zeroes copy at least the last zero.
        if (npos > exp2)
                npos = npos - 1
        call scopy (exps, npos, expstr, 1)
#C   get new length of exponent.
        exp2 = length (expstr)
#C   does exponent exceed maximum length ???
        if (exp2 > EXPMAXLEN)
                {
                d = MAXVAL
                ctod = ERR
                return
                }
#C   get the characteristic of the mantissa.
        expm = decloc - nzero
        if (decloc == -1)
                expm = decloc * (nzero + 1)
#C   limit the length of mantissa to STOPDIG digits.
        if (mant2 > STOPDIG)
                mant2 = STOPDIG
#C   convert mantissa string to floating point number.
        for (npos = 1; npos <= mant2; npos = npos + 1)
                mant = DINT (mant * DTEN + (index (digits, mantstr (npos) ) - DHALF) )
        if (mant >= 10)
                mant = mant * (DTEN ** (1 - mant2) ) + LITTLEBIT
#C   convert exponent string to integer.
        for (npos = 1; npos <= exp2; npos = npos + 1)
                expo = expo * 10 + (index (digits, expstr (npos) ) - 1)
#C   combine explicit exponent 'expo' with mantissa's exponent 'expm'.
        expo = expo + expm
#C   does exponent exceed the maximum value.
        if (expo > EXPMAXVAL)
                {
                d = MAXVAL
                ctod = ERR
                return
                }
#C   multiply mantissa and exponent and all sign(s) to get result.
        d = sign * (mant * (DTEN ** (esign * expo) ) )
        ctod = YES
        return
        end
#S#
# --------------------------------------------------------------------
#
#       PUTDBL.S  --  write double precision number to file
#
#       15  AUGUST  1979     --     JOHN CHONG
#
#
        subroutine putdbl (d, p, w, fc)
        character out (23), fout (MAXLINE)
        integer leng, p, w, fc, dtoc, i, move
        double precision d
        for (i = 1; i <= MAXLINE; i = i + 1)
                fout (i) = BLANK
        leng = dtoc (d, out, p, w)
        if (leng == ERR)
                {
                call putlin (out, fc)
                return
                }
        move = 1
        if (w > leng)
                move = w - leng + 1
        call scopy (out, 1, fout, move)
        fout (w + 1) = EOS
        call putlin (fout, fc)
        return
        end
#S#
# ----------------------------------------------------------------------------
#
#
#       RTOC.F   --   single precision floating point to character string
#
#
        integer function rtoc (realin, outstr, p, size)
        real realin
        integer size, p
        integer dtoc
        double precision dbl
        character outstr (MAXLINE)
        dbl = realin
        rtoc = dtoc (dbl, outstr, p, size)
        return
        end
#S#
# ----------------------------------------------------------------------------
#
#
#       CTOR.F   --   character string to single precision floating point
#
#
        integer function ctor (outstr, realout)
        real realout
        integer ctod
        double precision dbl
        character outstr
        ctor = ctod (outstr, dbl)
        realout = dbl
        return
        end
#S#
# -----------------------------------------------------------------------------
#
#
#       PUTREAL.S   --   write single precision number to file
#
#
        subroutine putreal (r, p, w, fc)
        real r
        integer p, w, fc
        double precision dd
        dd = r
        call putdbl (dd, p, w, fc)
        return
        end
#-t-  math.pak                  13065  local   01/05/81  17:27:39
#-t-  math.lbl                  20851  local   01/05/81  21:41:09
#-h-  printf.lbl                 9621  local   01/05/81  22:41:16
#-h-  printf.doc                 3686  local   01/05/81  22:39:57
.bp 1
.he 'PRINTF'1/5/81'PRINTF'
.fo ''-#-''
.in 5
.ti -5
NAME
.br
printf - formatted print
.sp
.ti -5
SYNOPSIS
.br
printf(fd, s, arg1, ...)
.br
integer fd
.br
character s(ARB)
.sp
.ti -5
DESCRIPTION
.br
Printf converts, formats, and prints its arguments onto file 'fd'
under control of the first argument.
The first argument is a character string which contains two types
of objects: plain characters, which are simply copied to the output
stream, and conversion specifications,
each of which causes conversion and printing of the next 
successive argument to printf.
.sp
Each conversion specification is introduced by the character %.
Following the %, there may be
.sp
.in +5
an optional minus sign "-" which specifies left adjustment of
the converted argument in the indicated field;
.sp
an optional digit string specifying a field width; 
if the converted argument has fewer characters than the field width
it will be blank-padded on the left (or right, if the left-adjustment
indicator has beeen given) to make up the field width;
.sp
an optional period "." which serves to separate the field width from
the next digit string;
.sp
an optional digit string (precision) which specifies the number of
digits to appear after the decimal point, for e- and f-conversion,
or the maximum number of characters to be printed from a string;
.sp
a character which indicates the type of conversion to be applied.
.sp
.in -5
The conversion characters and their meanings are:
.sp
d,o,x  The integer argument is converted to decimal, octal, or hexadecimal
notation respectively.
.sp
f   The argument is converted to decimal notation in the style "[-]ddd.ddd"
where the number of d's after the decimal point is equal to the
precision specification for the argument.
If the precision is missing, 6 digits are given;
if the precision is explicitly 0, no digits and no decimal point
are printed.
The argument is expected to be of type "real".
.sp
e   The argument is converted in the style "[-]d.ddde+-dd" where there
is one digit before the decimal point and the number after is equal to
the precision specification for the argument;
when the precision is missing, 6 digits are produced.
The argument is expected to be of type "real".
.sp
c  The argument character is printed.
.sp
s   The argument is taken to be a character string and characters from
the string are printed until an EOS is found or until the number of
characters indicated by the precision specification is reached.
.sp
If no recognizable character appears after the %, that character is printed;
thus % may be printed by use of the string %%.
In no case does a non-existent or small field width cause
truncation of a field; padding takes place only if
the specified field width exceeds the actual width.
.sp
.ti -5
SEE ALSO
.br
putdec, putint, putstr, putc, putch, putlin, remark, ctoi, itoc
.br
.ti -5
AUTHORS
.br
Clint Ward, Lawrence Berkeley Laboratory, and David Hanson, University
of Arizona.
.sp
.ti -5
FILES
.br
This package uses routines from the LBL math package.
.sp
.ti -5
BUGS/DEFICIENCIES
.br
It is impossible for a routine to 'portably' determine the number of
arguments passed to it.
If your system does provide a way, alter printf accordingly.
If not, you may want to write a macro which provides dummy arguments
to 'printf' whenever it is called with fewer than the number declared.
.sp
This version of printf only works with fortran compilers that can
be fooled as the the typing of arguments.
If your compiler is smarter than that, perhaps you can think of
a better way to write this routine.
.sp
This package has never been completely tested.  
Consider it a starting point for a future, more robust version...
#-t-  printf.doc                 3686  local   01/05/81  22:39:57
#-h-  printf.r                   5671  local   01/05/81  22:36:40
#-h-  printf                     3471  local   01/05/81  21:59:14
##printf--print arguments according to s
  subroutine printf(fd,s,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9)
  character s(ARB)
  integer myllc, a(ARB), ctoi, length, rtoc, xtoc
  integer arg(9)
  integer fd, i, j, c, w, p, ap, len
  integer buf(MAXCHARS)
  character fmt(ARB)

  arg(1) = arg1
  arg(2) = arg2
  arg(3) = arg3
  arg(4) = arg4
  arg(5) = arg5
  arg(6) = arg6
  arg(7) = arg7
  arg(8) = arg8
  arg(9) = arg9
  ap = 1
  if (s(1) > 127 | s(1) < 0)  {
     for (i = 1; myllc(fmt(i),s,i-1) != 0; i = i + 1)
        ;
     fmt(i) = EOS
     }
  else
     call scopy(s, 1, fmt, 1)
  for (i = 1; fmt(i) != EOS; i = i + 1) {
     c = fmt(i)
     if (c == BAR) {  # special character
        i = i + 1
        c = fmt(i)
        if (c == DIG0)
           return
        else if (c == LETT | c == BIGT)
           c = TAB
        else if (c == LETN | c == BIGN)
           c = NEWLINE
        else if (c == LETB | c == BIGB)
           c = BACKSPACE
        call putch(c, fd)
        }
    else if (c != PERCENT)  #ordinary character
        call putch(c, fd)
    else {  #format code
       i = i + 1
       w = ctoi(fmt, i)
       if (fmt(i) == PERIOD) {
          i = i + 1
          p = ctoi(fmt, i)
          }
     else
          p = -1
     c = fmt(i)
     if (c == LETD | c == BIGD)
    {
       call remark('we think it is a decimal.')
        call putint(arg(ap), w, fd)
     }
     else if (c == LETO | c == BIGO) { # %wo print octal integer
        len = xtoc(arg(ap), buf, MAXCHARS, 8)
        call putstr(buf, w, fd)
        }
     else if (c == LETX | c == BIGX) { # %w.bx print integer in base b
        if (p < 2 | p > 36) # default is hex
           p = 16
        len = xtoc(arg(ap), buf, MAXCHARS, p)
        call putstr(buf, w, fd)
        }
     else if (c == LETS | c == BIGS) { # %ws print string
      call locarg(ap,argout,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9)
      if (arg(ap) <= 127 & arg(ap) > 0)  # unpacked string
           len = length(argout)
        else     # packed string
           for (len=0; myllc(c,argout,len) != 0; len = len+1)
              if (c == BAR)
                 if (myllc(c, argout, len+1) == DIG0)
                    break
      if (p > 0 & p < len)  # truncate if precision given
          len = p
      for ( ; w > len; w = w - 1)
         call putch(BLANK, fd)
      if (arg(ap) <= 127 & arg(ap) > 0)  # unpacked string
         for (j = 0; j < len; j = j + 1)
            call putch(argout,fd)
      else  # packed string
         for (j = 0; j < len; j = j + 1)
             call putch(myllc(c, argout,j), fd)
      for ( ; w < -len; w = w + 1)
         call putch(BLANK, fd)
      }
   else if (c == LETF | c == BIGF) { # %w.df print real number
      if (p == -1)        # default precision is 666
          p = 6
      len = rtoc(arg(ap), buf, p, MAXCHARS)
      call putstr(buf, w, fd)
      }
   else if (c == LETE | c == BIGE) { # %w.de print real number
      if (p == -1)
          p = 6
      len = rtoc(arg(ap), buf, -p, MAXCHARS) # force e format
      call putstr(buf, w, fd)
      }
   else if (c == LETC | c == BIGC) { # %wc print character
      for ( ; w > 1; w = w - 1)
          call putch(BLANK, fd)
      if (arg(ap) <= 127 & arg(ap) > 0)
        call putch(arg(ap),fd)
      else
         call putch(myllc(c, arg(ap), 0), fd)
      for ( ; w < -1; w = w + 1)
          call putch(BLANK,fd)
      }
    else if (c == LETN | c == BIGN)   # %n change output file
       fd = arg(ap)
    else {   # funny code
       call putch(c, fd)
       next
       }
    ap = ap + 1
    }
  }
return
end
#-t-  printf                     3471  local   01/05/81  21:59:14
#-h-  xtoc                        716  local   01/05/81  21:59:15
# xtoc - convert integer  int  to char string in  str in base b
   integer function xtoc(int, str, size, b)
   integer abs, mod
   integer i, int, intval, j, k, size, b
   character str(ARB)
 
   intval = abs(int)
   str(1) = EOS
   i = 1
   repeat {            # generate digits
      i = i + 1
      str(i) = DIG0 + mod(intval, b)
      if (b > 10)
         str(i) = str(i) + LETA - DIG9 - 1
      intval = intval / b
      } until (intval == 0 | i >= size)
   if (int < 0 & i < size) {      # then sign
      i = i + 1
      str(i) = MINUS
      }
   xtoc = 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
#-t-  xtoc                        716  local   01/05/81  21:59:15
#-h-  myllc                       142  local   01/05/81  21:59:15
##myllc puts the ith character (base-0) of a into c
integer function myllc(c,a,i)
        character a(ARB), c
        integer i

        c = a(i+1)
        myllc = c
end
#-t-  myllc                       142  local   01/05/81  21:59:15
#-h-  locarg                      388  local   01/05/81  21:59:16
##locarg--finds the ith argument writes it to argout
subroutine locarg(ap,argout,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9)
integer ap,argout(ARB),arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9

if (ap == 1)
       call scopy(arg1,1,argout,1)
else if(ap == 2)
       call scopy(arg2,1,argout,1)
else if(ap == 3)
       call scopy(arg3,1,argout,1)
else if(ap == 4)
       call scopy(arg4,1,argout,1)
else if (ap == 5)
       call scopy(arg5,1,argout,1)
else if (ap == 6)
       call scopy(arg6,1,argout,1)
else if (ap == 7)
       call scopy(arg7,1,argout,1)
else if (ap == 8)
       call scopy(arg8,1,argout,1)
else if (ap == 9)
       call scopy(arg9,1,argout,1)
else argout(1) = EOS
return
end
#-t-  locarg                      388  local   01/05/81  21:59:16
#-t-  printf.r                   5671  local   01/05/81  22:36:40
#-t-  printf.lbl                 9621  local   01/05/81  22:41:16
#-t-  library                  221308  local   01/05/81  23:05:50
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        