      logical*1 prctrl,caller(6)
c
      common /com1/ d0,d1,d2,d3,d4,d5,d6,d7,d8,d9
      common /com1/ la,lb,lc,ld,le,lf,lg,lh,li,lj,lk,ll,lm,ln,lo,lp,lq,
     c   lr,ls,lt,lu,lv,lw,lx,ly,lz
      common /com1/ blank,period,lparen,plus,dollar,aster,rparen,minus,
     c   slash,comma,under,equal,quote,less,bar,and,semi,not,prcent,
     c   grater,questn,colon,pound,at,apost
      common /com1/ self,west,east,south,north,swest,nwest,seast,neast,
     c   horiz,vert,aigu,grave,rook,bishop,king
      common /com1/ system,scope,ttyo,ttyi,ptapei,cardi,printr,cardo,
     c   camrao,camrai,fmts
      common /com1/ ttwide,lastin,income,fmtbuf
      integer d0,d1,d2,d3,d4,d5,d6,d7,d8,d9
      integer la,lb,lc,ld,le,lf,lg,lh,li,lj,lk,lm,ln,lo,lp,lq,lr,ls,lt,
     c   lu,lv,lw,lx,ly,lz
      integer blank,period,lparen,plus,dollar,aster,rparen,minus,slash,
     c   comma,under,equal,quote,less,bar,and,semi,not,prcent,grater,
     c   questn,colon,pound,at,apost
      integer self,west,east,south,north,swest,nwest,seast,neast,horiz,
     c   vert,aigu,grave,rook,bishop,king
      integer system,scope,ttyo,ttyi,ptapei,cardi,printr,cardo,camrao,
     c   camrai,fmts
      integer ttwide,lastin
      logical*1 income(72), fmtbuf(160)
c
c boundaries of the rectangle
      integer ledge,redge,bedge,tedge
c count of consecutive error messages for illegal min. or max. fleck
c values
      integer minmax/1/
c switch determines whether to type an error message showing all the
c input parameters
      logical ermsg
c switch determines whether actual parameters allow subroutine execution
      logical xecute
c probability adjusted to legal value
      integer adjprb
c variables for random-skipping through table
      integer point,skip,del
      integer point2,skip2,del2
c four times adjusted probability
      integer probx4
c min. and max. fleck values, adjusted to correct possible user errors
      integer minadj,maxadj
c range of fleck values
      integer range
c number of ranges of fleck values spanned by the table of random
c numbers
      integer ratio
c 1 + largest random number which can be transformed into a fleck value
      integer prodct
c equivalent storage for numerical operations on character values
      integer chari/0/
      logical charl
      equivalence (chari,charl)
c name of this subroutine
      logical*1 name(6)/'f','l','e','c','k',' '/
c
c
c
      do 1 i=1,6
 1    caller(i) = name(i)
c adjust boundaries, test for absence of error message
      ermsg = .not. qadj(xcentr,ycentr,width,height,prob,adjprb,
     c   ledge,redge,bedge,tedge,xecute,0)
c test for valid min. and max. fleck values
      if ((minmum .lt. 0) .or. (maxmum .lt. 0) .or. (maxmum .ge. chars)
     c   .or. (minmum .gt. maxmum)) go to 2
c reset error count
      minmax = 1
c if actual parameters caused any error messages, show the user his
c actual call
 9    if (ermsg) go to 10
 11   if (.not. xecute) go to 12
c correct possible errors in min. and max. fleck values
      minadj = min0(iabs(minmum),chars-1)
      maxadj = min0(iabs(maxmum),chars-1)
      if (minadj .le. maxadj) go to 3
c interchange min. and max. fleck values
      temp = minadj
      minadj = maxadj
      maxadj = temp
 3    range = maxadj - minadj + 1
      ratio = 401 / range
      prodct = ratio * range
c for efficient execution, set up loops using the string equivalent
c addresses of squares in the rectangle.  this allows single indexing in
c the innermost loop, where array addresses would require double
c indexing.
      bedge = (bedge-1)*pictx + 1
      tedge = (tedge-1)*pictx + 1
c set initial values for table skipping
c point,skip,del for determining which squares to do
c point2,skip2,del2 for determining which numbers to store
      point=random(1,401,0)
      point2=random(1,401,0)
      skip=random(0,399,0)
       skip2=random(0,399,0)
      del=random(1,397,0)
      del2=random(1,397,0)
      probx4=4*adjprb+adjprb/51
      do 20 y=bedge,tedge,pictx
      mindex = y + ledge - 1
      maxdex = y + redge - 1
      skip=mod(skip+del,400)
      skip2=mod(skip2+del2,400)
      if((adjprb.ge.100).and.(range.eq.1))go to 13
      if(adjprb.ge.100)go to 15
      if(range.eq.1)go to 17
c do only some squares, store more than one number
      do 19 index=mindex,maxdex
      point=mod(point+skip,401)+1
      if(ranseq(point).ge.probx4)go to 19
 4    point2=mod(point2+skip2,401)+1
      chari = ranseq(point2)
      if (chari .ge. prodct) go to 4
      chari = chari/ratio + minadj
      string(index)=charl
  19  continue
      go to 20
