c
 100  format (133a1)
      end
c boundary adjustment and error detection for the "print" subroutines.
c the first parameter is the number of transliteration tables used by
c the calling "print" subroutine.  the next 4 parameters define the
c rectangle to be adjusted.  the last 4 parameters are output parameters
c only.
c on exit, the value of the function is .true. if any error messages
c were typed, or .false. otherwise.  output parameter "xecute" is .true.
c if any printing is to be done.  if it is .true., then "height" has
c been adjusted to the height of the part of the rectangle within the
c picture, and "ledge", "redge", and "tedge" have been set to the left
c edge, right edge, and top edge of the part of the rectangle within the
c picture.
c
c
c
      logical function qpradj(tables,xcentr,ycentr,width,height,
     c   ledge,redge,tedge,xecute)
      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 bottom edge of the rectangle, not included as a parameter
      integer bedge
c distances outside the picture which last caused error messages
      integer distl/0/, distr/0/,distb/0/, distt/0/
c counts of consecutive error messages for illegal parameters
      integer erwide/1/, erhigh/1/, er132/1/
c
c
c
c initially no errors detected
      qpradj = .false.
      xecute = .true.
c compute boundaries of the rectangle
      if (width .lt. 1) go to 1
      ledge = xcentr - (width-1)/2
      if (ledge .lt. 1) go to 2
 19   redge = xcentr + width/2
      if (redge .gt. pictx) go to 3
c constrain printing to max. number of printer columns
 14   if (redge-ledge .gt. 131) go to 10
c reset error count
      er132 = 1
c reset error count
 11   erwide = 1
 15   if (height .lt. 1) go to 4
      bedge = ycentr - (height-1)/2
      if (bedge .lt. 1) go to 5
 22   tedge = ycentr + height/2
      if (tedge .gt. picty) go to 6
c test whether any part of the rectangle is in the picture
 24   xecute = xecute .and. (ledge .le. pictx) .and. (redge .ge. 1)
     c   .and. (bedge .le. picty) .and. (tedge .ge. 1)
c reset error count
 16   erhigh = 1
c recalculate adjusted height
      height = tedge - bedge + 1
 17   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 (erwide .gt. maxmsg) go to 15
      erwide = erwide + 1
      qpradj = .true.
      call getfmt(11,.false.)
      write (ttyo,fmtbuf) tables
      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 (erhigh .gt. maxmsg) go to 17
      erhigh = erhigh + 1
      qpradj = .true.
      call getfmt(12,.false.)
      write (ttyo,fmtbuf) tables
      go to 17
c the left edge of the rectangle is to the left of the picture
 2    if (1-ledge .lt. distl*eratio) go to 18
      distl = 1 - ledge
      qpradj = .true.
      call getfmt(14,.false.)
      write (ttyo,fmtbuf) tables,distl
c reset left edge of rectangle to left edge of picture
 18   ledge = 1
      go to 19
c the right edge of the rectangle is to the right of the picture
 3    if (redge-pictx .lt. distr*eratio) go to 20
      distr = redge - pictx
      qpradj = .true.
      call getfmt(15,.false.)
      write (ttyo,fmtbuf) tables,distr
c reset right edge of rectangle to right edge of picture
 20   redge = pictx
      go to 14
c the bottom edge of the rectangle is below the picture
 5    if (1-bedge .lt. distb*eratio) go to 21
      distb = 1 - bedge
      qpradj = .true.
      call getfmt(16,.false.)
      write (ttyo,fmtbuf) tables,distb
c reset bottom edge of rectangle to bottom edge of picture
 21   bedge = 1
      go to 22
c the top edge of the rectangle is above the picture
 6    if (tedge-picty .lt. distt*eratio) go to 23
      distt = tedge - picty
      qpradj = .true.
      call getfmt(17,.false.)
      write (ttyo,fmtbuf) tables,distt
c reset top edge of rectangle to top edge of picture
 23   tedge = picty
      go to 24
c even after adjusting the rectangle boundaries to lie within the
c picture, the width is greater than the max. number of printer columns
 10   redge = ledge + 131
c test error count
      if (er132 .gt. maxmsg) go to 11
      er132 = er132 + 1
      qpradj = .true.
      call getfmt(69,.false.)
      write (ttyo,fmtbuf) tables
      go to 11
      end