c
c do only some squares, but all of these with the same number
 17   chari = minadj
      do 18 index=mindex,maxdex
      point=mod(point+skip,401)+1
      if(ranseq(point).ge.probx4)go to 18
      string(index)=charl
  18  continue
      go to 20
c
c do all squares, but with a range of numbers
 15   do 16 index=mindex,maxdex
 5    point2=mod(point2+skip2,401)+1
      chari = ranseq(point2)
      if (chari .ge. prodct) go to 5
      chari = chari/ratio + minadj
      string(index)=charl
  16  continue
      go to 20
c
c do all squares, with the same number
 13   chari = minadj
      do 14 index=mindex,maxdex
      string(index)=charl
  14  continue
      go to 20
c
  20  continue
  12  return
c
c illegal fleck values; test error count
 2    if (minmax .gt. maxmsg) go to 9
      minmax = minmax + 1
c no need to set error message switch; execution falls through to
c statement 10
c passing character size to the error message allows this code to run
c unchanged on computers with different character sizes
      temp = chars - 1
      call getfmt(50,.false.)
      write (ttyo,fmtbuf) temp
c at least one error message preceded this.  show the user his actual
c call.
 10   call getfmt(53,.false.)
      write (ttyo,fmtbuf) xcentr,ycentr,width,height,prob,minmum,maxmum
c ask the user what he wants to do next
      call qnowut
      go to 11
      end
c      census(x,y,width,height),count(n),rank(n),ident(rank)
c subroutine census counts and tabulates the number of times each of the
c numbers appears in the specified rectangle, the effect being to esta-
c blish values for the following functions, which are not updated until
c the next call of census: count(n), rank(n), ident(rank).  count(n) is
c simply the number of times n appears, rank(n) is the position in order
c of popularity(i.e. whether n was most numerous, 2nd, 3rd, etc.), ident
c (rank) is the (identity of) the number with the specified rank.  all
c ranks are unique - they are computed by initially assuming 0 is most
c common, 1 next, etc., and they are reordered only by inequality of
c counts.
c
c census, count, rank, and ident are all actually different entries in
c the same function.  the value of census, if it should actually be
c called as a function, is 0.  census serves to compose a 256-long
c integer*4 table whose entries are 1000*count(n)+rank(n),  from which
c count and rank of n can be gotten rather directly by performing the
c appropriate arithmetic.  ident(n) requires a scan of the table in
c order to find the number (position) with the specified rank.
c the system of storing information described above must be changed
c for machines with short word lengths (e.g. 16 bits) ******************
c **********************************************************************
c
c
c
      integer function census(xcentr,ycentr,width,height)
      implicit integer(a-z)
c
c specification of called functions
      logical qadj
c
      common /qommon/ chars,mach2k,k2mach,pictx,picty,picher,buf1,
     c   ranseq,
     c   eratio,ldist,rdist,bdist,tdist,maxmsg,wider,higher,prober,
     c   frames,frame1,frame2,frame3,frame4,frscop,frintr,frcard,
     c   prctrl,caller
      integer chars
      logical*1 mach2k(256), k2mach(256)
      integer pictx,picty
      logical*1 picher(320,240), string(76800)
      equivalence (picher(1,1), string(1))
      logical*1 buf1(352)
      integer ranseq(401)
      integer eratio,ldist,rdist,bdist,tdist,maxmsg,wider,higher,prober,
     c   frames
      logical frame1,frame2
      integer frame3,frame4
      logical frscop,frintr,frcard
      logical*1 prctrl,caller(6)
c
      common /com1/ d0,d1,d2,d3,d4,d5,d6,d7,d8,d9
      common /com1/ la,lb,lc,ld,le,lf,lg,lh,li,lj,lk,ll,lm,ln,lo,lp,lq,
     c   lr,ls,lt,lu,lv,lw,lx,ly,lz
      common /com1/ blank,period,lparen,plus,dollar,aster,rparen,minus,
     c   slash,comma,under,equal,quote,less,bar,and,semi,not,prcent,
     c   grater,questn,colon,pound,at,apost
      common /com1/ self,west,east,south,north,swest,nwest,seast,neast,
     c   horiz,vert,aigu,grave,rook,bishop,king
      common /com1/ system,scope,ttyo,ttyi,ptapei,cardi,printr,cardo,
     c   camrao,camrai,fmts
      common /com1/ ttwide,lastin,income,fmtbuf
      integer d0,d1,d2,d3,d4,d5,d6,d7,d8,d9
      integer la,lb,lc,ld,le,lf,lg,lh,li,lj,lk,lm,ln,lo,lp,lq,lr,ls,lt,
     c   lu,lv,lw,lx,ly,lz
      integer blank,period,lparen,plus,dollar,aster,rparen,minus,slash,
     c   comma,under,equal,quote,less,bar,and,semi,not,prcent,grater,
     c   questn,colon,pound,at,apost
      integer self,west,east,south,north,swest,nwest,seast,neast,horiz,
     c   vert,aigu,grave,rook,bishop,king
      integer system,scope,ttyo,ttyi,ptapei,cardi,printr,cardo,camrao,
     c   camrai,fmts
      integer ttwide,lastin
      logical*1 income(72), fmtbuf(160)
c
c table for keeping statistics
      integer counts(256)
c misc. variables
      integer mxntry,point,rnk,cnt
c boundaries of the rectangle, dummy adjusted probability
      integer ledge,redge,bedge,tedge,adjprb
c switch shows whether to type an error message showing input params
      logical ermsg
c switch indicates whether input parameters actually allow execution.
      logical xecute
c equivalent storage for numerical operations on character values
      integer chari/0/
      logical charl
      equivalence(chari,charl)
c name of this function
      logical*1 name(6) /'c','e','n','s','u','s'/
c
c
c
      do 1 i=1,6
  1   caller(i)=name(i)
      census=0
c adjust boundaries, test for error message.
      ermsg = .not. qadj(xcentr,ycentr,width,height,100,adjprb,
     c ledge,redge,bedge,tedge,xecute,0)
c if parameters caused error message, print values.
      if (.not. ermsg) go to 2
      call getfmt(68,.false.)
      write (ttyo,fmtbuf) xcentr,ycentr,width,height
c ask the user what he wants to do next
      call qnowut
 2    continue
c process "xecute" *****************************************************
c initialize counts table
      do 3 i=1,256
  3   counts(i)=0
c for efficient execution use string equivalent addresses
      bedge=(bedge-1)*pictx+1
      tedge=(tedge-1)*pictx+1
      do 10 y=bedge,tedge,pictx
      mindex=y+ledge-1
      maxdex=y+redge-1
c
      do 5 index=mindex,maxdex
      charl=string(index)
  5   counts(chari+1)=counts(chari+1)+1000
  10  continue
      mxntry=256
      do 15 i=1,256
      if (counts(257-i).ne.0)go to 20
  15  mxntry=mxntry-1
c the rank of n is the number of numbers with counts greater than counts
c (n)+1. since they are computed in increasing order, lower numbers are
c favored (get lower ranks) if counts are equal.
  20  do 25 i=1,mxntry
      cnt=counts(i)
      rnk=1
      do 26 j=1,mxntry
  26  if(counts(j).gt.cnt)rnk=rnk+1
  25  counts(i)=cnt+rnk
c insert ranks in unused positions
      point=mxntry+1
      if(point.gt.256)go to 50
      do 27 i=point,256
  27  counts(i)=i
      go to 50
c
c
c
c entry for returning count(n)
      entry count(n)
      count=counts(n+1)/1000
      go to 50
c
c
c
c entry for computing rank(n)
      entry rank(n)
      rank=mod(counts(n+1),1000)
      go to 50
c
c
c
c ident(rank) is found by searching table for specified rank.
      entry ident(rk)
      do 40 i=1,256
      if(mod(counts(i),1000).eq.rk) go to 45
  40  continue
  45  ident=i-1
  50  return
      end
c boundary adjustment and error detection for those subroutines which
c are defined on a rectangle and which have a probability parameter.
c the first 4 parameters define the rectangle as specified by the user.
c the fifth parameter "probin" is a percentage probability between 0 and
c 100.  the contents of array "caller" in common area "qommon" is an
c implied input parameter, containing the name of the superroutine which
c called function "qadj".  "margin" is an input parameter described
c below.
c on exit, the value of the function is .false. if any error messages
c were typed, or .true. otherwise.  output parameter "xecute" is .true.
c if the actual parameters allow execution of the calling superroutine.
c if it is .true., then output parameters "ledge", "redge", "bedge", and
c "tedge" have been set to the left, right, bottom, and top edge
c coordinates of the rectangle, adjusted to be entirely within the
c picture by an amount equal to input parameter "margin".  parameter
c "prbout" is the percentage probability, adjusted to a legal value.
c
c
c
      logical function qadj(xcentr,ycentr,width,height,probin,prbout,
     c   ledge,redge,bedge,tedge,xecute,margin)
      implicit integer (a-z)
      logical xecute
c
      common /qommon/ chars,mach2k,k2mach,pictx,picty,picher,buf1,
     c   ranseq,
     c   eratio,ldist,rdist,bdist,tdist,maxmsg,wider,higher,prober,
     c   frames,frame1,frame2,frame3,frame4,frscop,frintr,frcard,
     c   prctrl,caller
      integer chars
      logical*1 mach2k(256), k2mach(256)
      integer pictx,picty
      logical*1 picher(320,240), string(76800)
      equivalence (picher(1,1), string(1))
      logical*1 buf1(352)
      integer ranseq(401)
      integer eratio,ldist,rdist,bdist,tdist,maxmsg,wider,higher,prober,
     c   frames
      logical frame1,frame2
      integer frame3,frame4
      logical frscop,frintr,frcard
      logical*1 prctrl,caller(6)