c if identification of the current frame has not yet been punched, punch
c it now.
c
c
c
      subroutine qfunch
      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
c
      if (frcard) go to 3
      frcard = .true.
c test for use of modulus in frame identification
      if ((frame4 .ge. 2) .and. (frame4 .le. 99)) go to 1
      write (cardo,100) frames,frame1,frame2,frame3
 3    return
 1    temp = mod(frames,frame4)
      write (cardo,101) frames,temp,frame4,frame1,frame2,frame3
      go to 3
c the length of the alpha variables depends on computer word size ******
 100  format (1x/'frame',i7,': ',2(a4,' '),i11,' ',44(1h*)/1x)
 101  format (1x/'frame',i7,' =',i3,' (mod',i3,'): ',2(a4,' '),i11,' ',
     c30(1h*)/1x)
      end
c the punch subroutines cause punching on cards of a portion of the
c picture, with the option of transliteration on output.  the
c subroutines are named "punch0" and "punch1", where the digit specifies
c how many transliteration tables are to be used.  the first 4
c parameters define a rectangle.  the portion of this rectangle which is
c within the picture will be punched.  if the rectangle extends to the
c left of the picture by "c" columns, the punched cards will be indented
c by "c" columns.  the last parameter is the name of a 1-dimensional
c integer array containing the transliteration table.  the
c transliteration table may be of any length, but if it is too short for
c the numeric values of the characters being transliterated, the punched
c 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 punch1(xcentr,ycentr,width,height,table1)
      implicit integer (a-z)
      integer table1(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 qpundj
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 card column corresponding to picture column "ledge"
      integer lcol
c switch determines whether any punching is to be done
      logical xecute
c indices of transliteration table entries which are not characters
      integer tablx(3)
c index of indices of transliteration table entries
      integer tablxx
c equivalent storage for indexing with character values
      integer chari/0/
      logical charl
      equivalence (chari,charl)
c other characters
      logical*1 space/' '/
c
c
c
      hadj = height
c adjust boundaries, detect errors, test for error message
      if (.not. qpundj(1,xcentr,ycentr,width,hadj,
     c   ledge,redge,tedge,lcol,xecute)) go to 1
c at least one error message preceded this.  show the user his actual
c call.
      call getfmt(76,.false.)
      write (ttyo,fmtbuf) xcentr,ycentr,width,height
c ask the user what he wants to do next
      call qnowut
c test whether any punching is to be done
 1    if (.not. xecute) go to 2
c if identification of the current frame has not yet been punched, punch
c it now
      call qfunch
c clear the punch buffer
      do 4 cursor=1,80
 4    buf1(cursor) = space
c reset index of indices
      tablxx = 0
c punch 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 transliteration:  picture (knowltonian) to table1 (knowltonian) to
c table1 (machine)
      cursor = lcol
      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 punch
      write (cardo,100) (buf1(cursor), cursor=1,80)
 3    continue
 2    return
c
c
c
c the following is the same as "punch1", with no transliteration except
c from knowltonian to machine representation
      entry punch0(xcentr,ycentr,width,height)
      hadj = height
      if (.not. qpundj(0,xcentr,ycentr,width,hadj,
     c   ledge,redge,tedge,lcol,xecute)) go to 18
      call getfmt(77,.false.)
      write (ttyo,fmtbuf) xcentr,ycentr,width,height
      call qnowut
 18   if (.not. xecute) go to 2
      call qfunch
      do 19 cursor=1,80
 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 = lcol
      do 21 index=mindex,maxdex
      charl = string(index)
      buf1(cursor) = k2mach(chari+1)
 21   cursor = cursor + 1
      write (cardo,100) (buf1(cursor), cursor=1,80)
 20   continue
      go to 2
c
c
c
c an illegal transliteration table entry was encountered.  test whether
c to type an error message.
 31   if (tablxx .eq. 3) go to 5
c test whether any messages have been typed during this call of "punch1"
      if (tablxx .eq. 0) go to 34
c compare index = (chari) with previously typed indices
      do 35 i=1,tablxx
      if (chari .eq. tablx(i)) go to 5
 35   continue
c type an error message
 34   call getfmt(79,.false.)
      write (ttyo,fmtbuf) chari
c store (chari) as an index
      tablxx = tablxx + 1
      tablx(tablxx) = chari
      go to 5
c
c
c
 100  format (80a1)
      end
c boundary adjustment and error detection for the "punch" subroutines.
c the first parameter is the number of transliteration tables used by
c the calling "punch" subroutine.  the next 4 parameters define the
c rectangle to be adjusted.  the last 5 parameters are output parameters
c only.
c on exit, the value of the function is .true. if any error messages
c were typed, or .false. otherwise.  output parameter "xecute" is .true.
c if any punching is to be done.  if it is .true., then "height" has
c been adjusted to the height of the part of the rectangle within the
c picture, and "ledge", "redge", and "tedge" have been set to the left
c edge, right edge, and top edge of the part of the rectangle within the
c picture.  "lcol" has been set to the card column corresponding to
c picture column "ledge".
c
c
c
      logical function qpundj(tables,xcentr,ycentr,width,height,
     c   ledge,redge,tedge,lcol,xecute)
      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 bottom edge of the rectangle, not included as a parameter
      integer bedge
c
c
c
c initially no errors detected
      qpundj = .false.
      xecute = .true.
      lcol = 1
c compute boundaries of the rectangle
      if (width .lt. 1) go to 1
      ledge = xcentr - (width-1)/2
      if (ledge .lt. 1) go to 2
 19   redge = xcentr + width/2
      if (redge .gt. pictx) go to 3
c constrain punching to max. number of card columns
 14   if (redge-ledge+lcol .gt. 80) go to 10
 15   if (height .lt. 1) go to 4
      bedge = ycentr - (height-1)/2
      if (bedge .lt. 1) go to 5
 22   tedge = ycentr + height/2
      if (tedge .gt. picty) go to 6
c test whether any part of the rectangle is in the picture
 24   xecute = xecute .and. (ledge .le. pictx) .and. (redge .ge. 1)
     c   .and. (bedge .le. picty) .and. (tedge .ge. 1)
c recalculate adjusted height
      height = tedge - bedge + 1
 17   return
c process nonpositive width parameter
 1    xecute = .false.
      qpundj = .true.
      call getfmt(70,.false.)
      write (ttyo,fmtbuf) tables
      go to 15
c process nonpositive height parameter
 4    xecute = .false.
      qpundj = .true.
      call getfmt(71,.false.)
      write (ttyo,fmtbuf) tables
      go to 17
c the left edge of the rectangle is to the left of the picture
 2    qpundj = .true.
      call getfmt(72,.false.)
      write (ttyo,fmtbuf) tables
c reset left edge of rectangle to left edge of picture
      lcol = 2 - ledge
      ledge = 1
      go to 19
c the right edge of the rectangle is to the right of the picture
 3    qpundj = .true.
      call getfmt(73,.false.)
      write (ttyo,fmtbuf) tables
c reset right edge of rectangle to right edge of picture
      redge = pictx
      go to 14
c the bottom edge of the rectangle is below the picture
 5    qpundj = .true.
      call getfmt(69,.false.)
      write (ttyo,fmtbuf) tables
c reset bottom edge of rectangle to bottom edge of picture
      bedge = 1
      go to 22
c the top edge of the rectangle is above the picture
 6    qpundj = .true.
      call getfmt(74,.false.)
      write (ttyo,fmtbuf) tables
c reset top edge of rectangle to top edge of picture
      tedge = picty
      go to 24
c specified width is greater than max. number of card columns
 10   redge = ledge - lcol + 80
      qpundj = .true.
      call getfmt(75,.false.)
      write (ttyo,fmtbuf) tables
      go to 15
      end
c ask the user what he wants to do next.  this subroutine normally is
c called after typing an error message.  only the first nonblank
c character of the user's response is scanned.  possible responses are:
c "h", call subroutine "histry", then ask what next again; "c", continue
c execution by a normal return from "qnowut"; "s", stop execution
c without a storage dump; "d", stop execution with a storage dump.
c
c
c
      subroutine qnowut
      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 equivalent storage for testing character values
      integer typedi/0/, consti/0/
      logical typedl,constl
      equivalence (typedi,typedl), (consti,constl)
c valid characters for user's response
      logical*1 h/'h'/, c/'c'/, s/'s'/, d/'d'/, space/' '/
c
c
c
c remove this and the next 2 cards for conversational use **************
      lastin = 1
      income(1) = h
 1    call getfmt(1,.true.)
      write (ttyo,fmtbuf)
c test for empty line
      if (lastin .eq. 0) go to 1
c scan response for first nonblank character
      constl = space
      do 2 i=1,lastin
      typedl = income(i)
      if (typedi .ne. consti) go to 3
 2    continue
c if execution passes here, the user's response was entirely blank
      go to 1
c test the first nonblank character of the user's response
 3    constl = c
      if (typedi .eq. consti) return
      constl = s
      if (typedi .eq. consti) stop
      constl = d
      if (typedi .eq. consti) i = 1/0/0/0/0/0/0
      constl = h
      if (typedi .ne. consti) call huh
      call histry
c remove this and the next card for conversational use *****************
      income(1) = c
      go to 1
      end
c this subroutine should be called only if the calling superroutine
c cannot understand a solicited response typed in by the user.
c subroutine "huh" does not return control to its calling superroutine.
c
c
c
      subroutine huh
c recode for conversational use ****************************************
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
c
      write (ttyo,100)
      call histry
      stop
 100  format (' huh')
      end
c this subroutine should be called only if the calling superroutine
c cannot understand an unsolicited message typed in by the user.
c subroutine "notme" does not return control to its calling
c superroutine.
c
c
c
      subroutine notme
c recode for conversational use ****************************************
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
c
      write (ttyo,100)
      call histry
      stop
 100  format (' not me')
      end
c write to teletype using format specification "number", no reply.
c
c
c
      subroutine qttyo(number)
      integer number
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
c
      call getfmt(number,.false.)
      write (ttyo,fmtbuf)
      return
      end
c instead of using "format" statements, all format specifications used
c for typing out messages to the user's terminal should be stored in a
c file of card images on disk (or drum).  this subroutine reads card
c image "number" into buffer "fmtbuf" in "com1".  "fmtbuf" then may be
c used in place of a format statement number as part of the "write"
c statement.  "reply" should be given the value .true. if a reply is
c expected from the user following completion of the "write", or the
c value .false. if no reply is expected.  if "reply" is set .true.,
c the next executed "write" statement to the user's terminal will not
c return control until after the user finishes typing his reply.
c
c a format specification consists of everything in a normal "format"
c statement following, but not including, the word "format".  each
c format specification must start on a separate card image and may
c occupy any of columns 1 to 80.  the format specification may be
c continued on at most 1 additional card image.  the continuation card
c is treated as an extension to 160 columns of the first card, with no
c special continuation marks or other unique identification.
c
c this subroutine is coded using a "define file" statement which is not
c valid asa fortran iv.  "define file" is used to get direct access to
c the desired card image.  in its absence, a "rewind" and "number"
c consecutive "read"s from the card file "fmts" could achieve the same
c effect.  the "define file" appears as part of subroutine "init".
c
c
c
c "reply" has not yet been coded ***************************************
c
      subroutine getfmt(number,reply)
      implicit integer (a-z)
      logical reply
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 maximum card image number in file "fmts" *****************************
      integer maxrec/88/
c
c
c
c check for valid format specification card image number
      if ((number .lt. 1) .or. (number .gt. maxrec-1)) go to 1
c read 2 card images, in case format specification continues on 2nd card
      call q4mat(number,1)
      call q4mat(number+1,81)
      return
c subroutine "getfmt" cannot call itself recursively, so the error
c message must be core resident.  the user must not be allowed to reply
c to this message.
 1    write (ttyo,101) number,reply
      call histry
      stop
 101  format (' err in 1st param of: getfmt(', i11, ',', l1, ')')
      end
c copy format card image "number" into the format buffer, starting at
c "fmtbuf(column)".
c the format card images may be blocked in disk storage.  this
c subroutine reads the appropriate block, if the block is not in core
c memory already.
c
c
c
      subroutine q4mat(number,column)
      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 number of card images per disk block = blocking factor, must be
c changed if the blocking factor is changed ****************************
      integer prblok/44/
c block size = 80*prblok ***********************************************
      integer blksiz/3520/
c buffer for a block of card images ************************************
      logical*1 block(3520)
c number of the desired block
      integer desire
c number of the block currently in core memory, initially none
      integer incore/0/
c
c
c
c read the block if it is not in core memory already
      desire = (number-1)/prblok + 1
c
c
c     if (desire .eq. incore) go to 1                                   dir acc
c     read (fmts ' desire, 100) (block(i), i=1,blksiz)                  dir acc
c