c
      common /com1/ d0,d1,d2,d3,d4,d5,d6,d7,d8,d9
      common /com1/ la,lb,lc,ld,le,lf,lg,lh,li,lj,lk,ll,lm,ln,lo,lp,lq,
     c   lr,ls,lt,lu,lv,lw,lx,ly,lz
      common /com1/ blank,period,lparen,plus,dollar,aster,rparen,minus,
     c   slash,comma,under,equal,quote,less,bar,and,semi,not,prcent,
     c   grater,questn,colon,pound,at,apost
      common /com1/ self,west,east,south,north,swest,nwest,seast,neast,
     c   horiz,vert,aigu,grave,rook,bishop,king
      common /com1/ system,scope,ttyo,ttyi,ptapei,cardi,printr,cardo,
     c   camrao,camrai,fmts
      common /com1/ ttwide,lastin,income,fmtbuf
      integer d0,d1,d2,d3,d4,d5,d6,d7,d8,d9
      integer la,lb,lc,ld,le,lf,lg,lh,li,lj,lk,lm,ln,lo,lp,lq,lr,ls,lt,
     c   lu,lv,lw,lx,ly,lz
      integer blank,period,lparen,plus,dollar,aster,rparen,minus,slash,
     c   comma,under,equal,quote,less,bar,and,semi,not,prcent,grater,
     c   questn,colon,pound,at,apost
      integer self,west,east,south,north,swest,nwest,seast,neast,horiz,
     c   vert,aigu,grave,rook,bishop,king
      integer system,scope,ttyo,ttyi,ptapei,cardi,printr,cardo,camrao,
     c   camrai,fmts
      integer ttwide,lastin
      logical*1 income(72), fmtbuf(160)
c
c boundaries of the picture, with the margin removed
      integer marg1,margx,margy
c
c
c
c initially no errors detected
      qadj = .true.
      xecute = .true.
c remove the margin from the picture boundaries
      marg1 = 1 + margin
      margx = pictx - margin
      margy = picty - margin
c compute boundaries of the rectangle
      if (width .lt. 1) go to 1
      ledge = xcentr - (width-1)/2
      if (ledge .lt. marg1) go to 2
 19   redge = xcentr + width/2
      if (redge .gt. margx) go to 3
c reset error count
 14   wider = 1
 15   if (height .lt. 1) go to 4
      bedge = ycentr - (height-1)/2
      if (bedge .lt. marg1) go to 5
 22   tedge = ycentr + height/2
      if (tedge .gt. margy) go to 6
c test whether any part of the rectangle is in the picture
 24   xecute = xecute .and. (ledge .le. margx) .and. (redge .ge. marg1)
     c   .and. (bedge .le. margy) .and. (tedge .ge. marg1)
c reset error count
 16   higher = 1
c test for valid probability; reanalyze errors later, to save time in
c normal error-free execution
 17   prbout = probin
      if ((prbout .lt. 1) .or. (prbout .gt. 100)) go to 7
c reset error count
 28   prober = 1
 9    return
c process nonpositive width parameter, no error if width = 0
 1    xecute = .false.
      if (width .eq. 0) go to 14
c test error count
      if (wider .gt. maxmsg) go to 15
      wider = wider + 1
      qadj = .false.
      call getfmt(2,.false.)
      write (ttyo,fmtbuf) (caller(i), i=1,6)
      go to 15
c process nonpositive height parameter, no error if height = 0
 4    xecute = .false.
      if (height .eq. 0) go to 16
c test error count
      if (higher .gt. maxmsg) go to 17
      higher = higher + 1
      qadj = .false.
      call getfmt(13,.false.)
      write (ttyo,fmtbuf) (caller(i), i=1,6)
      go to 17
c the left edge of the rectangle is to the left of the picture
 2    if (marg1-ledge .lt. ldist*eratio) go to 18
      ldist = marg1 - ledge
      qadj = .false.
      call getfmt(3,.false.)
      write (ttyo,fmtbuf) (caller(i), i=1,6), ldist
c reset left edge of rectangle to left edge of picture
 18   ledge = marg1
      go to 19
c the right edge of the rectangle is to the right of the picture
 3    if (redge-margx .lt. rdist*eratio) go to 20
      rdist = redge - margx
      qadj = .false.
      call getfmt(4,.false.)
      write (ttyo,fmtbuf) (caller(i), i=1,6), rdist
c reset right edge of rectangle to right edge of picture
 20   redge = margx
      go to 14
c the bottom edge of the rectangle is below the picture
 5    if (marg1-bedge .lt. bdist*eratio) go to 21
      bdist = marg1 - bedge
      qadj = .false.
      call getfmt(5,.false.)
      write (ttyo,fmtbuf) (caller(i), i=1,6), bdist
c reset bottom edge of rectangle to bottom edge of picture
 21   bedge = marg1
      go to 22
c the top edge of the rectangle is above the picture
 6    if (tedge-margy .lt. tdist*eratio) go to 23
      tdist = tedge - margy
      qadj = .false.
      call getfmt(6,.false.)
      write (ttyo,fmtbuf) (caller(i), i=1,6), tdist
c reset top edge of rectangle to top edge of picture
 23   tedge = margy
      go to 24
c input probability parameter < 1 or > 100
 7    if (prbout) 25,26,27
 26   xecute = .false.
      go to 28
c setting output probability parameter = 100 does not hurt if execute
c switch = .false.
 25   xecute = .false.
 27   prbout = 100
c test error count
      if (prober .gt. maxmsg) go to 9
      prober = prober + 1
      qadj = .false.
      call getfmt(7,.false.)
      write (ttyo,fmtbuf) (caller(i), i=1,6)
      go to 9
      end
c advance to the next frame in a sequence of graphic output displays.
c this subroutine clears the scope screen.  it sets switches which will
c cause a page eject the next time there is printer output, and punch
c some special frame separation cards the next time there is punched
c output.
c each new frame is identified by the incremented value of the frame
c counter "frames" and by the first 3 input parameters to subroutine
c "frame".  the first 2 input parameters may be any strings (of length
c equal to the length of logical variables) and the third input
c parameter may be any integer.  the values of the frame counter and
c these input parameters automatically will be displayed, printed,
c punched, etc. to identify the new frame.
c the fourth input parameter, a modulus, is intended for use in making
c multi-color movies from masks on black-and-white film.  a separate
c frame is used for the mask for each color.  the modulus parameter
c should be set to the number of black-and-white masks which are
c required to produce a single frame in the final color movie.  if the
c fourth parameter is between 2 and 99 (inclusive), each frame will have
c as additional identification the value of the frame counter modulo
c this parameter.  if the fourth parameter is outside this interval, it
c will be ignored.  if the color masks are displayed in the same
c sequence for each frame of the final color movie, the masks for each
c color separation will be identified by a unique number modulo the
c fourth parameter.
c
c
c
      subroutine frame(alpha1,alpha2,intger,modlus)
      implicit integer (a-z)
      logical alpha1,alpha2
c
      common /qommon/ chars,mach2k,k2mach,pictx,picty,picher,buf1,
     c   ranseq,
     c   eratio,ldist,rdist,bdist,tdist,maxmsg,wider,higher,prober,
     c   frames,frame1,frame2,frame3,frame4,frscop,frintr,frcard,
     c   prctrl,caller
      integer chars
      logical*1 mach2k(256), k2mach(256)
      integer pictx,picty
      logical*1 picher(320,240), string(76800)
      equivalence (picher(1,1), string(1))
      logical*1 buf1(352)
      integer ranseq(401)
      integer eratio,ldist,rdist,bdist,tdist,maxmsg,wider,higher,prober,
     c   frames
      logical frame1,frame2
      integer frame3,frame4
      logical frscop,frintr,frcard
      logical*1 prctrl,caller(6)
c
      common /com1/ d0,d1,d2,d3,d4,d5,d6,d7,d8,d9
      common /com1/ la,lb,lc,ld,le,lf,lg,lh,li,lj,lk,ll,lm,ln,lo,lp,lq,
     c   lr,ls,lt,lu,lv,lw,lx,ly,lz
      common /com1/ blank,period,lparen,plus,dollar,aster,rparen,minus,
     c   slash,comma,under,equal,quote,less,bar,and,semi,not,prcent,
     c   grater,questn,colon,pound,at,apost
      common /com1/ self,west,east,south,north,swest,nwest,seast,neast,
     c   horiz,vert,aigu,grave,rook,bishop,king
      common /com1/ system,scope,ttyo,ttyi,ptapei,cardi,printr,cardo,
     c   camrao,camrai,fmts
      common /com1/ ttwide,lastin,income,fmtbuf
      integer d0,d1,d2,d3,d4,d5,d6,d7,d8,d9
      integer la,lb,lc,ld,le,lf,lg,lh,li,lj,lk,lm,ln,lo,lp,lq,lr,ls,lt,
     c   lu,lv,lw,lx,ly,lz
      integer blank,period,lparen,plus,dollar,aster,rparen,minus,slash,
     c   comma,under,equal,quote,less,bar,and,semi,not,prcent,grater,
     c   questn,colon,pound,at,apost
      integer self,west,east,south,north,swest,nwest,seast,neast,horiz,
     c   vert,aigu,grave,rook,bishop,king
      integer system,scope,ttyo,ttyi,ptapei,cardi,printr,cardo,camrao,
     c   camrai,fmts
      integer ttwide,lastin
      logical*1 income(72), fmtbuf(160)
c
c asa carriage control character for page eject
      logical*1 eject/'1'/
c
c
c
      frames = frames + 1
      frame1 = alpha1
      frame2 = alpha2
      frame3 = intger
      frame4 = modlus
      frscop = .false.
      frintr = .false.
      frcard = .false.
      prctrl = eject
c type out the new frame identification, so the user can correlate any
c typed error messages with the picture he sees displayed, printed, or
c punched
      if ((modlus .ge. 2) .and. (modlus .le. 99)) go to 1
      call getfmt(9,.false.)
      write (ttyo,fmtbuf) frames,alpha1,alpha2,intger
 2    return
 1    temp = mod(frames,modlus)
      call getfmt(10,.false.)
      write (ttyo,fmtbuf) frames,temp,modlus,alpha1,alpha2,intger
      go to 2
      end
c if identification of the current frame has not yet been printed, print
c it now.
c
c
c
      subroutine qprame
      implicit integer (a-z)
c
      common /qommon/ chars,mach2k,k2mach,pictx,picty,picher,buf1,
     c   ranseq,
     c   eratio,ldist,rdist,bdist,tdist,maxmsg,wider,higher,prober,
     c   frames,frame1,frame2,frame3,frame4,frscop,frintr,frcard,
     c   prctrl,caller
      integer chars
      logical*1 mach2k(256), k2mach(256)
      integer pictx,picty
      logical*1 picher(320,240), string(76800)
      equivalence (picher(1,1), string(1))
      logical*1 buf1(352)
      integer ranseq(401)
      integer eratio,ldist,rdist,bdist,tdist,maxmsg,wider,higher,prober,
     c   frames
      logical frame1,frame2
      integer frame3,frame4
      logical frscop,frintr,frcard
      logical*1 prctrl,caller(6)
c
      common /com1/ d0,d1,d2,d3,d4,d5,d6,d7,d8,d9
      common /com1/ la,lb,lc,ld,le,lf,lg,lh,li,lj,lk,ll,lm,ln,lo,lp,lq,
     c   lr,ls,lt,lu,lv,lw,lx,ly,lz
      common /com1/ blank,period,lparen,plus,dollar,aster,rparen,minus,
     c   slash,comma,under,equal,quote,less,bar,and,semi,not,prcent,
     c   grater,questn,colon,pound,at,apost
      common /com1/ self,west,east,south,north,swest,nwest,seast,neast,
     c   horiz,vert,aigu,grave,rook,bishop,king
      common /com1/ system,scope,ttyo,ttyi,ptapei,cardi,printr,cardo,
     c   camrao,camrai,fmts
      common /com1/ ttwide,lastin,income,fmtbuf
      integer d0,d1,d2,d3,d4,d5,d6,d7,d8,d9
      integer la,lb,lc,ld,le,lf,lg,lh,li,lj,lk,lm,ln,lo,lp,lq,lr,ls,lt,
     c   lu,lv,lw,lx,ly,lz
      integer blank,period,lparen,plus,dollar,aster,rparen,minus,slash,
     c   comma,under,equal,quote,less,bar,and,semi,not,prcent,grater,
     c   questn,colon,pound,at,apost
      integer self,west,east,south,north,swest,nwest,seast,neast,horiz,
     c   vert,aigu,grave,rook,bishop,king
      integer system,scope,ttyo,ttyi,ptapei,cardi,printr,cardo,camrao,
     c   camrai,fmts
      integer ttwide,lastin
      logical*1 income(72), fmtbuf(160)
c
c asa carriage control character for upspacing 2 lines
      logical*1 upsp2/'0'/
c
c
c
      if (frintr) go to 3
      frintr = .true.
c test for use of modulus in frame identification
      if ((frame4 .ge. 2) .and. (frame4 .le. 99)) go to 1
      write (printr,100) frames,frame1,frame2,frame3
 2    prctrl = upsp2
 3    return
 1    temp = mod(frames,frame4)
      write (printr,101) frames,temp,frame4,frame1,frame2,frame3
      go to 2
c the length of the alpha variables depends on computer word size ******
 100  format ('1frame',i7,': ',2(a4,' '),i11)
 101  format ('1frame',i7,' =',i3,' (mod',i3,'): ',2(a4,' '),i11)
      end
c the print subroutines cause printing of a portion of the picture, with
c the option of transliteration on output.  the subroutines are named
c "print0", "print1", "print2", and "print3", where the digit specifies
c how many transliteration tables are to be used.  "print2" and "print3"
c cause overprinting for the 2nd and 3rd transliteration tables.
c the first 4 parameters define a rectangle.  the portion of this
c rectangle which is within the picture will be printed left-justified
c on the page.  the remaining parameters are names of 1-dimensional
c integer arrays containing transliteration tables.  the
c transliteration tables may be of any length, but if they are too short
c for the numeric values of the characters being transliterated, the
c printed output may appear as garbage.
c
c the subroutines were written as entries to save copying the data
c specification cards.  otherwise they would have been written as
c separate subroutines.  "entry" is not valid asa fortran iv. **********
c
c
c
      subroutine print3(xcentr,ycentr,width,height,table1,table2,table3)
      implicit integer (a-z)
      integer table1(1024), table2(1024), table3(1024)
c
      common /qommon/ chars,mach2k,k2mach,pictx,picty,picher,buf1,
     c   ranseq,
     c   eratio,ldist,rdist,bdist,tdist,maxmsg,wider,higher,prober,
     c   frames,frame1,frame2,frame3,frame4,frscop,frintr,frcard,
     c   prctrl,caller
      integer chars
      logical*1 mach2k(256), k2mach(256)
      integer pictx,picty
      logical*1 picher(320,240), string(76800)
      equivalence (picher(1,1), string(1))
      logical*1 buf1(352)
      integer ranseq(401)
      integer eratio,ldist,rdist,bdist,tdist,maxmsg,wider,higher,prober,
     c   frames
      logical frame1,frame2
      integer frame3,frame4
      logical frscop,frintr,frcard
      logical*1 prctrl,caller(6)
c
      common /com1/ d0,d1,d2,d3,d4,d5,d6,d7,d8,d9
      common /com1/ la,lb,lc,ld,le,lf,lg,lh,li,lj,lk,ll,lm,ln,lo,lp,lq,
     c   lr,ls,lt,lu,lv,lw,lx,ly,lz
      common /com1/ blank,period,lparen,plus,dollar,aster,rparen,minus,
     c   slash,comma,under,equal,quote,less,bar,and,semi,not,prcent,
     c   grater,questn,colon,pound,at,apost
      common /com1/ self,west,east,south,north,swest,nwest,seast,neast,
     c   horiz,vert,aigu,grave,rook,bishop,king
      common /com1/ system,scope,ttyo,ttyi,ptapei,cardi,printr,cardo,
     c   camrao,camrai,fmts
      common /com1/ ttwide,lastin,income,fmtbuf
      integer d0,d1,d2,d3,d4,d5,d6,d7,d8,d9
      integer la,lb,lc,ld,le,lf,lg,lh,li,lj,lk,lm,ln,lo,lp,lq,lr,ls,lt,
     c   lu,lv,lw,lx,ly,lz
      integer blank,period,lparen,plus,dollar,aster,rparen,minus,slash,
     c   comma,under,equal,quote,less,bar,and,semi,not,prcent,grater,
     c   questn,colon,pound,at,apost
      integer self,west,east,south,north,swest,nwest,seast,neast,horiz,
     c   vert,aigu,grave,rook,bishop,king
      integer system,scope,ttyo,ttyi,ptapei,cardi,printr,cardo,camrao,
     c   camrai,fmts
      integer ttwide,lastin
      logical*1 income(72), fmtbuf(160)
c
c specifications of called functions
      logical qpradj
c
c height, adjusted to be within the picture
      integer hadj
c boundaries of the rectangle, adjusted to be within the picture
      integer ledge,redge,tedge
c switch determines whether any printing is to be done
      logical xecute
c indices of transliteration table entries which are not characters
      integer tbl1x(3), tbl2x(3), tbl3x(3)
c indices of indices of transliteration table entries
      integer tbl1xx,tbl2xx,tbl3xx
c return locs. for processing illegal table entries
      integer next1,next2
c equivalent storage for indexing with character values
      integer chari/0/
      logical charl
      equivalence (chari,charl)
c asa carriage control characters
      logical*1 upsp1/' '/, noupsp/'+'/
c other characters
      logical*1 space/' '/
c
c
c
      hadj = height
c adjust boundaries, detect errors, test for error message
      if (.not. qpradj(3,xcentr,ycentr,width,hadj,ledge,redge,tedge,
     c   xecute)) go to 1
c at least one error message preceded this.  show the user his actual
c call.
      call getfmt(18,.false.)
      write (ttyo,fmtbuf) xcentr,ycentr,width,height
c ask the user what he wants to do next
      call qnowut
c test whether any printing is to be done
 1    if (.not. xecute) go to 2
c if identification of the current frame has not yet been printed,
c print it now
      call qprame
c clear the print buffer
      do 4 cursor=1,132
 4    buf1(cursor) = space
      tables = 3
c reset indices of indices
      tbl1xx = 0
      tbl2xx = 0
      tbl3xx = 0
c set return locs. for processing illegal table entries
      assign 5 to next1
      assign 6 to next2
c print the picture within the adjusted rectangle.  for efficient
c execution, set up loops using the string equivalent addresses of
c squares in the rectangle.  this allows single indexing in the
c innermost loop, where array addresses would require double indexing.
      tedge = (tedge-1)*pictx + 1
      hadj = (hadj-1)*pictx + 1
      do 3 dy=1,hadj,pictx
      mindex = tedge - dy + ledge
      maxdex = tedge - dy + redge
c first transliteration:  picture (knowltonian) to table1 (knowltonian)
c to table1 (machine)
      cursor = 1
      do 5 index=mindex,maxdex
      charl = string(index)
      entry = table1(chari+1)
      if ((entry .lt. 0) .or. (entry .ge. chars)) go to 31
      buf1(cursor) = k2mach(entry+1)
 5    cursor = cursor + 1
c first printing
      write (printr,100) prctrl, (buf1(cursor), cursor=1,132)
c second transliteration:  picture (knowltonian) to table2
c (knowltonian) to table2 (machine)
      cursor = 1
      do 6 index=mindex,maxdex
      charl = string(index)
      entry = table2(chari+1)
      if ((entry .lt. 0) .or. (entry .ge. chars)) go to 32
      buf1(cursor) = k2mach(entry+1)
 6    cursor = cursor + 1
c second printing
      write (printr,100) noupsp, (buf1(cursor), cursor=1,132)
c third transliteration:  picture (knowltonian) to table3 (knowltonian)
c to table3 (machine)
      cursor = 1
      do 7 index=mindex,maxdex
      charl = string(index)
      entry = table3(chari+1)
      if ((entry .lt. 0) .or. (entry .ge. chars)) go to 33
      buf1(cursor) = k2mach(entry+1)
 7    cursor = cursor + 1
c third printing
      write (printr,100) noupsp, (buf1(cursor), cursor=1,132)
c reset carriage control character for next printed line
 3    prctrl = upsp1
 2    return
c
c
c
c the following is the same as "print3", with only 2 transliterations
      entry print2(xcentr,ycentr,width,height,table1,table2)
      hadj = height
      if (.not. qpradj(2,xcentr,ycentr,width,hadj,ledge,redge,tedge,
     c   xecute)) go to 8
      call getfmt(19,.false.)
      write (ttyo,fmtbuf) xcentr,ycentr,width,height
      call qnowut
 8    if (.not. xecute) go to 2
      call qprame
      do 10 cursor=1,132
 10   buf1(cursor) = space
      tables = 2
      tbl1xx = 0
      tbl2xx = 0
      assign 12 to next1
      assign 13 to next2
      tedge = (tedge-1)*pictx + 1
      hadj = (hadj-1)*pictx + 1
      do 11 dy=1,hadj,pictx
      mindex = tedge - dy + ledge
      maxdex = tedge - dy + redge
      cursor = 1
      do 12 index=mindex,maxdex
      charl = string(index)
      entry = table1(chari+1)
      if ((entry .lt. 0) .or. (entry .ge. chars)) go to 31
      buf1(cursor) = k2mach(entry+1)
 12   cursor = cursor + 1
      write (printr,100) prctrl, (buf1(cursor), cursor=1,132)
      cursor = 1
      do 13 index=mindex,maxdex
      charl = string(index)
      entry = table2(chari+1)
      if ((entry .lt. 0) .or. (entry .ge. chars)) go to 32
      buf1(cursor) = k2mach(entry+1)
 13   cursor = cursor + 1
      write (printr,100) noupsp, (buf1(cursor), cursor=1,132)
 11   prctrl = upsp1
      go to 2
c
c
c
c the following is the same as "print3", with only 1 transliteration
      entry print1(xcentr,ycentr,width,height,table1)
      hadj = height
      if (.not. qpradj(1,xcentr,ycentr,width,hadj,ledge,redge,tedge,
     c   xecute)) go to 14
      call getfmt(20,.false.)
      write (ttyo,fmtbuf) xcentr,ycentr,width,height
      call qnowut
 14   if (.not. xecute) go to 2
      call qprame
      do 15 cursor=1,132
 15   buf1(cursor) = space
      tables = 1
      tbl1xx = 0
      assign 17 to next1
      tedge = (tedge-1)*pictx + 1
      hadj = (hadj-1)*pictx + 1
      do 16 dy=1,hadj,pictx
      mindex = tedge - dy + ledge
      maxdex = tedge - dy + redge
      cursor = 1
      do 17 index=mindex,maxdex
      charl = string(index)
      entry = table1(chari+1)
      if ((entry .lt. 0) .or. (entry .ge. chars)) go to 31
      buf1(cursor) = k2mach(entry+1)
 17   cursor = cursor + 1
      write (printr,100) prctrl, (buf1(cursor), cursor=1,132)
 16   prctrl = upsp1
      go to 2
c
c
c
c the following is the same as "print3", with no transliteration except
c from knowltonian to machine representation
      entry print0(xcentr,ycentr,width,height)
      hadj = height
      if (.not. qpradj(0,xcentr,ycentr,width,hadj,ledge,redge,tedge,
     c   xecute)) go to 18
      call getfmt(21,.false.)
      write (ttyo,fmtbuf) xcentr,ycentr,width,height
      call qnowut
 18   if (.not. xecute) go to 2
      call qprame
      do 19 cursor=1,132
 19   buf1(cursor) = space
      tedge = (tedge-1)*pictx + 1
      hadj = (hadj-1)*pictx + 1
      do 20 dy=1,hadj,pictx
      mindex = tedge - dy + ledge
      maxdex = tedge - dy + redge
      cursor = 1
      do 21 index=mindex,maxdex
      charl = string(index)
      buf1(cursor) = k2mach(chari+1)
 21   cursor = cursor + 1
      write (printr,100) prctrl, (buf1(cursor), cursor=1,132)
 20   prctrl = upsp1
      go to 2
c
c
c
c an illegal entry was encountered in transliteration table 1.  test
c whether to type an error message.
 31   if (tbl1xx .eq. 3) go to next1, (5,12,17)
c test whether any table1 messages have been typed during this call of
c "print"
      if (tbl1xx .eq. 0) go to 34
c compare index = (chari) with previously typed indices
      do 35 i=1,tbl1xx
      if (chari .eq. tbl1x(i)) go to next1, (5,12,17)
 35   continue
c type an error message
 34   call getfmt(46,.false.)
      write (ttyo,fmtbuf) tables,chari
c store (chari) as an index
      tbl1xx = tbl1xx + 1
      tbl1x(tbl1xx) = chari
      go to next1, (5,12,17)
c
c
c
c the following is the same as the code at statement 31, but for
c transliteration table 2
 32   if (tbl2xx .eq. 3) go to next2, (6,13)
      if (tbl2xx .eq. 0) go to 36
      do 37 i=1,tbl2xx
      if (chari .eq. tbl2x(i)) go to next2, (6,13)
 37   continue
 36   call getfmt(47,.false.)
      write (ttyo,fmtbuf) tables,chari
      tbl2xx = tbl2xx + 1
      tbl2x(tbl2xx) = chari
      go to next2, (6,13)
c
c
c
c the following is the same as the code at statement 31, but for
c transliteration table 3
 33   if (tbl3xx .eq. 3) go to 7
      if (tbl3xx .eq. 0) go to 38
      do 39 i=1,tbl3xx
      if (chari .eq. tbl3x(i)) go to 7
 39   continue
 38   call getfmt(48,.false.)
      write (ttyo,fmtbuf) chari
      tbl3xx = tbl3xx + 1
      tbl3x(tbl3xx) = chari
      go to 7
c
c
